04 Jul '25
Hassan Al-Awwadi pushed new branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/haanss/depdir
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/spec_tyfams] 3 commits: Specialise: Improve specialisation by refactoring interestingDict
by Simon Peyton Jones (＠simonpj) 04 Jul '25
by Simon Peyton Jones (＠simonpj) 04 Jul '25
04 Jul '25
Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
47feb375 by Andreas Klebinger at 2025-07-04T22:47:13+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]`
- - - - -
bdbbedae by Simon Peyton Jones at 2025-07-04T22:47:58+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.
- - - - -
ae8740b3 by Andreas Klebinger at 2025-07-04T22:58:58+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.
- - - - -
16 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/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 (ID4)
+ -> 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)
+ , not_ip_like -- See (ID4)
+ = if null (classMethods cls) -- See (ID6)
+ then any (interestingDict env) args
+ else True
+
+ | otherwise
+ = not (exprIsTrivial arg) && not_ip_like -- See (ID8)
+ where
+ arg_ty = exprType arg
+ 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,91 @@ 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`.
+
+(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 thes 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.
+
+(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 +3269,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 +3285,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/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/3db11f250db73518752615c5a0439f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3db11f250db73518752615c5a0439f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
04 Jul '25
Cheng Shao pushed to branch wip/symbolizer at Glasgow Haskell Compiler / GHC
Commits:
237b7508 by Cheng Shao at 2025-07-04T21:04:36+00:00
rts: remove libbfd logic
- - - - -
9 changed files:
- configure.ac
- hadrian/cfg/system.config.in
- hadrian/src/Oracles/Flag.hs
- hadrian/src/Settings/Packages.hs
- − m4/fp_bfd_support.m4
- rts/Printer.c
- rts/configure.ac
- rts/include/rts/Config.h
- rts/rts.cabal
Changes:
=====================================
configure.ac
=====================================
@@ -868,9 +868,6 @@ AC_SUBST([UseLibm])
TargetHasLibm=$UseLibm
AC_SUBST(TargetHasLibm)
-FP_BFD_FLAG
-AC_SUBST([UseLibbfd])
-
dnl ################################################################
dnl Check for libraries
dnl ################################################################
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -120,7 +120,6 @@ use-lib-numa = @UseLibNuma@
use-lib-m = @UseLibm@
use-lib-rt = @UseLibrt@
use-lib-dl = @UseLibdl@
-use-lib-bfd = @UseLibbfd@
use-lib-pthread = @UseLibpthread@
need-libatomic = @NeedLibatomic@
=====================================
hadrian/src/Oracles/Flag.hs
=====================================
@@ -37,7 +37,6 @@ data Flag = CrossCompiling
| UseLibm
| UseLibrt
| UseLibdl
- | UseLibbfd
| UseLibpthread
| NeedLibatomic
| UseGhcToolchain
@@ -61,7 +60,6 @@ flag f = do
UseLibm -> "use-lib-m"
UseLibrt -> "use-lib-rt"
UseLibdl -> "use-lib-dl"
- UseLibbfd -> "use-lib-bfd"
UseLibpthread -> "use-lib-pthread"
NeedLibatomic -> "need-libatomic"
UseGhcToolchain -> "use-ghc-toolchain"
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -440,7 +440,6 @@ rtsPackageArgs = package rts ? do
, useSystemFfi `cabalFlag` "use-system-libffi"
, useLibffiForAdjustors `cabalFlag` "libffi-adjustors"
, flag UseLibpthread `cabalFlag` "need-pthread"
- , flag UseLibbfd `cabalFlag` "libbfd"
, flag NeedLibatomic `cabalFlag` "need-atomic"
, flag UseLibdw `cabalFlag` "libdw"
, flag UseLibnuma `cabalFlag` "libnuma"
=====================================
m4/fp_bfd_support.m4 deleted
=====================================
@@ -1,59 +0,0 @@
-# FP_BFD_SUPPORT()
-# ----------------------
-# Whether to use libbfd for debugging RTS
-#
-# Sets:
-# UseLibbfd: [YES|NO]
-AC_DEFUN([FP_BFD_FLAG], [
- UseLibbfd=NO
- AC_ARG_ENABLE(bfd-debug,
- [AS_HELP_STRING([--enable-bfd-debug],
- [Enable symbol resolution for -debug rts ('+RTS -Di') via binutils' libbfd [default=no]])],
- [UseLibbfd=YES],
- [UseLibbfd=NO])
-])
-
-# FP_WHEN_ENABLED_BFD
-# ----------------------
-# Checks for libraries in the default way, which will define various
-# `HAVE_*` macros.
-AC_DEFUN([FP_WHEN_ENABLED_BFD], [
- # don't pollute general LIBS environment
- save_LIBS="$LIBS"
- AC_CHECK_HEADERS([bfd.h])
- dnl ** check whether this machine has BFD and libiberty installed (used for debugging)
- dnl the order of these tests matters: bfd needs libiberty
- AC_CHECK_LIB(iberty, xmalloc)
- dnl 'bfd_init' is a rare non-macro in libbfd
- AC_CHECK_LIB(bfd, bfd_init)
-
- AC_LINK_IFELSE(
- [AC_LANG_PROGRAM(
- [[#include <bfd.h>]],
- [[
- /* mimic our rts/Printer.c */
- bfd* abfd;
- const char * name;
- char **matching;
-
- name = "some.executable";
- bfd_init();
- abfd = bfd_openr(name, "default");
- bfd_check_format_matches (abfd, bfd_object, &matching);
- {
- long storage_needed;
- storage_needed = bfd_get_symtab_upper_bound (abfd);
- }
- {
- asymbol **symbol_table;
- long number_of_symbols;
- symbol_info info;
-
- number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
- bfd_get_symbol_info(abfd,symbol_table[0],&info);
- }
- ]])],
- [], dnl bfd seems to work
- [AC_MSG_ERROR([can't use 'bfd' library])])
- LIBS="$save_LIBS"
-])
=====================================
rts/Printer.c
=====================================
@@ -872,110 +872,11 @@ const char *lookupGHCName( void *addr )
* Symbol table loading
* ------------------------------------------------------------------------*/
-/* Causing linking trouble on Win32 plats, so I'm
- disabling this for now.
-*/
-#if defined(USING_LIBBFD)
-# define PACKAGE 1
-# define PACKAGE_VERSION 1
-/* Those PACKAGE_* defines are workarounds for bfd:
- * https://sourceware.org/bugzilla/show_bug.cgi?id=14243
- * ghc's build system filter PACKAGE_* values out specifically to avoid clashes
- * with user's autoconf-based Cabal packages.
- * It's a shame <bfd.h> checks for unrelated fields instead of actually used
- * macros.
- */
-# include <bfd.h>
-
-/* Fairly ad-hoc piece of code that seems to filter out a lot of
- * rubbish like the obj-splitting symbols
- */
-
-static bool isReal( flagword flags STG_UNUSED, const char *name )
-{
-#if 0
- /* ToDo: make this work on BFD */
- int tp = type & N_TYPE;
- if (tp == N_TEXT || tp == N_DATA) {
- return (name[0] == '_' && name[1] != '_');
- } else {
- return false;
- }
-#else
- if (*name == '\0' ||
- (name[0] == 'g' && name[1] == 'c' && name[2] == 'c') ||
- (name[0] == 'c' && name[1] == 'c' && name[2] == '.')) {
- return false;
- }
- return true;
-#endif
-}
-
-extern void DEBUG_LoadSymbols( const char *name )
-{
- bfd* abfd;
- char **matching;
-
- bfd_init();
- abfd = bfd_openr(name, "default");
- if (abfd == NULL) {
- barf("can't open executable %s to get symbol table", name);
- }
- if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
- barf("mismatch");
- }
-
- {
- long storage_needed;
- asymbol **symbol_table;
- long number_of_symbols;
- long num_real_syms = 0;
- long i;
-
- storage_needed = bfd_get_symtab_upper_bound (abfd);
-
- if (storage_needed < 0) {
- barf("can't read symbol table");
- }
- symbol_table = (asymbol **) stgMallocBytes(storage_needed,"DEBUG_LoadSymbols");
-
- number_of_symbols = bfd_canonicalize_symtab (abfd, symbol_table);
-
- if (number_of_symbols < 0) {
- barf("can't canonicalise symbol table");
- }
-
- if (add_to_fname_table == NULL)
- add_to_fname_table = allocHashTable();
-
- for( i = 0; i != number_of_symbols; ++i ) {
- symbol_info info;
- bfd_get_symbol_info(abfd,symbol_table[i],&info);
- if (isReal(info.type, info.name)) {
- insertHashTable(add_to_fname_table,
- info.value, (void*)info.name);
- num_real_syms += 1;
- }
- }
-
- IF_DEBUG(interpreter,
- debugBelch("Loaded %ld symbols. Of which %ld are real symbols\n",
- number_of_symbols, num_real_syms)
- );
-
- stgFree(symbol_table);
- }
-}
-
-#else /* USING_LIBBFD */
-
extern void DEBUG_LoadSymbols( const char *name STG_UNUSED )
{
/* nothing, yet */
}
-#endif /* USING_LIBBFD */
-
void findPtr(P_ p, int); /* keep gcc -Wall happy */
int searched = 0;
=====================================
rts/configure.ac
=====================================
@@ -171,8 +171,6 @@ AS_IF(
[test "$CABAL_FLAG_libm" = 1],
[AC_DEFINE([HAVE_LIBM], [1], [Define to 1 if you need to link with libm])])
-AS_IF([test "$CABAL_FLAG_libbfd" = 1], [FP_WHEN_ENABLED_BFD])
-
dnl ################################################################
dnl Check for libraries
dnl ################################################################
=====================================
rts/include/rts/Config.h
=====================================
@@ -19,13 +19,6 @@
#error TICKY_TICKY is incompatible with THREADED_RTS
#endif
-/*
- * Whether the runtime system will use libbfd for debugging purposes.
- */
-#if defined(DEBUG) && defined(HAVE_BFD_H) && defined(HAVE_LIBBFD) && !defined(_WIN32)
-#define USING_LIBBFD 1
-#endif
-
/*
* We previously only offer the eventlog in a subset of RTS ways; we now
* enable it unconditionally to simplify packaging. See #18948.
@@ -101,4 +94,3 @@ code.
#else
#define CACHELINE_SIZE 64
#endif
-
=====================================
rts/rts.cabal
=====================================
@@ -46,9 +46,6 @@ flag libffi-adjustors
flag need-pthread
default: False
manual: True
-flag libbfd
- default: False
- manual: True
flag need-atomic
default: False
manual: True
@@ -250,9 +247,6 @@ library
if flag(need-atomic)
-- for sub-word-sized atomic operations (#19119)
extra-libraries: atomic
- if flag(libbfd)
- -- for debugging
- extra-libraries: bfd iberty
if flag(libdw)
-- for backtraces
extra-libraries: elf dw
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/237b750831434016450e320ff6e2462…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/237b750831434016450e320ff6e2462…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Cheng Shao pushed new branch wip/symbolizer at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/symbolizer
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/spec_tyfams] Ugh. Wibble to avoid confusing Haddock
by Simon Peyton Jones (＠simonpj) 04 Jul '25
by Simon Peyton Jones (＠simonpj) 04 Jul '25
04 Jul '25
Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
3db11f25 by Simon Peyton Jones at 2025-07-04T16:30:24+01:00
Ugh. Wibble to avoid confusing Haddock
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/DmdAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -2194,7 +2194,8 @@ 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 || isCTupleClass cls)
+ -> not (isEqualityClass cls)
-- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]
--
-- *** TODO *** document the removal of isCTupleClass!
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3db11f250db73518752615c5a0439fd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3db11f250db73518752615c5a0439fd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
04 Jul '25
Simon Peyton Jones pushed new branch wip/T23162-spj at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T23162-spj
You're receiving this email because of your account on gitlab.haskell.org.
1
0
04 Jul '25
Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
5bd2bca3 by Simon Peyton Jones at 2025-07-04T14:32:49+01:00
Wibble imports
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/Specialise.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -66,7 +66,7 @@ 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)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bd2bca35d91f95a9dd1fe1e239cbb7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bd2bca35d91f95a9dd1fe1e239cbb7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/spec_tyfams] 2 commits: Treat tuple dicationaries uniformly; don't unbox them
by Simon Peyton Jones (＠simonpj) 04 Jul '25
by Simon Peyton Jones (＠simonpj) 04 Jul '25
04 Jul '25
Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
39a685d7 by Simon Peyton Jones at 2025-07-04T13:52:43+01:00
Treat tuple dicationaries uniformly; don't unbox them
See the explanation in
https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297
ToDo: needs better Notes etc. This is for CI
- - - - -
e9bce3a3 by Simon Peyton Jones at 2025-07-04T13:55:01+01:00
Comment out the ad-hoc specCase stuff
See #26158. Needs more documentation
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Specialise.hs
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,8 +2194,10 @@ 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 {- || isCTupleClass cls -})
-- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]
+ --
+ -- *** TODO *** document the removal of isCTupleClass!
_ -> False
@@ -2243,7 +2245,7 @@ Wrinkle (DNB1): we /do/ want to unbox tuple dictionaries (#23398)
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
+ `d`. The Simplifier 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 %)
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1283,6 +1283,7 @@ specCase :: SpecEnv
, OutId
, [OutAlt]
, UsageDetails)
+{-
specCase env scrut' case_bndr [Alt con args rhs]
| -- See Note [Floating dictionaries out of cases]
isDictTy (idType case_bndr)
@@ -1343,6 +1344,7 @@ specCase env scrut' case_bndr [Alt con args rhs]
&& tyCoVarsOfType var_ty `disjointVarSet` arg_set
where
var_ty = idType var
+-}
specCase env scrut case_bndr alts
= do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e61488225a0c5a97e0a77443592c16…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e61488225a0c5a97e0a77443592c16…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out-9] ghci: Allocate BreakArrays at link time only
by Rodrigo Mesquita (＠alt-romes) 04 Jul '25
by Rodrigo Mesquita (＠alt-romes) 04 Jul '25
04 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC
Commits:
92555217 by Rodrigo Mesquita at 2025-07-04T13:02:15+01: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).
- - - - -
10 changed files:
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Eval.hs
- − compiler/GHC/Runtime/Interpreter.hs-boot
- − compiler/GHC/Runtime/Interpreter/Types.hs-boot
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -58,15 +58,16 @@ linkBCO
:: Interp
-> PkgsLoaded
-> LinkerEnv
+ -> LinkedBreaks
-> NameEnv Int
-> UnlinkedBCO
-> IO ResolvedBCO
-linkBCO interp pkgs_loaded le bco_ix
+linkBCO interp pkgs_loaded le lb bco_ix
(UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
-- fromIntegral Word -> Word64 should be a no op if Word is Word64
-- otherwise it will result in a cast to longlong on 32bit systems.
- (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0)
- ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0)
+ (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0)
+ ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0)
let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian
, resolvedBCOArity = arity
@@ -76,8 +77,8 @@ linkBCO interp pkgs_loaded le bco_ix
, resolvedBCOPtrs = addListToSS emptySS ptrs
}
-lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
-lookupLiteral interp pkgs_loaded le ptr = case ptr of
+lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word
+lookupLiteral interp pkgs_loaded le lb ptr = case ptr of
BCONPtrWord lit -> return lit
BCONPtrLbl sym -> do
Ptr a# <- lookupStaticPtr interp sym
@@ -99,7 +100,7 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of
pure $ fromIntegral p
BCONPtrCostCentre BreakpointId{..}
| interpreterProfiled interp -> do
- case expectJust (lookupModuleEnv (ccs_env le) bi_tick_mod) ! bi_tick_index of
+ case expectJust (lookupModuleEnv (ccs_env lb) bi_tick_mod) ! bi_tick_index of
RemotePtr p -> pure $ fromIntegral p
| otherwise ->
case toRemotePtr nullPtr of
@@ -158,10 +159,11 @@ resolvePtr
:: Interp
-> PkgsLoaded
-> LinkerEnv
+ -> LinkedBreaks
-> NameEnv Int
-> BCOPtr
-> IO ResolvedBCOPtr
-resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
+resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of
BCOPtrName nm
| Just ix <- lookupNameEnv bco_ix nm
-> return (ResolvedBCORef ix) -- ref to another BCO in this group
@@ -182,10 +184,10 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
-> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
BCOPtrBCO bco
- -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco
+ -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco
BCOPtrBreakArray tick_mod ->
- withForeignRef (expectJust (lookupModuleEnv (breakarray_env le) tick_mod)) $
+ withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $
\ba -> pure $ ResolvedBCOPtrBreakArray ba
-- | Look up the address of a Haskell symbol in the currently
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -97,8 +97,8 @@ import GHC.Unit.Module.Deps
import Data.List (partition)
import Data.IORef
-import Data.Traversable (for)
import GHC.Iface.Make (mkRecompUsageInfo)
+import GHC.Runtime.Interpreter (interpreterProfiled)
{-
************************************************************************
@@ -162,13 +162,12 @@ deSugar hsc_env
mod mod_loc
export_set (typeEnvTyCons type_env) binds
else return (binds, Nothing)
- ; modBreaks <- for
- [ (i, s)
- | i <- hsc_interp hsc_env
- , (_, s) <- m_tickInfo
- , breakpointsAllowed dflags
- ]
- $ \(interp, specs) -> mkModBreaks interp mod specs
+ ; let modBreaks
+ | Just (_, specs) <- m_tickInfo
+ , breakpointsAllowed dflags
+ = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs
+ | otherwise
+ = Nothing
; ds_hpc_info <- case m_tickInfo of
Just (orig_file2, ticks)
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -33,14 +33,6 @@ import GHC.Unit.Module (Module)
import GHC.Utils.Outputable
import Data.List (intersperse)
-import GHCi.BreakArray (BreakArray)
-import GHCi.RemoteTypes (ForeignRef)
-
--- TODO: Break this cycle
-import {-# SOURCE #-} GHC.Runtime.Interpreter.Types (Interp, interpreterProfiled)
-import {-# SOURCE #-} qualified GHC.Runtime.Interpreter as GHCi (newBreakArray)
-import Data.Array.Base (numElements)
-
--------------------------------------------------------------------------------
-- ModBreaks
--------------------------------------------------------------------------------
@@ -58,10 +50,7 @@ import Data.Array.Base (numElements)
-- and 'modBreaks_decls'.
data ModBreaks
= ModBreaks
- { modBreaks_flags :: ForeignRef BreakArray
- -- ^ The array of flags, one per breakpoint,
- -- indicating which breakpoints are enabled.
- , modBreaks_locs :: !(Array BreakTickIndex SrcSpan)
+ { modBreaks_locs :: !(Array BreakTickIndex SrcSpan)
-- ^ An array giving the source span of each breakpoint.
, modBreaks_vars :: !(Array BreakTickIndex [OccName])
-- ^ An array giving the names of the free variables at each breakpoint.
@@ -83,40 +72,31 @@ data ModBreaks
-- generator needs to encode this information for each expression, the data is
-- allocated remotely in GHCi's address space and passed to the codegen as
-- foreign pointers.
-mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks
-mkModBreaks interp mod extendedMixEntries
- = do
- let count = fromIntegral $ sizeSS extendedMixEntries
+mkModBreaks :: Bool {-^ Whether the interpreter is profiled and thus if we should include store a CCS array -}
+ -> Module -> SizedSeq Tick -> ModBreaks
+mkModBreaks interpreterProfiled modl extendedMixEntries
+ = let count = fromIntegral $ sizeSS extendedMixEntries
entries = ssElts extendedMixEntries
- let
- locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
- varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
- declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
- ccs
- | interpreterProfiled interp =
- listArray
- (0, count - 1)
- [ ( concat $ intersperse "." $ tick_path t,
- renderWithContext defaultSDocContext $ ppr $ tick_loc t
- )
- | t <- entries
- ]
- | otherwise = listArray (0, -1) []
- hydrateModBreaks interp $
- ModBreaks
- { modBreaks_flags = undefined,
- modBreaks_locs = locsTicks,
- modBreaks_vars = varsTicks,
- modBreaks_decls = declsTicks,
- modBreaks_ccs = ccs,
- modBreaks_module = mod
- }
-
-hydrateModBreaks :: Interp -> ModBreaks -> IO ModBreaks
-hydrateModBreaks interp ModBreaks {..} = do
- let count = numElements modBreaks_locs
- modBreaks_flags <- GHCi.newBreakArray interp count
- pure ModBreaks {..}
+ locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
+ varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
+ declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
+ ccs
+ | interpreterProfiled =
+ listArray
+ (0, count - 1)
+ [ ( concat $ intersperse "." $ tick_path t,
+ renderWithContext defaultSDocContext $ ppr $ tick_loc t
+ )
+ | t <- entries
+ ]
+ | otherwise = listArray (0, -1) []
+ in ModBreaks
+ { modBreaks_locs = locsTicks
+ , modBreaks_vars = varsTicks
+ , modBreaks_decls = declsTicks
+ , modBreaks_ccs = ccs
+ , modBreaks_module = modl
+ }
{-
Note [Field modBreaks_decls]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -28,6 +28,7 @@ module GHC.Linker.Loader
, extendLoadedEnv
, deleteFromLoadedEnv
-- * Internals
+ , allocateBreakArrays
, rmDupLinkables
, modifyLoaderState
, initLinkDepsOpts
@@ -122,8 +123,8 @@ import System.Win32.Info (getSystemDirectory)
import GHC.Utils.Exception
import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey)
import GHC.Driver.Downsweep
-
-
+import qualified GHC.Runtime.Interpreter as GHCi
+import Data.Array.Base (numElements)
-- Note [Linkers and loaders]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -177,13 +178,15 @@ emptyLoaderState = LoaderState
{ closure_env = emptyNameEnv
, itbl_env = emptyNameEnv
, addr_env = emptyNameEnv
- , breakarray_env = emptyModuleEnv
- , ccs_env = emptyModuleEnv
}
, pkgs_loaded = init_pkgs
, bcos_loaded = emptyModuleEnv
, objs_loaded = emptyModuleEnv
, temp_sos = []
+ , linked_breaks = LinkedBreaks
+ { breakarray_env = emptyModuleEnv
+ , ccs_env = emptyModuleEnv
+ }
}
-- Packages that don't need loading, because the compiler
-- shares them with the interpreted program.
@@ -694,28 +697,22 @@ loadDecls interp hsc_env span linkable = do
else do
-- Link the expression itself
let le = linker_env pls
+ let lb = linked_breaks pls
le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs)
le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs
- le2_breakarray_env <-
- allocateBreakArrays
- interp
- (catMaybes $ map bc_breaks cbcs)
- (breakarray_env le)
- le2_ccs_env <-
- allocateCCS
- interp
- (catMaybes $ map bc_breaks cbcs)
- (ccs_env le)
+ le2_breakarray_env <- allocateBreakArrays interp (breakarray_env lb) (catMaybes $ map bc_breaks cbcs)
+ le2_ccs_env <- allocateCCS interp (ccs_env lb) (catMaybes $ map bc_breaks cbcs)
let le2 = le { itbl_env = le2_itbl_env
- , addr_env = le2_addr_env
- , breakarray_env = le2_breakarray_env
+ , addr_env = le2_addr_env }
+ let lb2 = lb { breakarray_env = le2_breakarray_env
, ccs_env = le2_ccs_env }
-- Link the necessary packages and linkables
- new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
+ new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs
nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
let ce2 = extendClosureEnv (closure_env le2) nms_fhvs
- !pls2 = pls { linker_env = le2 { closure_env = ce2 } }
+ !pls2 = pls { linker_env = le2 { closure_env = ce2 }
+ , linked_breaks = lb2 }
return (pls2, (nms_fhvs, links_needed, units_needed))
where
cbcs = linkableBCOs linkable
@@ -931,17 +928,15 @@ dynLinkBCOs interp pls bcos = do
le1 = linker_env pls
+ lb1 = linked_breaks pls
ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs)
ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs
- be2 <-
- allocateBreakArrays
- interp
- (catMaybes $ map bc_breaks cbcs)
- (breakarray_env le1)
- ce2 <- allocateCCS interp (catMaybes $ map bc_breaks cbcs) (ccs_env le1)
- let le2 = le1 { itbl_env = ie2, addr_env = ae2, breakarray_env = be2, ccs_env = ce2 }
+ be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs)
+ ce2 <- allocateCCS interp (ccs_env lb1) (catMaybes $ map bc_breaks cbcs)
+ let le2 = le1 { itbl_env = ie2, addr_env = ae2 }
+ let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 }
- names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
+ names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs
-- We only want to add the external ones to the ClosureEnv
let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
@@ -952,19 +947,21 @@ dynLinkBCOs interp pls bcos = do
new_binds <- makeForeignNamedHValueRefs interp to_add
let ce2 = extendClosureEnv (closure_env le2) new_binds
- return $! pls1 { linker_env = le2 { closure_env = ce2 } }
+ return $! pls1 { linker_env = le2 { closure_env = ce2 }
+ , linked_breaks = lb2 }
-- Link a bunch of BCOs and return references to their values
linkSomeBCOs :: Interp
-> PkgsLoaded
-> LinkerEnv
+ -> LinkedBreaks
-> [CompiledByteCode]
-> IO [(Name,HValueRef)]
-- The returned HValueRefs are associated 1-1 with
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
+linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods []
where
fun CompiledByteCode{..} inner accum =
inner (Foldable.toList bc_bcos : accum)
@@ -974,7 +971,7 @@ linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
let flat = [ bco | bcos <- mods, bco <- bcos ]
names = map unlinkedBCOName flat
bco_ix = mkNameEnv (zip names [0..])
- resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ]
+ resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ]
hvrefs <- createBCOs interp resolved
return (zip names hvrefs)
@@ -1072,9 +1069,13 @@ unload_wkr interp keep_linkables pls@LoaderState{..} = do
keep_name n = isExternalName n &&
nameModule n `elemModuleEnv` remaining_bcos_loaded
- !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env,
- bcos_loaded = remaining_bcos_loaded,
- objs_loaded = remaining_objs_loaded }
+ keep_mod :: Module -> Bool
+ keep_mod m = m `elemModuleEnv` remaining_bcos_loaded
+
+ !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env,
+ linked_breaks = filterLinkedBreaks keep_mod linked_breaks,
+ bcos_loaded = remaining_bcos_loaded,
+ objs_loaded = remaining_objs_loaded }
return new_pls
where
@@ -1656,30 +1657,34 @@ allocateTopStrings interp topStrings prev_env = do
where
mk_entry nm ptr = (nm, (nm, AddrPtr ptr))
--- | Given a list of 'ModBreaks' collected from a list of
--- 'CompiledByteCode', allocate the 'BreakArray'.
+-- | Given a list of 'InternalModBreaks' collected from a list of
+-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints.
allocateBreakArrays ::
Interp ->
- [InternalModBreaks] ->
ModuleEnv (ForeignRef BreakArray) ->
+ [InternalModBreaks] ->
IO (ModuleEnv (ForeignRef BreakArray))
-allocateBreakArrays _interp mbs be =
+allocateBreakArrays interp =
foldlM
- ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} ->
- evaluate $ extendModuleEnv be0 modBreaks_module modBreaks_flags
+ ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
+ -- If no BreakArray is assigned to this module yet, create one
+ if not $ elemModuleEnv modBreaks_module be0 then do
+ let count = numElements modBreaks_locs
+ breakArray <- GHCi.newBreakArray interp count
+ evaluate $ extendModuleEnv be0 modBreaks_module breakArray
+ else
+ return be0
)
- be
- mbs
--- | Given a list of 'ModBreaks' collected from a list of
--- 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling
--- is enabled.
+-- | Given a list of 'InternalModBreaks' collected from a list
+-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is
+-- enabled.
allocateCCS ::
Interp ->
- [InternalModBreaks] ->
ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) ->
+ [InternalModBreaks] ->
IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
-allocateCCS interp mbs ce
+allocateCCS interp ce mbss
| interpreterProfiled interp =
foldlM
( \ce0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
@@ -1688,12 +1693,15 @@ allocateCCS interp mbs ce
interp
(moduleNameString $ moduleName modBreaks_module)
(elems modBreaks_ccs)
- evaluate $
- extendModuleEnv ce0 modBreaks_module $
- listArray
- (0, length ccs - 1)
- ccs
+ if not $ elemModuleEnv modBreaks_module ce0 then do
+ evaluate $
+ extendModuleEnv ce0 modBreaks_module $
+ listArray
+ (0, length ccs - 1)
+ ccs
+ else
+ return ce0
)
ce
- mbs
+ mbss
| otherwise = pure ce
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -18,6 +18,8 @@ module GHC.Linker.Types
, ClosureEnv
, emptyClosureEnv
, extendClosureEnv
+ , LinkedBreaks(..)
+ , filterLinkedBreaks
, LinkableSet
, mkLinkableSet
, unionLinkableSet
@@ -159,6 +161,9 @@ data LoaderState = LoaderState
, temp_sos :: ![(FilePath, String)]
-- ^ We need to remember the name of previous temporary DLL/.so
-- libraries so we can link them (see #10322)
+
+ , linked_breaks :: !LinkedBreaks
+ -- ^ Mapping from loaded modules to their breakpoint arrays
}
uninitializedLoader :: IO Loader
@@ -184,20 +189,13 @@ data LinkerEnv = LinkerEnv
, addr_env :: !AddrEnv
-- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals,
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
-
- , breakarray_env :: !(ModuleEnv (ForeignRef BreakArray))
- -- ^ Each 'Module's remote pointer of 'BreakArray'.
-
- , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
- -- ^ Each 'Module's array of remote pointers of 'CostCentre'.
- -- Untouched when not profiling.
}
filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv
-filterLinkerEnv f le = le
- { closure_env = filterNameEnv (f . fst) (closure_env le)
- , itbl_env = filterNameEnv (f . fst) (itbl_env le)
- , addr_env = filterNameEnv (f . fst) (addr_env le)
+filterLinkerEnv f (LinkerEnv closure_e itbl_e addr_e) = LinkerEnv
+ { closure_env = filterNameEnv (f . fst) closure_e
+ , itbl_env = filterNameEnv (f . fst) itbl_e
+ , addr_env = filterNameEnv (f . fst) addr_e
}
type ClosureEnv = NameEnv (Name, ForeignHValue)
@@ -209,6 +207,29 @@ extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
extendClosureEnv cl_env pairs
= extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
+-- | 'BreakArray's and CCSs are allocated per-module at link-time.
+--
+-- Specifically, a module's 'BreakArray' is allocated either:
+-- - When a BCO for that module is linked
+-- - When :break is used on a given module *before* the BCO has been linked.
+--
+-- We keep this structure in the 'LoaderState'
+data LinkedBreaks
+ = LinkedBreaks
+ { breakarray_env :: !(ModuleEnv (ForeignRef BreakArray))
+ -- ^ Each 'Module's remote pointer of 'BreakArray'.
+
+ , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
+ -- ^ Each 'Module's array of remote pointers of 'CostCentre'.
+ -- Untouched when not profiling.
+ }
+
+filterLinkedBreaks :: (Module -> Bool) -> LinkedBreaks -> LinkedBreaks
+filterLinkedBreaks f (LinkedBreaks ba_e ccs_e) = LinkedBreaks
+ { breakarray_env = filterModuleEnv (\m _ -> f m) ba_e
+ , ccs_env = filterModuleEnv (\m _ -> f m) ccs_e
+ }
+
type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo
data LoadedPkgInfo
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -64,6 +64,7 @@ import GHCi.RemoteTypes
import GHC.ByteCode.Types
import GHC.Linker.Loader as Loader
+import GHC.Linker.Types (LinkedBreaks (..))
import GHC.Hs
@@ -126,6 +127,7 @@ import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Utils.Monad
import GHC.IfaceToCore
+import GHC.ByteCode.Breakpoints
import Control.Monad
import Data.Dynamic
@@ -134,7 +136,7 @@ import Data.List (find,intercalate)
import Data.List.NonEmpty (NonEmpty)
import Unsafe.Coerce ( unsafeCoerce )
import qualified GHC.Unit.Home.Graph as HUG
-import GHC.ByteCode.Breakpoints
+import GHCi.BreakArray (BreakArray)
-- -----------------------------------------------------------------------------
-- running a statement interactively
@@ -348,13 +350,15 @@ handleRunStatus step expr bindings final_ids status history0 = do
EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
let ibi = evalBreakpointToId eval_break
let hug = hsc_HUG hsc_env
- tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
+ tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
let
span = getBreakLoc ibi tick_brks
decl = intercalate "." $ getBreakDecls ibi tick_brks
-- Was this breakpoint explicitly enabled (ie. in @BreakArray@)?
- bactive <- liftIO $ breakpointStatus interp (modBreaks_flags $ imodBreaks_modBreaks tick_brks) (ibi_tick_index ibi)
+ bactive <- liftIO $ do
+ breakArray <- getBreakArray interp (toBreakpointId ibi) tick_brks
+ breakpointStatus interp breakArray (ibi_tick_index ibi)
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
@@ -462,9 +466,29 @@ setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m () -- #191
setupBreakpoint interp bi cnt = do
hug <- hsc_HUG <$> getSession
modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi)
- let breakarray = modBreaks_flags $ imodBreaks_modBreaks modBreaks
- _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt
- pure ()
+ breakArray <- liftIO $ getBreakArray interp bi modBreaks
+ liftIO $ GHCi.storeBreakpoint interp breakArray (bi_tick_index bi) cnt
+
+getBreakArray :: Interp -> BreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)
+getBreakArray interp BreakpointId{bi_tick_mod} imbs = do
+ breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp
+ case lookupModuleEnv (breakarray_env breaks0) bi_tick_mod of
+ Just ba -> return ba
+ Nothing -> do
+ modifyLoaderState interp $ \ld_st -> do
+ let lb = linked_breaks ld_st
+
+ -- Recall that BreakArrays are allocated only at BCO link time, so if we
+ -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here.
+ ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs]
+
+ let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} }
+ let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env bi_tick_mod
+
+ return
+ ( ld_st'
+ , ba
+ )
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
back n = moveHist (+n)
=====================================
compiler/GHC/Runtime/Interpreter.hs-boot deleted
=====================================
@@ -1,10 +0,0 @@
-module GHC.Runtime.Interpreter where
-
-import {-# SOURCE #-} GHC.Runtime.Interpreter.Types
-import Data.Int (Int)
-import GHC.Base (IO)
-import GHCi.BreakArray (BreakArray)
-import GHCi.RemoteTypes (ForeignRef)
-
-newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)
-
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs-boot deleted
=====================================
@@ -1,6 +0,0 @@
-module GHC.Runtime.Interpreter.Types where
-
-import Data.Bool
-
-data Interp
-interpreterProfiled :: Interp -> Bool
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -5,6 +5,7 @@ GHC.Builtin.Types
GHC.Builtin.Types.Literals
GHC.Builtin.Types.Prim
GHC.Builtin.Uniques
+GHC.ByteCode.Breakpoints
GHC.ByteCode.Types
GHC.Cmm.BlockId
GHC.Cmm.CLabel
@@ -110,6 +111,8 @@ GHC.Hs.Pat
GHC.Hs.Specificity
GHC.Hs.Type
GHC.Hs.Utils
+GHC.HsToCore.Breakpoints
+GHC.HsToCore.Ticks
GHC.Iface.Errors.Types
GHC.Iface.Ext.Fields
GHC.Iface.Flags
@@ -150,7 +153,6 @@ GHC.Tc.Zonk.Monad
GHC.Types.Annotations
GHC.Types.Avail
GHC.Types.Basic
-GHC.Types.Breakpoint
GHC.Types.CostCentre
GHC.Types.CostCentre.State
GHC.Types.Cpr
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -5,6 +5,7 @@ GHC.Builtin.Types
GHC.Builtin.Types.Literals
GHC.Builtin.Types.Prim
GHC.Builtin.Uniques
+GHC.ByteCode.Breakpoints
GHC.ByteCode.Types
GHC.Cmm.BlockId
GHC.Cmm.CLabel
@@ -114,8 +115,10 @@ GHC.Hs.Pat
GHC.Hs.Specificity
GHC.Hs.Type
GHC.Hs.Utils
+GHC.HsToCore.Breakpoints
GHC.HsToCore.Errors.Types
GHC.HsToCore.Pmc.Solver.Types
+GHC.HsToCore.Ticks
GHC.Iface.Errors.Types
GHC.Iface.Ext.Fields
GHC.Iface.Flags
@@ -171,7 +174,6 @@ GHC.Tc.Zonk.Monad
GHC.Types.Annotations
GHC.Types.Avail
GHC.Types.Basic
-GHC.Types.Breakpoint
GHC.Types.CompleteMatch
GHC.Types.CostCentre
GHC.Types.CostCentre.State
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/925552177f8abb540a21e6c3f67f5c6…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/925552177f8abb540a21e6c3f67f5c6…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/romes/step-out-9] ghci: Allocate BreakArrays at link time only
by Rodrigo Mesquita (＠alt-romes) 04 Jul '25
by Rodrigo Mesquita (＠alt-romes) 04 Jul '25
04 Jul '25
Rodrigo Mesquita pushed to branch wip/romes/step-out-9 at Glasgow Haskell Compiler / GHC
Commits:
dc5c29a6 by Rodrigo Mesquita at 2025-07-04T12:55:05+01: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).
- - - - -
10 changed files:
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Eval.hs
- − compiler/GHC/Runtime/Interpreter.hs-boot
- − compiler/GHC/Runtime/Interpreter/Types.hs-boot
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -58,15 +58,16 @@ linkBCO
:: Interp
-> PkgsLoaded
-> LinkerEnv
+ -> LinkedBreaks
-> NameEnv Int
-> UnlinkedBCO
-> IO ResolvedBCO
-linkBCO interp pkgs_loaded le bco_ix
+linkBCO interp pkgs_loaded le lb bco_ix
(UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
-- fromIntegral Word -> Word64 should be a no op if Word is Word64
-- otherwise it will result in a cast to longlong on 32bit systems.
- (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0)
- ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0)
+ (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0)
+ ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0)
let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian
, resolvedBCOArity = arity
@@ -76,8 +77,8 @@ linkBCO interp pkgs_loaded le bco_ix
, resolvedBCOPtrs = addListToSS emptySS ptrs
}
-lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
-lookupLiteral interp pkgs_loaded le ptr = case ptr of
+lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word
+lookupLiteral interp pkgs_loaded le lb ptr = case ptr of
BCONPtrWord lit -> return lit
BCONPtrLbl sym -> do
Ptr a# <- lookupStaticPtr interp sym
@@ -99,7 +100,7 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of
pure $ fromIntegral p
BCONPtrCostCentre BreakpointId{..}
| interpreterProfiled interp -> do
- case expectJust (lookupModuleEnv (ccs_env le) bi_tick_mod) ! bi_tick_index of
+ case expectJust (lookupModuleEnv (ccs_env lb) bi_tick_mod) ! bi_tick_index of
RemotePtr p -> pure $ fromIntegral p
| otherwise ->
case toRemotePtr nullPtr of
@@ -158,10 +159,11 @@ resolvePtr
:: Interp
-> PkgsLoaded
-> LinkerEnv
+ -> LinkedBreaks
-> NameEnv Int
-> BCOPtr
-> IO ResolvedBCOPtr
-resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
+resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of
BCOPtrName nm
| Just ix <- lookupNameEnv bco_ix nm
-> return (ResolvedBCORef ix) -- ref to another BCO in this group
@@ -182,10 +184,10 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
-> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
BCOPtrBCO bco
- -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco
+ -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco
BCOPtrBreakArray tick_mod ->
- withForeignRef (expectJust (lookupModuleEnv (breakarray_env le) tick_mod)) $
+ withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $
\ba -> pure $ ResolvedBCOPtrBreakArray ba
-- | Look up the address of a Haskell symbol in the currently
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -97,8 +97,8 @@ import GHC.Unit.Module.Deps
import Data.List (partition)
import Data.IORef
-import Data.Traversable (for)
import GHC.Iface.Make (mkRecompUsageInfo)
+import GHC.Runtime.Interpreter (interpreterProfiled)
{-
************************************************************************
@@ -162,13 +162,12 @@ deSugar hsc_env
mod mod_loc
export_set (typeEnvTyCons type_env) binds
else return (binds, Nothing)
- ; modBreaks <- for
- [ (i, s)
- | i <- hsc_interp hsc_env
- , (_, s) <- m_tickInfo
- , breakpointsAllowed dflags
- ]
- $ \(interp, specs) -> mkModBreaks interp mod specs
+ ; let modBreaks
+ | Just (_, specs) <- m_tickInfo
+ , breakpointsAllowed dflags
+ = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs
+ | otherwise
+ = Nothing
; ds_hpc_info <- case m_tickInfo of
Just (orig_file2, ticks)
=====================================
compiler/GHC/HsToCore/Breakpoints.hs
=====================================
@@ -33,14 +33,6 @@ import GHC.Unit.Module (Module)
import GHC.Utils.Outputable
import Data.List (intersperse)
-import GHCi.BreakArray (BreakArray)
-import GHCi.RemoteTypes (ForeignRef)
-
--- TODO: Break this cycle
-import {-# SOURCE #-} GHC.Runtime.Interpreter.Types (Interp, interpreterProfiled)
-import {-# SOURCE #-} qualified GHC.Runtime.Interpreter as GHCi (newBreakArray)
-import Data.Array.Base (numElements)
-
--------------------------------------------------------------------------------
-- ModBreaks
--------------------------------------------------------------------------------
@@ -58,10 +50,7 @@ import Data.Array.Base (numElements)
-- and 'modBreaks_decls'.
data ModBreaks
= ModBreaks
- { modBreaks_flags :: ForeignRef BreakArray
- -- ^ The array of flags, one per breakpoint,
- -- indicating which breakpoints are enabled.
- , modBreaks_locs :: !(Array BreakTickIndex SrcSpan)
+ { modBreaks_locs :: !(Array BreakTickIndex SrcSpan)
-- ^ An array giving the source span of each breakpoint.
, modBreaks_vars :: !(Array BreakTickIndex [OccName])
-- ^ An array giving the names of the free variables at each breakpoint.
@@ -83,40 +72,31 @@ data ModBreaks
-- generator needs to encode this information for each expression, the data is
-- allocated remotely in GHCi's address space and passed to the codegen as
-- foreign pointers.
-mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks
-mkModBreaks interp mod extendedMixEntries
- = do
- let count = fromIntegral $ sizeSS extendedMixEntries
+mkModBreaks :: Bool {-^ Whether the interpreter is profiled and thus if we should include store a CCS array -}
+ -> Module -> SizedSeq Tick -> ModBreaks
+mkModBreaks interpreterProfiled modl extendedMixEntries
+ = let count = fromIntegral $ sizeSS extendedMixEntries
entries = ssElts extendedMixEntries
- let
- locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
- varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
- declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
- ccs
- | interpreterProfiled interp =
- listArray
- (0, count - 1)
- [ ( concat $ intersperse "." $ tick_path t,
- renderWithContext defaultSDocContext $ ppr $ tick_loc t
- )
- | t <- entries
- ]
- | otherwise = listArray (0, -1) []
- hydrateModBreaks interp $
- ModBreaks
- { modBreaks_flags = undefined,
- modBreaks_locs = locsTicks,
- modBreaks_vars = varsTicks,
- modBreaks_decls = declsTicks,
- modBreaks_ccs = ccs,
- modBreaks_module = mod
- }
-
-hydrateModBreaks :: Interp -> ModBreaks -> IO ModBreaks
-hydrateModBreaks interp ModBreaks {..} = do
- let count = numElements modBreaks_locs
- modBreaks_flags <- GHCi.newBreakArray interp count
- pure ModBreaks {..}
+ locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ]
+ varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ]
+ declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
+ ccs
+ | interpreterProfiled =
+ listArray
+ (0, count - 1)
+ [ ( concat $ intersperse "." $ tick_path t,
+ renderWithContext defaultSDocContext $ ppr $ tick_loc t
+ )
+ | t <- entries
+ ]
+ | otherwise = listArray (0, -1) []
+ in ModBreaks
+ { modBreaks_locs = locsTicks
+ , modBreaks_vars = varsTicks
+ , modBreaks_decls = declsTicks
+ , modBreaks_ccs = ccs
+ , modBreaks_module = modl
+ }
{-
Note [Field modBreaks_decls]
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -28,6 +28,7 @@ module GHC.Linker.Loader
, extendLoadedEnv
, deleteFromLoadedEnv
-- * Internals
+ , allocateBreakArrays
, rmDupLinkables
, modifyLoaderState
, initLinkDepsOpts
@@ -122,8 +123,8 @@ import System.Win32.Info (getSystemDirectory)
import GHC.Utils.Exception
import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey)
import GHC.Driver.Downsweep
-
-
+import qualified GHC.Runtime.Interpreter as GHCi
+import Data.Array.Base (numElements)
-- Note [Linkers and loaders]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -177,13 +178,15 @@ emptyLoaderState = LoaderState
{ closure_env = emptyNameEnv
, itbl_env = emptyNameEnv
, addr_env = emptyNameEnv
- , breakarray_env = emptyModuleEnv
- , ccs_env = emptyModuleEnv
}
, pkgs_loaded = init_pkgs
, bcos_loaded = emptyModuleEnv
, objs_loaded = emptyModuleEnv
, temp_sos = []
+ , linked_breaks = LinkedBreaks
+ { breakarray_env = emptyModuleEnv
+ , ccs_env = emptyModuleEnv
+ }
}
-- Packages that don't need loading, because the compiler
-- shares them with the interpreted program.
@@ -694,28 +697,22 @@ loadDecls interp hsc_env span linkable = do
else do
-- Link the expression itself
let le = linker_env pls
+ let lb = linked_breaks pls
le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs)
le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs
- le2_breakarray_env <-
- allocateBreakArrays
- interp
- (catMaybes $ map bc_breaks cbcs)
- (breakarray_env le)
- le2_ccs_env <-
- allocateCCS
- interp
- (catMaybes $ map bc_breaks cbcs)
- (ccs_env le)
+ le2_breakarray_env <- allocateBreakArrays interp (breakarray_env lb) (catMaybes $ map bc_breaks cbcs)
+ le2_ccs_env <- allocateCCS interp (ccs_env lb) (catMaybes $ map bc_breaks cbcs)
let le2 = le { itbl_env = le2_itbl_env
- , addr_env = le2_addr_env
- , breakarray_env = le2_breakarray_env
+ , addr_env = le2_addr_env }
+ let lb2 = lb { breakarray_env = le2_breakarray_env
, ccs_env = le2_ccs_env }
-- Link the necessary packages and linkables
- new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
+ new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs
nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
let ce2 = extendClosureEnv (closure_env le2) nms_fhvs
- !pls2 = pls { linker_env = le2 { closure_env = ce2 } }
+ !pls2 = pls { linker_env = le2 { closure_env = ce2 }
+ , linked_breaks = lb2 }
return (pls2, (nms_fhvs, links_needed, units_needed))
where
cbcs = linkableBCOs linkable
@@ -931,17 +928,15 @@ dynLinkBCOs interp pls bcos = do
le1 = linker_env pls
+ lb1 = linked_breaks pls
ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs)
ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs
- be2 <-
- allocateBreakArrays
- interp
- (catMaybes $ map bc_breaks cbcs)
- (breakarray_env le1)
- ce2 <- allocateCCS interp (catMaybes $ map bc_breaks cbcs) (ccs_env le1)
- let le2 = le1 { itbl_env = ie2, addr_env = ae2, breakarray_env = be2, ccs_env = ce2 }
+ be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs)
+ ce2 <- allocateCCS interp (ccs_env lb1) (catMaybes $ map bc_breaks cbcs)
+ let le2 = le1 { itbl_env = ie2, addr_env = ae2 }
+ let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 }
- names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
+ names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs
-- We only want to add the external ones to the ClosureEnv
let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
@@ -952,19 +947,21 @@ dynLinkBCOs interp pls bcos = do
new_binds <- makeForeignNamedHValueRefs interp to_add
let ce2 = extendClosureEnv (closure_env le2) new_binds
- return $! pls1 { linker_env = le2 { closure_env = ce2 } }
+ return $! pls1 { linker_env = le2 { closure_env = ce2 }
+ , linked_breaks = lb2 }
-- Link a bunch of BCOs and return references to their values
linkSomeBCOs :: Interp
-> PkgsLoaded
-> LinkerEnv
+ -> LinkedBreaks
-> [CompiledByteCode]
-> IO [(Name,HValueRef)]
-- The returned HValueRefs are associated 1-1 with
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
+linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods []
where
fun CompiledByteCode{..} inner accum =
inner (Foldable.toList bc_bcos : accum)
@@ -974,7 +971,7 @@ linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods []
let flat = [ bco | bcos <- mods, bco <- bcos ]
names = map unlinkedBCOName flat
bco_ix = mkNameEnv (zip names [0..])
- resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ]
+ resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ]
hvrefs <- createBCOs interp resolved
return (zip names hvrefs)
@@ -1072,9 +1069,13 @@ unload_wkr interp keep_linkables pls@LoaderState{..} = do
keep_name n = isExternalName n &&
nameModule n `elemModuleEnv` remaining_bcos_loaded
- !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env,
- bcos_loaded = remaining_bcos_loaded,
- objs_loaded = remaining_objs_loaded }
+ keep_mod :: Module -> Bool
+ keep_mod m = m `elemModuleEnv` remaining_bcos_loaded
+
+ !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env,
+ linked_breaks = filterLinkedBreaks keep_mod linked_breaks,
+ bcos_loaded = remaining_bcos_loaded,
+ objs_loaded = remaining_objs_loaded }
return new_pls
where
@@ -1656,30 +1657,34 @@ allocateTopStrings interp topStrings prev_env = do
where
mk_entry nm ptr = (nm, (nm, AddrPtr ptr))
--- | Given a list of 'ModBreaks' collected from a list of
--- 'CompiledByteCode', allocate the 'BreakArray'.
+-- | Given a list of 'InternalModBreaks' collected from a list of
+-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints.
allocateBreakArrays ::
Interp ->
- [InternalModBreaks] ->
ModuleEnv (ForeignRef BreakArray) ->
+ [InternalModBreaks] ->
IO (ModuleEnv (ForeignRef BreakArray))
-allocateBreakArrays _interp mbs be =
+allocateBreakArrays interp =
foldlM
- ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} ->
- evaluate $ extendModuleEnv be0 modBreaks_module modBreaks_flags
+ ( \be0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
+ -- If no BreakArray is assigned to this module yet, create one
+ if not $ elemModuleEnv modBreaks_module be0 then do
+ let count = numElements modBreaks_locs
+ breakArray <- GHCi.newBreakArray interp count
+ evaluate $ extendModuleEnv be0 modBreaks_module breakArray
+ else
+ return be0
)
- be
- mbs
--- | Given a list of 'ModBreaks' collected from a list of
--- 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling
--- is enabled.
+-- | Given a list of 'InternalModBreaks' collected from a list
+-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is
+-- enabled.
allocateCCS ::
Interp ->
- [InternalModBreaks] ->
ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)) ->
+ [InternalModBreaks] ->
IO (ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
-allocateCCS interp mbs ce
+allocateCCS interp ce mbss
| interpreterProfiled interp =
foldlM
( \ce0 InternalModBreaks{imodBreaks_modBreaks=ModBreaks {..}} -> do
@@ -1688,12 +1693,15 @@ allocateCCS interp mbs ce
interp
(moduleNameString $ moduleName modBreaks_module)
(elems modBreaks_ccs)
- evaluate $
- extendModuleEnv ce0 modBreaks_module $
- listArray
- (0, length ccs - 1)
- ccs
+ if not $ elemModuleEnv modBreaks_module ce0 then do
+ evaluate $
+ extendModuleEnv ce0 modBreaks_module $
+ listArray
+ (0, length ccs - 1)
+ ccs
+ else
+ return ce0
)
ce
- mbs
+ mbss
| otherwise = pure ce
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -18,6 +18,8 @@ module GHC.Linker.Types
, ClosureEnv
, emptyClosureEnv
, extendClosureEnv
+ , LinkedBreaks(..)
+ , filterLinkedBreaks
, LinkableSet
, mkLinkableSet
, unionLinkableSet
@@ -159,6 +161,9 @@ data LoaderState = LoaderState
, temp_sos :: ![(FilePath, String)]
-- ^ We need to remember the name of previous temporary DLL/.so
-- libraries so we can link them (see #10322)
+
+ , linked_breaks :: !LinkedBreaks
+ -- ^ Mapping from loaded modules to their breakpoint arrays
}
uninitializedLoader :: IO Loader
@@ -184,20 +189,13 @@ data LinkerEnv = LinkerEnv
, addr_env :: !AddrEnv
-- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals,
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
-
- , breakarray_env :: !(ModuleEnv (ForeignRef BreakArray))
- -- ^ Each 'Module's remote pointer of 'BreakArray'.
-
- , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
- -- ^ Each 'Module's array of remote pointers of 'CostCentre'.
- -- Untouched when not profiling.
}
filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv
-filterLinkerEnv f le = le
- { closure_env = filterNameEnv (f . fst) (closure_env le)
- , itbl_env = filterNameEnv (f . fst) (itbl_env le)
- , addr_env = filterNameEnv (f . fst) (addr_env le)
+filterLinkerEnv f (LinkerEnv closure_e itbl_e addr_e) = LinkerEnv
+ { closure_env = filterNameEnv (f . fst) closure_e
+ , itbl_env = filterNameEnv (f . fst) itbl_e
+ , addr_env = filterNameEnv (f . fst) addr_e
}
type ClosureEnv = NameEnv (Name, ForeignHValue)
@@ -209,6 +207,29 @@ extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
extendClosureEnv cl_env pairs
= extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
+-- | 'BreakArray's and CCSs are allocated per-module at link-time.
+--
+-- Specifically, a module's 'BreakArray' is allocated either:
+-- - When a BCO for that module is linked
+-- - When :break is used on a given module *before* the BCO has been linked.
+--
+-- We keep this structure in the 'LoaderState'
+data LinkedBreaks
+ = LinkedBreaks
+ { breakarray_env :: !(ModuleEnv (ForeignRef BreakArray))
+ -- ^ Each 'Module's remote pointer of 'BreakArray'.
+
+ , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre)))
+ -- ^ Each 'Module's array of remote pointers of 'CostCentre'.
+ -- Untouched when not profiling.
+ }
+
+filterLinkedBreaks :: (Module -> Bool) -> LinkedBreaks -> LinkedBreaks
+filterLinkedBreaks f (LinkedBreaks ba_e ccs_e) = LinkedBreaks
+ { breakarray_env = filterModuleEnv (\m _ -> f m) ba_e
+ , ccs_env = filterModuleEnv (\m _ -> f m) ccs_e
+ }
+
type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo
data LoadedPkgInfo
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -64,6 +64,7 @@ import GHCi.RemoteTypes
import GHC.ByteCode.Types
import GHC.Linker.Loader as Loader
+import GHC.Linker.Types (LinkedBreaks (..))
import GHC.Hs
@@ -126,6 +127,7 @@ import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Utils.Monad
import GHC.IfaceToCore
+import GHC.ByteCode.Breakpoints
import Control.Monad
import Data.Dynamic
@@ -134,7 +136,7 @@ import Data.List (find,intercalate)
import Data.List.NonEmpty (NonEmpty)
import Unsafe.Coerce ( unsafeCoerce )
import qualified GHC.Unit.Home.Graph as HUG
-import GHC.ByteCode.Breakpoints
+import GHCi.BreakArray (BreakArray)
-- -----------------------------------------------------------------------------
-- running a statement interactively
@@ -348,13 +350,14 @@ handleRunStatus step expr bindings final_ids status history0 = do
EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do
let ibi = evalBreakpointToId eval_break
let hug = hsc_HUG hsc_env
- tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
+ tick_brks <- liftIO $ readModBreaks hug (ibi_tick_mod ibi)
+ breakArray <- liftIO $ getBreakArray interp (toBreakpointId ibi) tick_brks
let
span = getBreakLoc ibi tick_brks
decl = intercalate "." $ getBreakDecls ibi tick_brks
-- Was this breakpoint explicitly enabled (ie. in @BreakArray@)?
- bactive <- liftIO $ breakpointStatus interp (modBreaks_flags $ imodBreaks_modBreaks tick_brks) (ibi_tick_index ibi)
+ bactive <- liftIO $ breakpointStatus interp breakArray (ibi_tick_index ibi)
apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
@@ -462,9 +465,29 @@ setupBreakpoint :: GhcMonad m => Interp -> BreakpointId -> Int -> m () -- #191
setupBreakpoint interp bi cnt = do
hug <- hsc_HUG <$> getSession
modBreaks <- liftIO $ readModBreaks hug (bi_tick_mod bi)
- let breakarray = modBreaks_flags $ imodBreaks_modBreaks modBreaks
- _ <- liftIO $ GHCi.storeBreakpoint interp breakarray (bi_tick_index bi) cnt
- pure ()
+ breakArray <- liftIO $ getBreakArray interp bi modBreaks
+ liftIO $ GHCi.storeBreakpoint interp breakArray (bi_tick_index bi) cnt
+
+getBreakArray :: Interp -> BreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)
+getBreakArray interp BreakpointId{bi_tick_mod} imbs = do
+ breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp
+ case lookupModuleEnv (breakarray_env breaks0) bi_tick_mod of
+ Just ba -> return ba
+ Nothing -> do
+ modifyLoaderState interp $ \ld_st -> do
+ let lb = linked_breaks ld_st
+
+ -- Recall that BreakArrays are allocated only at BCO link time, so if we
+ -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here.
+ ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs]
+
+ let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} }
+ let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env bi_tick_mod
+
+ return
+ ( ld_st'
+ , ba
+ )
back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan)
back n = moveHist (+n)
=====================================
compiler/GHC/Runtime/Interpreter.hs-boot deleted
=====================================
@@ -1,10 +0,0 @@
-module GHC.Runtime.Interpreter where
-
-import {-# SOURCE #-} GHC.Runtime.Interpreter.Types
-import Data.Int (Int)
-import GHC.Base (IO)
-import GHCi.BreakArray (BreakArray)
-import GHCi.RemoteTypes (ForeignRef)
-
-newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)
-
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs-boot deleted
=====================================
@@ -1,6 +0,0 @@
-module GHC.Runtime.Interpreter.Types where
-
-import Data.Bool
-
-data Interp
-interpreterProfiled :: Interp -> Bool
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -5,6 +5,7 @@ GHC.Builtin.Types
GHC.Builtin.Types.Literals
GHC.Builtin.Types.Prim
GHC.Builtin.Uniques
+GHC.ByteCode.Breakpoints
GHC.ByteCode.Types
GHC.Cmm.BlockId
GHC.Cmm.CLabel
@@ -110,6 +111,8 @@ GHC.Hs.Pat
GHC.Hs.Specificity
GHC.Hs.Type
GHC.Hs.Utils
+GHC.HsToCore.Breakpoints
+GHC.HsToCore.Ticks
GHC.Iface.Errors.Types
GHC.Iface.Ext.Fields
GHC.Iface.Flags
@@ -150,7 +153,6 @@ GHC.Tc.Zonk.Monad
GHC.Types.Annotations
GHC.Types.Avail
GHC.Types.Basic
-GHC.Types.Breakpoint
GHC.Types.CostCentre
GHC.Types.CostCentre.State
GHC.Types.Cpr
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -5,6 +5,7 @@ GHC.Builtin.Types
GHC.Builtin.Types.Literals
GHC.Builtin.Types.Prim
GHC.Builtin.Uniques
+GHC.ByteCode.Breakpoints
GHC.ByteCode.Types
GHC.Cmm.BlockId
GHC.Cmm.CLabel
@@ -114,8 +115,10 @@ GHC.Hs.Pat
GHC.Hs.Specificity
GHC.Hs.Type
GHC.Hs.Utils
+GHC.HsToCore.Breakpoints
GHC.HsToCore.Errors.Types
GHC.HsToCore.Pmc.Solver.Types
+GHC.HsToCore.Ticks
GHC.Iface.Errors.Types
GHC.Iface.Ext.Fields
GHC.Iface.Flags
@@ -171,7 +174,6 @@ GHC.Tc.Zonk.Monad
GHC.Types.Annotations
GHC.Types.Avail
GHC.Types.Basic
-GHC.Types.Breakpoint
GHC.Types.CompleteMatch
GHC.Types.CostCentre
GHC.Types.CostCentre.State
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc5c29a64e5e72fefaa04071081b0de…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc5c29a64e5e72fefaa04071081b0de…
You're receiving this email because of your account on gitlab.haskell.org.
1
0