- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/T23162-spj] 14 commits: Add a perf test for #26425
by Simon Peyton Jones (＠simonpj) 30 Oct '25

30 Oct '25

Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 4038a28b by Andreas Klebinger at 2025-10-30T12:38:52-04:00 Add a perf test for #26425 - - - - - f997618e by Andreas Klebinger at 2025-10-30T12:38:52-04:00 OccAnal: Be stricter for better compiler perf. In particular we are now stricter: * When combining usageDetails. * When computing binder info. In combineUsageDetails when combining the underlying adds we compute a new `LocalOcc` for each entry by combining the two existing ones. Rather than wait for those entries to be forced down the road we now force them immediately. Speeding up T26425 by about 10% with little effect on the common case. We also force binders we put into the Core AST everywhere now. Failure to do so risks leaking the occ env used to set the binders OccInfo. For T26425 compiler residency went down by a factor of ~10x. Compile time also improved by a factor of ~1.6. ------------------------- Metric Decrease: T18698a T26425 T9233 ------------------------- - - - - - 5618645b by Vladislav Zavialov at 2025-10-30T12:39:33-04:00 Fix namespace specifiers in subordinate exports (#12488) This patch fixes an oversight in the `lookupChildrenExport` function that caused explicit namespace specifiers of subordinate export items to be ignored: module M (T (type A)) where -- should be rejected data T = A Based on the `IEWrappedName` data type, there are 5 cases to consider: 1. Unadorned name: P(X) 2. Named default: P(default X) 3. Pattern synonym: P(pattern X) 4. Type name: P(type X) 5. Data name: P(data X) Case 1 is already handled correctly; cases 2 and 3 are parse errors; and it is cases 4 and 5 that we are concerned with in this patch. Following the precedent established in `LookupExactName`, we introduce a boolean flag in `LookupChildren` to control whether to look up in all namespaces or in a specific one. If an export item is accompanied by an explicit namespace specifier `type` or `data`, we restrict the lookup in `lookupGRE` to a specific namespace. The newly introduced diagnostic `TcRnExportedSubordinateNotFound` provides error messages and suggestions more tailored to this context than the previously used `reportUnboundName`. - - - - - 2cc9924e by Richard Eisenberg at 2025-10-30T17:08:32+00:00 Refactor fundep solving This commit is a large-scale refactor of the increasingly-messy code that handles functional dependencies. It has virtually no effect on what compiles but improves error messages a bit. And it does the groundwork for #23162. The big picture is described in Note [Overview of functional dependencies in type inference] in GHC.Tc.Solver.FunDeps * New module GHC.Tc.Solver.FunDeps contains all the fundep-handling code for the constraint solver. * Fundep-equalities are solved in a nested scope; they may generate unifications but otherwise have no other effect. See GHC.Tc.Solver.FunDeps.solveFunDeps The nested needs to start from the Givens in the inert set, but not the Wanteds; hence a new function `resetInertCans`, used in `nestFunDepsTcS`. * That in turn means that fundep equalities never show up in error messages, so the complicated FunDepOrigin tracking can all disappear. * We need to be careful about tracking unifications, so we kick out constraints from the inert set after doing unifications. Unification tracking has been majorly reformed: see Note [WhatUnifications] in GHC.Tc.Utils.Unify. A good consequence is that the hard-to-grok `resetUnificationFlag` has been replaced with a simpler use of `reportCoarseGrainUnifications` Smaller things: * Rename `FunDepEqn` to `FunDepEqns` since it contains multiple type equalities. Some compile time improvement Metrics: compile_time/bytes allocated Baseline Test value New value Change ---------------------- -------------------------------------- T5030(normal) 173,839,232 148,115,248 -14.8% GOOD hard_hole_fits(normal) 286,768,048 284,015,416 -1.0% geo. mean -0.2% minimum -14.8% maximum +0.3% Metric Decrease: T5030 - - - - - 072466a4 by Simon Peyton Jones at 2025-10-30T17:08:32+00:00 QuickLook's tcInstFun should make instantiation variables directly tcInstFun must make "instantiation variables", not regular unification variables, when instantiating function types. That was previously implemented by a hack: set the /ambient/ level to QLInstTyVar. But the hack finally bit me, when I was refactoring WhatUnifications. And it was always wrong: see the now-expunged (TCAPP2) note. This commit does it right, by making tcInstFun call its own instantiation functions. That entails a small bit of duplication, but the result is much, much cleaner. - - - - - 0c9e957c by Simon Peyton Jones at 2025-10-30T17:08:32+00:00 Build implication for constraints from (static e) This commit addresses #26466, by buiding an implication for the constraints arising from a (static e) form. The implication has a special ic_info field of StaticFormSkol, which tells the constraint solver to use an empty set of Givens. See (SF3) in Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable This commit also reinstates an `assert` in GHC.Tc.Solver.Equality. The test `StaticPtrTypeFamily` was failing with an assertion failure, but it now works. - - - - - fbb2a831 by Simon Peyton Jones at 2025-10-30T17:08:32+00:00 Comments about defaulting representation equalities - - - - - b59a8713 by Simon Peyton Jones at 2025-10-30T17:08:32+00:00 Improve tracking of rewriter-sets This refactor substantially improves the treatment of so-called "rewriter-sets" in the constraint solver. The story is described in the rewritten Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint Some highlights * Trace the free coercion holes of a filled CoercionHole, in CoercionPlusHoles. See Note [Coercion holes] (COH5) This avoids taking having to take the free coercion variables of a coercion when zonking a rewrriter-set * Many knock on changes * Make fillCoercionHole take CoercionPlusHoles as its argument rather than to separate arguments. * Similarly setEqIfWanted, setWantedE, wrapUnifierAndEmit. * Be more careful about passing the correct CoHoleSet to `rewriteEqEvidence` and friends * Make kickOurAfterFillingCoercionHole more clever. See new Note [Kick out after filling a coercion hole] Smaller matters * Rename RewriterSet to CoHoleSet * Add special-case helper `rewriteEqEvidenceSwapOnly` - - - - - 02de4352 by Simon Peyton Jones at 2025-10-30T17:08:32+00:00 Tidy up constraint solving for foralls * In `can_eq_nc_forall` make sure to track Givens that are used in the nested solve step. * Tiny missing-swap bug-fix in `lookup_eq_in_qcis` * Fix some leftover mess from commit 14123ee646f2b9738a917b7cec30f9d3941c13de Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Wed Aug 20 00:35:48 2025 +0100 Solve forall-constraints via an implication, again Specifically, trySolveImplication is now dead. - - - - - 27b3b406 by Simon Peyton Jones at 2025-10-30T17:08:32+00:00 Do not treat CoercionHoles as free variables in coercions This fixes a long-standing wart in the free-variable finder; now CoercionHoles are no longer treated as a "free variable" of a coercion. I got big and unexpected performance regressions when making this change. Turned out that CallArity didn't discover that the free variable finder could be eta-expanded, which gave very poor code. So I re-used Note [The one-shot state monad trick] for Endo, resulting in GHC.Utils.EndoOS. Very simple, big win. - - - - - 49a558ed by Simon Peyton Jones at 2025-10-30T17:08:32+00:00 Update debug-tracing in CallArity No effect on behaviour, and commented out anyway - - - - - c35ab399 by Simon Peyton Jones at 2025-10-30T17:08:33+00:00 Comments only -- remove dangling Note references - - - - - eaf505bd by Simon Peyton Jones at 2025-10-30T17:08:33+00:00 Accept error message wibbles - - - - - 09161c1f by Simon Peyton Jones at 2025-10-30T17:08:33+00:00 Comments only - - - - - 125 changed files: - compiler/GHC/Core/Opt/CallArity.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - + compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Irred.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Solver/Solve.hs-boot - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Unique/DSM.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var/Env.hs - + compiler/GHC/Utils/EndoOS.hs - compiler/ghc.cabal.in - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/default/default-fail05.stderr - testsuite/tests/dependent/should_fail/T13135_simple.stderr - testsuite/tests/deriving/should_fail/T3621.stderr - testsuite/tests/indexed-types/should_fail/T14369.stderr - testsuite/tests/indexed-types/should_fail/T1897b.stderr - testsuite/tests/linters/notes.stdout - testsuite/tests/module/mod4.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr - + testsuite/tests/parser/should_fail/T12488c.hs - + testsuite/tests/parser/should_fail/T12488c.stderr - + testsuite/tests/parser/should_fail/T12488d.hs - + testsuite/tests/parser/should_fail/T12488d.stderr - testsuite/tests/parser/should_fail/T20654a.stderr - testsuite/tests/parser/should_fail/all.T - testsuite/tests/partial-sigs/should_fail/T14584a.stderr - + testsuite/tests/perf/compiler/T26425.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/polykinds/T6068.stdout - testsuite/tests/quantified-constraints/T15359.hs - + testsuite/tests/rename/should_compile/T12488b.hs - + testsuite/tests/rename/should_compile/T12488f.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T12488a.hs - + testsuite/tests/rename/should_fail/T12488a.stderr - + testsuite/tests/rename/should_fail/T12488a_foo.hs - + testsuite/tests/rename/should_fail/T12488a_foo.stderr - + testsuite/tests/rename/should_fail/T12488e.hs - + testsuite/tests/rename/should_fail/T12488e.stderr - + testsuite/tests/rename/should_fail/T12488g.hs - + testsuite/tests/rename/should_fail/T12488g.stderr - testsuite/tests/rename/should_fail/T25899e2.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/rep-poly/RepPolyNPlusK.stderr - testsuite/tests/rep-poly/RepPolyRightSection.stderr - testsuite/tests/rep-poly/T13233.stderr - testsuite/tests/rep-poly/T19709b.stderr - testsuite/tests/rep-poly/T23903.stderr - testsuite/tests/typecheck/no_skolem_info/T13499.stderr - testsuite/tests/typecheck/should_compile/T13651.hs - − testsuite/tests/typecheck/should_compile/T13651.stderr - + testsuite/tests/typecheck/should_compile/T14745.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr - testsuite/tests/typecheck/should_compile/tc126.hs - testsuite/tests/typecheck/should_fail/AmbigFDs.hs - − testsuite/tests/typecheck/should_fail/AmbigFDs.stderr - testsuite/tests/typecheck/should_fail/FD3.stderr - testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr - testsuite/tests/typecheck/should_fail/T13506.stderr - testsuite/tests/typecheck/should_fail/T16512a.stderr - testsuite/tests/typecheck/should_fail/T18851b.hs - − testsuite/tests/typecheck/should_fail/T18851b.stderr - testsuite/tests/typecheck/should_fail/T18851c.hs - − testsuite/tests/typecheck/should_fail/T18851c.stderr - testsuite/tests/typecheck/should_fail/T19415.stderr - testsuite/tests/typecheck/should_fail/T19415b.stderr - testsuite/tests/typecheck/should_fail/T22684.stderr - + testsuite/tests/typecheck/should_fail/T23162a.hs - + testsuite/tests/typecheck/should_fail/T23162a.stderr - testsuite/tests/typecheck/should_fail/T25325.stderr - testsuite/tests/typecheck/should_fail/T5246.stderr - testsuite/tests/typecheck/should_fail/T5978.stderr - testsuite/tests/typecheck/should_fail/T7368a.stderr - testsuite/tests/typecheck/should_fail/T7696.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail122.stderr - testsuite/tests/typecheck/should_fail/tcfail143.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/040919fec6783a2b2e0b9c4b54fbc0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/040919fec6783a2b2e0b9c4b54fbc0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26349] 10 commits: Skip uniques test if sources are not available
by Simon Peyton Jones (＠simonpj) 30 Oct '25

30 Oct '25

Simon Peyton Jones pushed to branch wip/T26349 at Glasgow Haskell Compiler / GHC Commits: 5dc2e9ea by Julian Ospald at 2025-10-27T18:17:23-04:00 Skip uniques test if sources are not available - - - - - 544b9ec9 by Vladislav Zavialov at 2025-10-27T18:18:06-04:00 Re-export GHC.Hs.Basic from GHC.Hs Clean up some import sections in GHC by re-exporting GHC.Hs.Basic from GHC.Hs. - - - - - 643ce801 by Julian Ospald at 2025-10-28T18:18:55-04:00 rts: remove unneccesary cabal flags We perform those checks via proper autoconf macros instead that do the right thing and then add those libs to the rts buildinfo. - - - - - d69ea8fe by Vladislav Zavialov at 2025-10-28T18:19:37-04:00 Test case for #17705 Starting with GHC 9.12 (the first release to include 5745dbd3), all examples in this ticket are handled as expected. - - - - - 4038a28b by Andreas Klebinger at 2025-10-30T12:38:52-04:00 Add a perf test for #26425 - - - - - f997618e by Andreas Klebinger at 2025-10-30T12:38:52-04:00 OccAnal: Be stricter for better compiler perf. In particular we are now stricter: * When combining usageDetails. * When computing binder info. In combineUsageDetails when combining the underlying adds we compute a new `LocalOcc` for each entry by combining the two existing ones. Rather than wait for those entries to be forced down the road we now force them immediately. Speeding up T26425 by about 10% with little effect on the common case. We also force binders we put into the Core AST everywhere now. Failure to do so risks leaking the occ env used to set the binders OccInfo. For T26425 compiler residency went down by a factor of ~10x. Compile time also improved by a factor of ~1.6. ------------------------- Metric Decrease: T18698a T26425 T9233 ------------------------- - - - - - 5618645b by Vladislav Zavialov at 2025-10-30T12:39:33-04:00 Fix namespace specifiers in subordinate exports (#12488) This patch fixes an oversight in the `lookupChildrenExport` function that caused explicit namespace specifiers of subordinate export items to be ignored: module M (T (type A)) where -- should be rejected data T = A Based on the `IEWrappedName` data type, there are 5 cases to consider: 1. Unadorned name: P(X) 2. Named default: P(default X) 3. Pattern synonym: P(pattern X) 4. Type name: P(type X) 5. Data name: P(data X) Case 1 is already handled correctly; cases 2 and 3 are parse errors; and it is cases 4 and 5 that we are concerned with in this patch. Following the precedent established in `LookupExactName`, we introduce a boolean flag in `LookupChildren` to control whether to look up in all namespaces or in a specific one. If an export item is accompanied by an explicit namespace specifier `type` or `data`, we restrict the lookup in `lookupGRE` to a specific namespace. The newly introduced diagnostic `TcRnExportedSubordinateNotFound` provides error messages and suggestions more tailored to this context than the previously used `reportUnboundName`. - - - - - ce0773a7 by Simon Peyton Jones at 2025-10-30T17:02:14+00:00 Add a HsWrapper optimiser This is an experimental MR. The big change is adding `GHC.Tc.Types.Evidence.optHsWrapper Addresses #26349 A bit more Working, I think Remove silly trace Better now Added WpSubType Remove trace better More Comments and one test wibble - - - - - 9f6aee01 by Simon Peyton Jones at 2025-10-30T17:02:14+00:00 Improve mkWpFun_FRR This commit ensures that `mkWpFun_FRR` directly produces a `FunCo` in the cases where it can. (Previously called `mkWpFun` which in turn optimised to a `FunCo`, but that made the smarts in `mkWpFun` /essential/ rather than (as they should be) optional. - - - - - f4f71579 by Simon Peyton Jones at 2025-10-30T17:02:14+00:00 Comments only - - - - - 82 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var/Env.hs - m4/fp_check_pthreads.m4 - rts/configure.ac - + rts/rts.buildinfo.in - rts/rts.cabal - testsuite/tests/linters/all.T - testsuite/tests/module/mod4.stderr - + testsuite/tests/parser/should_fail/T12488c.hs - + testsuite/tests/parser/should_fail/T12488c.stderr - + testsuite/tests/parser/should_fail/T12488d.hs - + testsuite/tests/parser/should_fail/T12488d.stderr - testsuite/tests/parser/should_fail/all.T - + testsuite/tests/perf/compiler/T26425.hs - testsuite/tests/perf/compiler/all.T - + testsuite/tests/rename/should_compile/T12488b.hs - + testsuite/tests/rename/should_compile/T12488f.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T12488a.hs - + testsuite/tests/rename/should_fail/T12488a.stderr - + testsuite/tests/rename/should_fail/T12488a_foo.hs - + testsuite/tests/rename/should_fail/T12488a_foo.stderr - + testsuite/tests/rename/should_fail/T12488e.hs - + testsuite/tests/rename/should_fail/T12488e.stderr - + testsuite/tests/rename/should_fail/T12488g.hs - + testsuite/tests/rename/should_fail/T12488g.stderr - testsuite/tests/rename/should_fail/T25899e2.stderr - testsuite/tests/rename/should_fail/all.T - + testsuite/tests/simplCore/should_compile/T26349.hs - + testsuite/tests/simplCore/should_compile/T26349.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/simplCore/should_compile/rule2.stderr - + testsuite/tests/typecheck/should_compile/T17705.hs - testsuite/tests/typecheck/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6676d34dab1bc325de619605b2d8ea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6676d34dab1bc325de619605b2d8ea… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps] Load TH deps from home unit states of the modules that import them
by Torsten Schmits (＠torsten.schmits) 30 Oct '25

30 Oct '25

Torsten Schmits pushed to branch wip/torsten.schmits/mercury-ghc910-mhu-transitive-th-deps at Glasgow Haskell Compiler / GHC Commits: 1c80ba27 by Torsten Schmits at 2025-10-30T17:58:26+01:00 Load TH deps from home unit states of the modules that import them - - - - - 3 changed files: - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs Changes: ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Linker.Deps ( LinkDepsOpts (..) , LinkDeps (..) + , LibraryUnits (..) , getLinkDeps ) where @@ -83,10 +84,16 @@ data LinkDepsOpts = LinkDepsOpts data LinkDeps = LinkDeps { ldNeededLinkables :: [Linkable] , ldAllLinkables :: [Linkable] - , ldNeededUnits :: [UnitId] + , ldNeededUnits :: [LibraryUnits] , ldAllUnits :: UniqDSet UnitId } +data LibraryUnits + = LibraryUnits + { home_unit :: !UnitId + , library_unit :: !UnitId + } + -- | Find all the packages and linkables that a set of modules depends on -- -- Return the module and package dependencies for the needed modules. @@ -155,10 +162,10 @@ get_link_deps opts pls maybe_normal_osuf span mods = do link_mods = listToUDFM [(moduleName (mi_module (hm_iface m)), m) | m <- mmods] link_libs = - uniqDSetToList (unionManyUniqDSets (init_pkg_set : pkgs)) + eltsUDFM (foldl' plusUDFM emptyUDFM (init_pkg_set : pkgs)) pure $ LinkModules (LinkHomeModule <$> link_mods) : - (LinkLibrary <$> link_libs) + link_libs -- This code is used in `--make` mode to calculate the home package and unit dependencies -- for a set of modules. @@ -168,7 +175,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do -- It is also a matter of correctness to use the module graph so that dependencies between home units -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) + make_deps_loop :: (UniqDFM UnitId LinkDep, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDFM UnitId LinkDep, Set.Set NodeKey) make_deps_loop found [] = found make_deps_loop found@(found_units, found_mods) (nk:nexts) | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts @@ -176,7 +183,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do case fmap mkNodeKey <$> mgReachable mod_graph (NodeKey_Module nk) of Nothing -> let (ModNodeKeyWithUid _ uid) = nk - in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts + in make_deps_loop (addToUDFM found_units uid (LinkLibrary LibraryUnits {library_unit = uid, home_unit = (ue_current_unit (ldUnitEnv opts))}), found_mods) nexts Just trans_deps -> let deps = Set.insert (NodeKey_Module nk) (Set.fromList trans_deps) -- See #936 and the ghci.prog007 test for why we have to continue traversing through @@ -185,7 +192,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts) mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) - (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods) + (init_pkg_set, all_deps) = make_deps_loop (emptyUDFM, Set.empty) $ map mkNk (filterOut isInteractiveModule mods) all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps] @@ -195,7 +202,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do let iface = hm_iface hmi case mi_hsc_src iface of HsBootFile -> throwProgramError opts $ link_boot_mod_error (mi_module iface) - _ -> pure (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface), hmi) + _ -> pure (listToUDFM [(u, LinkLibrary LibraryUnits {library_unit = u, home_unit = (moduleUnitId (mi_module iface))}) | u <- Set.toList $ dep_direct_pkgs (mi_deps iface)], hmi) Nothing -> throwProgramError opts $ text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid @@ -279,12 +286,13 @@ instance Outputable LinkModule where data LinkDep = LinkModules (UniqDFM ModuleName LinkModule) | - LinkLibrary UnitId + LinkLibrary LibraryUnits instance Outputable LinkDep where ppr = \case LinkModules mods -> text "modules:" <+> ppr (eltsUDFM mods) - LinkLibrary uid -> text "library:" <+> ppr uid + LinkLibrary (LibraryUnits {home_unit, library_unit}) -> + text "library:" <+> ppr library_unit <+> parens (ppr home_unit) data OneshotError = NoLocation Module @@ -337,7 +345,7 @@ oneshot_deps_loop opts (mod : mods) acc = do already_seen | Just (LinkModules mods) <- mod_dep = elemUDFM mod_name mods - | Just (LinkLibrary _) <- mod_dep + | Just (LinkLibrary {}) <- mod_dep = True | otherwise = False @@ -362,7 +370,7 @@ oneshot_deps_loop opts (mod : mods) acc = do | otherwise = add_library - add_library = pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), []) + add_library = pure (addToUDFM acc mod_unit_id (LinkLibrary LibraryUnits {library_unit = mod_unit_id, home_unit}), []) add_module iface lmod = (addListToUDFM with_mod (direct_pkgs iface), new_deps iface) @@ -378,7 +386,7 @@ oneshot_deps_loop opts (mod : mods) acc = do | bytecode = [] | otherwise - = [(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))] + = [(u, LinkLibrary LibraryUnits {library_unit = u, home_unit}) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))] new_deps iface | bytecode @@ -418,6 +426,7 @@ oneshot_deps_loop opts (mod : mods) acc = do text "due to use of Template Haskell" bytecode = ldUseByteCode opts + home_unit = homeUnitId (expectJust "oneshot_deps" mb_home) mb_home = ue_homeUnit (ldUnitEnv opts) link_boot_mod_error :: Module -> SDoc @@ -428,7 +437,7 @@ link_boot_mod_error mod = classify_deps :: LoaderState -> [LinkDep] -> - ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId]) + ([Linkable], [LinkModule], UniqDSet UnitId, [LibraryUnits]) classify_deps pls deps = (loaded_modules, needed_modules, all_packages, needed_packages) where @@ -436,13 +445,15 @@ classify_deps pls deps = partitionWith loaded_or_needed (concatMap eltsUDFM modules) needed_packages = - eltsUDFM (getUniqDSet all_packages `minusUDFM` pkgs_loaded pls) + eltsUDFM (packages `minusUDFM` pkgs_loaded pls) + + packages = listToUDFM [(library_unit p, p) | p <- packages_with_home_units] - all_packages = mkUniqDSet packages + all_packages = mkUniqDSet (map library_unit packages_with_home_units) - (modules, packages) = flip partitionWith deps $ \case + (modules, packages_with_home_units) = flip partitionWith deps $ \case LinkModules mods -> Left mods - LinkLibrary lib -> Right lib + LinkLibrary units -> Right units loaded_or_needed lm = maybe (Right lm) Left (loaded_linkable (mi_module (link_module_iface lm))) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -93,8 +93,9 @@ import Control.Monad import qualified Data.Set as Set import Data.Char (isSpace) +import Data.Foldable (for_) import Data.IORef -import Data.List (intercalate, isPrefixOf, nub, partition) +import Data.List (intercalate, isPrefixOf, nub, partition, sortOn) import Data.Maybe import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC @@ -109,6 +110,7 @@ import System.Win32.Info (getSystemDirectory) #endif import GHC.Utils.Exception +import qualified Data.List.NonEmpty as NE -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -173,7 +175,7 @@ emptyLoaderState = LoaderState -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) + where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId Nothing [] [] [] emptyUniqDSet) extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings = @@ -325,9 +327,8 @@ reallyInitLoaderState interp hsc_env = do -- (a) initialise the C dynamic linker initObjLinker interp - -- (b) Load packages from the command-line (Note [preload packages]) - pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) + pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp hsc_env [LibraryUnits {home_unit = u, library_unit = pre} | pre <- preloadUnits (homeUnitEnv_units env)] pls') (return pls0) (hsc_HUG hsc_env) -- steps (c), (d) and (e) loadCmdLineLibs' interp hsc_env pls @@ -855,7 +856,13 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again. - linkDynLib logger tmpfs dflags2 unit_env objs (loaded_pkg_uid <$> eltsUDFM pkgs_loaded) + do + let groupedLoadedPackageInfos = groupLoadedPackageInfosByParent pkgs_loaded + for_ groupedLoadedPackageInfos $ \(mParent, loaded_pkg_uids) -> do + let unit_env' = case mParent of + Nothing -> unit_env + Just parent -> ue_setActiveUnit parent unit_env + linkDynLib logger tmpfs dflags2 unit_env' objs loaded_pkg_uids -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] @@ -866,6 +873,19 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" + groupOn :: Eq k => (a -> k) -> [a] -> [NE.NonEmpty a] + groupOn f = NE.groupBy ((==) `on2` f) + -- redefine on so we avoid duplicate computation for most values. + where (.*.) `on2` f = \x -> let fx = f x in \y -> fx .*. f y + + groupLoadedPackageInfosByParent :: PkgsLoaded -> [(Maybe UnitId, [UnitId])] + groupLoadedPackageInfosByParent pkgs = + map (\l -> (loaded_pkg_parent (NE.head l), NE.toList $ NE.map loaded_pkg_uid l)) + $ groupOn loaded_pkg_parent + $ sortOn loaded_pkg_parent + $ eltsUDFM pkgs + + rmDupLinkables :: LinkableSet -- Already loaded -> [Linkable] -- New linkables -> (LinkableSet, -- New loaded set (including new ones) @@ -1075,36 +1095,39 @@ loadPackages interp hsc_env new_pkgs = do -- a lock. initLoaderState interp hsc_env modifyLoaderState_ interp $ \pls -> - loadPackages' interp hsc_env new_pkgs pls + loadPackages' interp hsc_env [LibraryUnits {home_unit = hscActiveUnitId hsc_env, library_unit} | library_unit <- new_pkgs] pls -loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState -loadPackages' interp hsc_env new_pks pls = do +loadPackages' :: Interp -> HscEnv -> [LibraryUnits] -> LoaderState -> IO LoaderState +loadPackages' interp hsc_env0 new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where - link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded + link :: PkgsLoaded -> [LibraryUnits] -> IO PkgsLoaded link pkgs new_pkgs = foldM link_one pkgs new_pkgs - link_one pkgs new_pkg - | new_pkg `elemUDFM` pkgs -- Already linked + link_one pkgs (LibraryUnits {home_unit, library_unit}) + | library_unit `elemUDFM` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg + | Just pkg_cfg <- lookupUnitId (hsc_units (hscSetActiveUnitId home_unit hsc_env)) library_unit = do { let deps = unitDepends pkg_cfg -- Link dependents first - ; pkgs' <- link pkgs deps + ; pkgs' <- link pkgs [LibraryUnits {home_unit, library_unit} | library_unit <- deps] + -- Now link the package itself ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg | dep_pkg <- deps , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) ] - ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } + ; return (addToUDFM pkgs' library_unit (LoadedPkgInfo library_unit (Just home_unit) hs_cls extra_cls loaded_dlls trans_deps)) } | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS library_unit))) + where + hsc_env = hscSetActiveUnitId home_unit hsc_env0 loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -192,6 +192,7 @@ type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo data LoadedPkgInfo = LoadedPkgInfo { loaded_pkg_uid :: !UnitId + , loaded_pkg_parent :: !(Maybe UnitId) , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] @@ -200,8 +201,9 @@ data LoadedPkgInfo } instance Outputable LoadedPkgInfo where - ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = - vcat [ppr uid + ppr (LoadedPkgInfo uid parent_uid hs_objs non_hs_objs _ trans_deps) = + vcat [ ppr uid + , ppr parent_uid , ppr hs_objs , ppr non_hs_objs , ppr trans_deps ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c80ba274d942b854db9fd8f029a5c2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1c80ba274d942b854db9fd8f029a5c2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Fix namespace specifiers in subordinate exports (#12488)
by Marge Bot (＠marge-bot) 30 Oct '25

30 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 5618645b by Vladislav Zavialov at 2025-10-30T12:39:33-04:00 Fix namespace specifiers in subordinate exports (#12488) This patch fixes an oversight in the `lookupChildrenExport` function that caused explicit namespace specifiers of subordinate export items to be ignored: module M (T (type A)) where -- should be rejected data T = A Based on the `IEWrappedName` data type, there are 5 cases to consider: 1. Unadorned name: P(X) 2. Named default: P(default X) 3. Pattern synonym: P(pattern X) 4. Type name: P(type X) 5. Data name: P(data X) Case 1 is already handled correctly; cases 2 and 3 are parse errors; and it is cases 4 and 5 that we are concerned with in this patch. Following the precedent established in `LookupExactName`, we introduce a boolean flag in `LookupChildren` to control whether to look up in all namespaces or in a specific one. If an export item is accompanied by an explicit namespace specifier `type` or `data`, we restrict the lookup in `lookupGRE` to a specific namespace. The newly introduced diagnostic `TcRnExportedSubordinateNotFound` provides error messages and suggestions more tailored to this context than the previously used `reportUnboundName`. - - - - - 28 changed files: - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - testsuite/tests/module/mod4.stderr - + testsuite/tests/parser/should_fail/T12488c.hs - + testsuite/tests/parser/should_fail/T12488c.stderr - + testsuite/tests/parser/should_fail/T12488d.hs - + testsuite/tests/parser/should_fail/T12488d.stderr - testsuite/tests/parser/should_fail/all.T - + testsuite/tests/rename/should_compile/T12488b.hs - + testsuite/tests/rename/should_compile/T12488f.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T12488a.hs - + testsuite/tests/rename/should_fail/T12488a.stderr - + testsuite/tests/rename/should_fail/T12488a_foo.hs - + testsuite/tests/rename/should_fail/T12488a_foo.stderr - + testsuite/tests/rename/should_fail/T12488e.hs - + testsuite/tests/rename/should_fail/T12488e.stderr - + testsuite/tests/rename/should_fail/T12488g.hs - + testsuite/tests/rename/should_fail/T12488g.stderr - testsuite/tests/rename/should_fail/T25899e2.stderr - testsuite/tests/rename/should_fail/all.T Changes: ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -679,19 +679,20 @@ lookupGlobalOccRn will find it. -} -- | Used in export lists to lookup the children. -lookupSubBndrOcc_helper :: Bool +lookupSubBndrOcc_helper :: Bool -- ^ must have a parent + -> Bool -- ^ look up in all namespaces -> DeprecationWarnings -> ParentGRE -- ^ parent -> RdrName -- ^ thing we are looking up -> RnM ChildLookupResult -lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent_gre rdr_name +lookupSubBndrOcc_helper must_have_parent all_ns warn_if_deprec parent_gre rdr_name | isUnboundName (parentGRE_name parent_gre) -- Avoid an error cascade = return (FoundChild (mkUnboundGRERdr rdr_name)) | otherwise = do gre_env <- getGlobalRdrEnv - let original_gres = lookupGRE gre_env (LookupChildren parent_gre (rdrNameOcc rdr_name)) + let original_gres = lookupGRE gre_env (LookupChildren parent_gre (rdrNameOcc rdr_name) all_ns) picked_gres = pick_gres original_gres -- The remaining GREs are things that we *could* export here. -- Note that this includes things which have `NoParent`; @@ -844,7 +845,7 @@ lookupSubBndrOcc :: DeprecationWarnings lookupSubBndrOcc warn_if_deprec the_parent what_subordinate rdr_name = lookupExactOrOrig rdr_name (Right . greName) $ -- This happens for built-in classes, see mod052 for example - do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name + do { child <- lookupSubBndrOcc_helper True True warn_if_deprec the_parent rdr_name ; return $ case child of FoundChild g -> Right (greName g) NameNotFound -> Left unknown_sub ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -23,6 +23,7 @@ module GHC.Rename.Names ( checkConName, mkChildEnv, findChildren, + mkBadExportSubordinate, findImportUsage, getMinimalImports, printMinimalImports, @@ -1423,6 +1424,15 @@ filterImports hsc_env iface decl_spec (Just (want_hiding, L l import_items)) where name = greName gre +-- | Assuming a subordinate item could not be found, do another lookup for a +-- more specific error message. +mkBadExportSubordinate :: [GlobalRdrElt] -> LIEWrappedName GhcPs -> BadExportSubordinate +mkBadExportSubordinate child_gres n = + case lookupChildren child_gres [n] of + (LookupChildNonType {lce_nontype_item = g} : _, _) -> BadExportSubordinateNonType g + (LookupChildNonData {lce_nondata_item = g} : _, _) -> BadExportSubordinateNonData g + _ -> BadExportSubordinateNotFound n + type IELookupM = MaybeErr IELookupError data IELookupWarning ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -675,6 +675,43 @@ instance Diagnostic TcRnMessage where what_is = pp_category ty_thing thing = ppr $ nameOccName child parents = map ppr parent_names + TcRnExportedSubordinateNotFound parent_gre k _ -> + mkSimpleDecorated $ + case k of + BadExportSubordinateNotFound wname -> + let child_name = lieWrappedName wname + child_name_fs = occNameFS (rdrNameOcc child_name) + suggest_patsyn = allow_patsyn && could_be_patsyn + could_be_patsyn = + case unLoc wname of + IEName{} -> isLexCon child_name_fs + IEData{} -> isLexCon child_name_fs + IEPattern{} -> True + IEType{} -> False + IEDefault{} -> False + basic_msg = + what_parent <+> quotes (ppr parent_name) + <+> "does not define a child named" <+> quotes (ppr child_name) + patsyn_msg = + text "nor is there a pattern synonym of that name in scope" + combined_msg + | suggest_patsyn = basic_msg <> comma $$ patsyn_msg <> dot + | otherwise = basic_msg <> dot + in combined_msg + BadExportSubordinateNonType gre -> + let child_name = greName gre + in what_parent <+> quotes (ppr parent_name) <+> "defines a child named" <+> quotes (ppr child_name) <> comma + $$ text "but it is not in the type namespace." + BadExportSubordinateNonData gre -> + let child_name = greName gre + in what_parent <+> quotes (ppr parent_name) <+> "defines a child named" <+> quotes (ppr child_name) <> comma + $$ text "but it is not in the data namespace." + where + parent_name = greName parent_gre + (what_parent, allow_patsyn) = case greInfo parent_gre of + IAmTyCon ClassFlavour -> (text "The class", False) + IAmTyCon _ -> (text "The data type", True) + _ -> (text "The item", False) TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2 -> mkSimpleDecorated $ vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon @@ -2204,6 +2241,8 @@ instance Diagnostic TcRnMessage where -> WarningWithFlag Opt_WarnDuplicateExports TcRnExportedParentChildMismatch{} -> ErrorWithoutFlag + TcRnExportedSubordinateNotFound{} + -> ErrorWithoutFlag TcRnConflictingExports{} -> ErrorWithoutFlag TcRnDuplicateFieldExport {} @@ -2875,6 +2914,13 @@ instance Diagnostic TcRnMessage where -> noHints TcRnExportedParentChildMismatch{} -> noHints + TcRnExportedSubordinateNotFound _ k similar_names + -> ns_spec_hints ++ similar_names + where + ns_spec_hints = case k of + BadExportSubordinateNotFound{} -> noHints + BadExportSubordinateNonType{} -> [SuggestChangeExportItem ExportItemRemoveSubordinateType] + BadExportSubordinateNonData{} -> [SuggestChangeExportItem ExportItemRemoveSubordinateData] TcRnConflictingExports{} -> noHints TcRnDuplicateFieldExport {} ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -83,7 +83,6 @@ module GHC.Tc.Errors.Types ( , Subordinate(..), pprSubordinate , ImportError(..) , WhatLooking(..) - , lookingForSubordinate , HoleError(..) , CoercibleMsg(..) , NoBuiltinInstanceMsg(..) @@ -117,6 +116,7 @@ module GHC.Tc.Errors.Types ( , HsTyVarBndrExistentialFlag(..) , TySynCycleTyCons , BadImportKind(..) + , BadExportSubordinate(..) , DodgyImportsReason (..) , ImportLookupExtensions (..) , ImportLookupReason (..) @@ -1664,6 +1664,26 @@ data TcRnMessage where -> Name -- ^ child -> [Name] -> TcRnMessage + {-| TcRnExportedSubordinateNotFound is an error that occurs when the name of a + subordinate export item is not in scope. + + Example: + module M (T(X)) where -- X is not in scope + data T = Y + + Test cases: module/mod4 + rename/should_fail/T12488a + rename/should_fail/T12488a_foo + rename/should_fail/T12488e + rename/should_fail/T12488g + rename/should_fail/T25899e2 + -} + TcRnExportedSubordinateNotFound + :: GlobalRdrElt -- ^ parent + -> BadExportSubordinate + -> [GhcHint] -- ^ similar name suggestions + -> TcRnMessage + {-| TcRnConflictingExports is an error that occurs when different identifiers that have the same name are being exported by a module. @@ -5829,6 +5849,11 @@ data BadImportKind | BadImportAvailVar deriving Generic +data BadExportSubordinate + = BadExportSubordinateNotFound !(LIEWrappedName GhcPs) + | BadExportSubordinateNonType !GlobalRdrElt + | BadExportSubordinateNonData !GlobalRdrElt + {- Note [Reasons for BadImportAvailTyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BadImportAvailTyCon means a name is available in the TcCls namespace @@ -6065,15 +6090,6 @@ data WhatLooking = WL_Anything -- is no point in suggesting alternative spellings deriving (Eq, Show) --- | In what namespaces should we look for a subordinate --- of the given 'GlobalRdrElt'. -lookingForSubordinate :: GlobalRdrElt -> WhatLooking -lookingForSubordinate parent_gre = - case greInfo parent_gre of - IAmTyCon ClassFlavour - -> WL_TyCon_or_TermVar - _ -> WL_Term - -- | This datatype collates instances that match or unifier, -- in order to report an error message for an unsolved typeclass constraint. data PotentialInstances ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Rename.Doc import GHC.Rename.Module import GHC.Rename.Names import GHC.Rename.Env -import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Rename.Unbound ( mkUnboundNameRdr ) import GHC.Rename.Splice import GHC.Unit.Module import GHC.Unit.Module.Imported @@ -30,13 +30,13 @@ import GHC.Unit.Module.Warnings import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Misc (fuzzyLookup) import GHC.Core.ConLike import GHC.Core.PatSyn import GHC.Data.Maybe import GHC.Data.FastString (fsLit) import GHC.Driver.Env import GHC.Driver.DynFlags -import GHC.Parser.PostProcess ( setRdrNameSpace ) import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Unique.Map @@ -50,6 +50,7 @@ import GHC.Types.SourceFile import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name.Reader +import GHC.Types.Hint import Control.Arrow ( first ) import Control.Monad ( when ) @@ -590,8 +591,9 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie_kids_with :: GlobalRdrElt -> [LIEWrappedName GhcPs] -> RnM ([LIEWrappedName GhcRn], [GlobalRdrElt]) lookup_ie_kids_with gre sub_rdrs = - do { kids <- lookupChildrenExport gre sub_rdrs - ; return (map fst kids, map snd kids) } + do { let child_gres = findChildren kids_env (greName gre) + ; kids <- lookupChildrenExport gre child_gres sub_rdrs + ; return (unzip kids) } lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt -> RnM [GlobalRdrElt] @@ -782,9 +784,10 @@ If the module has NO main function: lookupChildrenExport :: GlobalRdrElt + -> [GlobalRdrElt] -> [LIEWrappedName GhcPs] -> RnM ([(LIEWrappedName GhcRn, GlobalRdrElt)]) -lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items +lookupChildrenExport parent_gre child_gres rdr_items = mapAndReportM doOne rdr_items where spec_parent = greName parent_gre -- Process an individual child @@ -792,24 +795,23 @@ lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items -> RnM (LIEWrappedName GhcRn, GlobalRdrElt) doOne n = do - let bareName = (ieWrappedName . unLoc) n + let all_ns = case unLoc n of + IEName{} -> True -- Ignore the namespace iff the name is unadorned + _ -> False + let bareName = lieWrappedName n -- Do not report export list declaration deprecations - name <- lookupSubBndrOcc_helper False ExportDeprecationWarnings + name <- lookupSubBndrOcc_helper False all_ns ExportDeprecationWarnings (ParentGRE spec_parent (greInfo parent_gre)) bareName traceRn "lookupChildrenExport" (ppr name) - -- Default to data constructors for slightly better error - -- messages - let unboundName :: RdrName - unboundName = if rdrNameSpace bareName == varName - then bareName - else setRdrNameSpace bareName dataName case name of NameNotFound -> - do { ub <- reportUnboundName (lookingForSubordinate parent_gre) unboundName - ; let l = getLoc n + do { let err = mkBadExportSubordinate child_gres n + similar_names = subordinateExportSimilarNames bareName child_gres + ; addDiagnosticTc (TcRnExportedSubordinateNotFound parent_gre err similar_names) + ; let ub = mkUnboundNameRdr bareName gre = mkLocalGRE UnboundGRE NoParent ub - ; return (L l (IEName noExtField (L (l2l l) ub)), gre)} + ; return (replaceLWrappedName n ub, gre)} FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> do { checkPatSynParent spec_parent par child_nm ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm) @@ -817,6 +819,22 @@ lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items } IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs +subordinateExportSimilarNames :: RdrName -> [GlobalRdrElt] -> [GhcHint] +subordinateExportSimilarNames rdr_name child_gres = + -- At the moment, we only suggest other children of the same parent. + -- One possible improvement would be to suggest bundling pattern synonyms with + -- data types, but not with classes or type data. + case NE.nonEmpty similar_names of + Nothing -> [] + Just nms -> [SuggestSimilarNames rdr_name (fmap SimilarName nms)] + where + occ_name = rdrNameOcc rdr_name + similar_names = + fuzzyLookup (occNameString occ_name) + [(occNameString child_occ_name, greName gre) + | gre <- child_gres + , let child_occ_name = greOccName gre + , occNameFS occ_name /= occNameFS child_occ_name ] -- Note [Typing Pattern Synonym Exports] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Types/Error/Codes.hs ===================================== @@ -510,6 +510,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnDuplicateExport" = 47854 GhcDiagnosticCode "TcRnDuplicateNamedDefaultExport" = 31584 GhcDiagnosticCode "TcRnExportedParentChildMismatch" = 88993 + GhcDiagnosticCode "TcRnExportedSubordinateNotFound" = 11592 GhcDiagnosticCode "TcRnConflictingExports" = 69158 GhcDiagnosticCode "TcRnDuplicateFieldExport" = 97219 GhcDiagnosticCode "TcRnAmbiguousFieldInUpdate" = 56428 ===================================== compiler/GHC/Types/Hint.hs ===================================== @@ -7,6 +7,7 @@ module GHC.Types.Hint ( , LanguageExtensionHint(..) , ImportItemSuggestion(..) , ImportSuggestion(..) + , ExportItemSuggestion(..) , HowInScope(..) , SimilarName(..) , StarIsType(..) @@ -419,6 +420,12 @@ data GhcHint -} | ImportSuggestion OccName ImportSuggestion + {-| Suggest to change an export item, e.g. to remove a namespace specifier. + + Test cases: T12488a, T12488a_foo, T12488e, T12488g, T25899e2 + -} + | SuggestChangeExportItem ExportItemSuggestion + {-| Found a pragma in the body of a module, suggest placing it in the header. -} | SuggestPlacePragmaInHeader @@ -556,6 +563,11 @@ data ImportItemSuggestion = -- Why no 'ImportItemAddData'? Because the suggestion to add 'data' is -- represented by the 'ImportDataCon' constructor of 'ImportSuggestion'. +-- | Suggest to change an export item. +data ExportItemSuggestion = + ExportItemRemoveSubordinateType + | ExportItemRemoveSubordinateData + -- | Suggest how to fix an import. data ImportSuggestion -- | Some module exports what we want, but we aren't explicitly importing it. ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -214,6 +214,10 @@ instance Outputable GhcHint where <+> pprQuotedList parents ImportSuggestion occ_name import_suggestion -> pprImportSuggestion occ_name import_suggestion + SuggestChangeExportItem export_item_suggestion + -> case export_item_suggestion of + ExportItemRemoveSubordinateType -> text "Remove the" <+> quotes (text "type") <+> text "keyword" + ExportItemRemoveSubordinateData -> text "Remove the" <+> quotes (text "data") <+> text "keyword" SuggestPlacePragmaInHeader -> text "Perhaps you meant to place it in the module header?" $$ text "The module header is the section at the top of the file, before the" <+> quotes (text "module") <+> text "keyword" ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -1182,8 +1182,12 @@ data LookupGRE info where -- | Look up children 'GlobalRdrElt's with a given 'Parent'. LookupChildren - :: ParentGRE -- ^ the parent - -> OccName -- ^ the child 'OccName' to look up + :: { lookupParentGRE :: ParentGRE -- ^ the parent + , lookupChildOccName :: OccName -- ^ the child 'OccName' to look up + , lookupChildrenInAllNameSpaces :: Bool + -- ^ whether to look in *all* 'NameSpace's, or just + -- in the 'NameSpace' of the 'OccName' + } -> LookupGRE GREInfo -- | How should we look up in a 'GlobalRdrEnv'? @@ -1420,10 +1424,15 @@ lookupGRE env = \case occ = nameOccName nm lkup | all_ns = concat $ lookupOccEnv_AllNameSpaces env occ | otherwise = fromMaybe [] $ lookupOccEnv env occ - LookupChildren parent child_occ -> - let ns = occNameSpace child_occ - all_gres = concat $ lookupOccEnv_AllNameSpaces env child_occ - in highestPriorityGREs (childGREPriority parent ns) all_gres + LookupChildren { lookupParentGRE = parent + , lookupChildOccName = child_occ + , lookupChildrenInAllNameSpaces = all_ns } -> + highestPriorityGREs (childGREPriority parent ns) $ + concat $ lkup env child_occ + where + ns = occNameSpace child_occ + lkup | all_ns = lookupOccEnv_AllNameSpaces + | otherwise = lookupOccEnv_WithFields -- | Collect the 'GlobalRdrElt's with the highest priority according -- to the given function (lower value <=> higher priority). ===================================== testsuite/tests/module/mod4.stderr ===================================== @@ -1,5 +1,6 @@ - -mod4.hs:2:10: error: [GHC-76037] - • Not in scope: data constructor ‘K2’ +mod4.hs:2:10: error: [GHC-11592] + • The data type ‘T’ does not define a child named ‘K2’, + nor is there a pattern synonym of that name in scope. • In the export: T(K1, K2) - Suggested fix: Perhaps use ‘K1’ (line 3) + Suggested fix: Perhaps use ‘K1’ (Defined at mod4.hs:3:10) + ===================================== testsuite/tests/parser/should_fail/T12488c.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module T12488c ( T (pattern A) ) where + +data T = A \ No newline at end of file ===================================== testsuite/tests/parser/should_fail/T12488c.stderr ===================================== @@ -0,0 +1,2 @@ +T12488c.hs:2:21: error: [GHC-58481] parse error on input ‘pattern’ + ===================================== testsuite/tests/parser/should_fail/T12488d.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE NamedDefaults #-} +module T12488d ( T (default C) ) where + +class C a where + +data T = A \ No newline at end of file ===================================== testsuite/tests/parser/should_fail/T12488d.stderr ===================================== @@ -0,0 +1,2 @@ +T12488d.hs:2:21: error: [GHC-58481] parse error on input ‘default’ + ===================================== testsuite/tests/parser/should_fail/all.T ===================================== @@ -242,3 +242,5 @@ test('T25258b', normal, compile_fail, ['']) test('T25258c', normal, compile_fail, ['']) test('T25530', normal, compile_fail, ['']) test('T26418', normal, compile_fail, ['']) +test('T12488c', normal, compile_fail, ['']) +test('T12488d', normal, compile_fail, ['']) ===================================== testsuite/tests/rename/should_compile/T12488b.hs ===================================== @@ -0,0 +1,24 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} + +module T12488b + ( T ( data A, -- data constructor (alphanumeric name) + data fld, -- record field (alphanumeric name) + data (:!!), -- data constructor (symbolic name) + data (///) -- record field (symbolic name) + ), + C ( type F, -- associated type (alphanumeric name) + data meth, -- class method (alphanumeric name) + type (+++), -- associated type (symbolic name) + data (***) -- class method (symbolic name) + ), + ) where + +data T = A { fld :: Int } + | (:!!) { (///) :: Int -> Int } + +class C a where + type F a + type (+++) a + meth :: a -> a + (***) :: a -> a -> a ===================================== testsuite/tests/rename/should_compile/T12488f.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} + +module T12488f + ( C ( type (+++), -- associated type (symbolic name) + data (++-) -- class method (symbolic name) + ), + ) where + +class C a where + type (+++) a -- exported + type (++-) a -- not exported + (+++) :: a -> a -- not exported + (++-) :: a -> a -- exported ===================================== testsuite/tests/rename/should_compile/all.T ===================================== @@ -245,3 +245,5 @@ test('T25899a', normal, compile, ['']) test('T25899b', normal, compile, ['']) test('T25899c', [extra_files(['T25899c_helper.hs'])], multimod_compile, ['T25899c', '-v0']) test('T25899d', combined_output, ghci_script, ['T25899d.script']) +test('T12488b', normal, compile, ['']) +test('T12488f', normal, compile, ['']) ===================================== testsuite/tests/rename/should_fail/T12488a.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE ExplicitNamespaces #-} +module T12488a + ( T (type A) + , (:!) (type (:/)) + ) where + +data T = A + +data (:!) = (:/) \ No newline at end of file ===================================== testsuite/tests/rename/should_fail/T12488a.stderr ===================================== @@ -0,0 +1,12 @@ +T12488a.hs:3:5: error: [GHC-11592] + • The data type ‘T’ defines a child named ‘A’, + but it is not in the type namespace. + • In the export: T(type A) + Suggested fix: Remove the ‘type’ keyword + +T12488a.hs:4:5: error: [GHC-11592] + • The data type ‘:!’ defines a child named ‘:/’, + but it is not in the type namespace. + • In the export: (:!)(type (:/)) + Suggested fix: Remove the ‘type’ keyword + ===================================== testsuite/tests/rename/should_fail/T12488a_foo.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} +module T12488a_foo ( T (type A) ) where + +data T = A + +class Foo a where + type A a + foo :: a -> Int ===================================== testsuite/tests/rename/should_fail/T12488a_foo.stderr ===================================== @@ -0,0 +1,6 @@ +T12488a_foo.hs:3:22: error: [GHC-11592] + • The data type ‘T’ defines a child named ‘A’, + but it is not in the type namespace. + • In the export: T(type A) + Suggested fix: Remove the ‘type’ keyword + ===================================== testsuite/tests/rename/should_fail/T12488e.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} +module T12488e + ( C (data A) + , D (data (+++)) + ) where + +class C a where + type A a + +class D a where + type (+++) a \ No newline at end of file ===================================== testsuite/tests/rename/should_fail/T12488e.stderr ===================================== @@ -0,0 +1,12 @@ +T12488e.hs:4:5: error: [GHC-11592] + • The class ‘C’ defines a child named ‘A’, + but it is not in the data namespace. + • In the export: C(data A) + Suggested fix: Remove the ‘data’ keyword + +T12488e.hs:5:5: error: [GHC-11592] + • The class ‘D’ defines a child named ‘+++’, + but it is not in the data namespace. + • In the export: D(data (+++)) + Suggested fix: Remove the ‘data’ keyword + ===================================== testsuite/tests/rename/should_fail/T12488g.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} +module T12488g + ( C (data (+++), + type (++-)) + ) where + +class C a where + type (+++) a + (++-) :: a -> a ===================================== testsuite/tests/rename/should_fail/T12488g.stderr ===================================== @@ -0,0 +1,16 @@ +T12488g.hs:4:5: error: [GHC-11592] + • The class ‘C’ defines a child named ‘++-’, + but it is not in the type namespace. + • In the export: C(data (+++), type (++-)) + Suggested fixes: + • Remove the ‘type’ keyword + • Perhaps use ‘+++’ (Defined at T12488g.hs:9:3) + +T12488g.hs:4:5: error: [GHC-11592] + • The class ‘C’ defines a child named ‘+++’, + but it is not in the data namespace. + • In the export: C(data (+++), type (++-)) + Suggested fixes: + • Remove the ‘data’ keyword + • Perhaps use ‘++-’ (Defined at T12488g.hs:10:3) + ===================================== testsuite/tests/rename/should_fail/T25899e2.stderr ===================================== @@ -1,4 +1,6 @@ -T25899e2.hs:5:5: error: [GHC-76037] - • Not in scope: data constructor ‘MkT’ +T25899e2.hs:5:5: error: [GHC-11592] + • The data type ‘T’ defines a child named ‘MkT’, + but it is not in the data namespace. • In the export: type T(data MkT) + Suggested fix: Remove the ‘data’ keyword ===================================== testsuite/tests/rename/should_fail/all.T ===================================== @@ -246,3 +246,7 @@ test('T25899e1', normal, compile_fail, ['']) test('T25899e2', normal, compile_fail, ['']) test('T25899e3', [extra_files(['T25899e_helper.hs'])], multimod_compile_fail, ['T25899e3', '-v0']) test('T25899f', [extra_files(['T25899f_helper.hs'])], multimod_compile_fail, ['T25899f', '-v0']) +test('T12488a', normal, compile_fail, ['']) +test('T12488a_foo', normal, compile_fail, ['']) +test('T12488e', normal, compile_fail, ['']) +test('T12488g', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5618645b5860bf65546108e578a7ebf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5618645b5860bf65546108e578a7ebf… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Add a perf test for #26425
by Marge Bot (＠marge-bot) 30 Oct '25

30 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4038a28b by Andreas Klebinger at 2025-10-30T12:38:52-04:00 Add a perf test for #26425 - - - - - f997618e by Andreas Klebinger at 2025-10-30T12:38:52-04:00 OccAnal: Be stricter for better compiler perf. In particular we are now stricter: * When combining usageDetails. * When computing binder info. In combineUsageDetails when combining the underlying adds we compute a new `LocalOcc` for each entry by combining the two existing ones. Rather than wait for those entries to be forced down the road we now force them immediately. Speeding up T26425 by about 10% with little effect on the common case. We also force binders we put into the Core AST everywhere now. Failure to do so risks leaking the occ env used to set the binders OccInfo. For T26425 compiler residency went down by a factor of ~10x. Compile time also improved by a factor of ~1.6. ------------------------- Metric Decrease: T18698a T26425 T9233 ------------------------- - - - - - 5 changed files: - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Var/Env.hs - + testsuite/tests/perf/compiler/T26425.hs - testsuite/tests/perf/compiler/all.T Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -9,6 +9,8 @@ -- many /other/ arguments the function has. Inconsistent unboxing is very -- bad for performance, so I increased the limit to allow it to unbox -- consistently. +-- AK: Seems we no longer unbox OccEnv now anyway so it might be redundant. + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -967,6 +969,12 @@ occAnalBind -> ([CoreBind] -> r -> r) -- How to combine the scope with new binds -> WithUsageDetails r -- Of the whole let(rec) +-- AK: While not allocating any less inlining occAnalBind turns calls to the +-- passed functions into known calls with all the benefits that brings. +-- On a version of T26425 with 6k alternatives this improved compile +-- by 10-20% with -O. +{-# INLINE occAnalBind #-} + occAnalBind env lvl ire (Rec pairs) thing_inside combine = addInScopeList env (map fst pairs) $ \env -> let WUD body_uds body' = thing_inside env @@ -984,7 +992,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine = -- Analyse the RHS and /then/ the body let -- Analyse the rhs first, generating rhs_uds !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs - rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of + rhs_uds = foldl1' orUDs rhs_uds_s -- NB: orUDs. See (W4) of -- Note [Occurrence analysis for join points] -- Now analyse the body, adding the join point @@ -1049,6 +1057,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- Match join arity O from mb_join_arity with manifest join arity M as -- returned by of occAnalLamTail. It's totally OK for them to mismatch; -- hence adjust the UDs from the RHS + WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ occAnalLamTail rhs_env rhs final_bndr_with_rules @@ -2054,6 +2063,18 @@ So The Plan is this: was a loop breaker last time round Hence the is_lb field of NodeScore + +Note [Strictness in the occurrence analyser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +By carefully making the occurrence analyser strict in some places, we can +dramatically reduce its memory residency. Among other things we: +* Evaluate the result of `tagLamBinder` and friends, so that the binder (or its + OccInfo) does not retain the entire `UsageDetails`. Also use `strictMap` in `tagLamBinders`. +* In `combineUsageDetailsWith`, the fields of the data constructor are strict, and we use + `strictPlusVarEnv` on the maps that are bound to be needed later on to avoid thunks being + stored in the values. + +These measures reduced residency for test T26425 by a factor of at least 5x. -} {- ********************************************************************* @@ -2188,7 +2209,9 @@ occ_anal_lam_tail env expr@(Lam {}) go env rev_bndrs body = addInScope env rev_bndrs $ \env -> let !(WUD usage body') = occ_anal_lam_tail env body - wrap_lam body bndr = Lam (tagLamBinder usage bndr) body + -- See Note [Strictness in the occurrence analyser] + wrap_lam !body !bndr = let !bndr' = tagLamBinder usage bndr + in Lam bndr' body in WUD (usage `addLamCoVarOccs` rev_bndrs) (foldl' wrap_lam body' rev_bndrs) @@ -2541,7 +2564,8 @@ occAnal env (Case scrut bndr ty alts) let alt_env = addBndrSwap scrut' bndr $ setTailCtxt env -- Kill off OccRhs WUD alts_usage alts' = do_alts alt_env alts - tagged_bndr = tagLamBinder alts_usage bndr + !tagged_bndr = tagLamBinder alts_usage bndr + -- See Note [Strictness in the occurrence analyser] in WUD alts_usage (tagged_bndr, alts') total_usage = markAllNonTail scrut_usage `andUDs` alts_usage @@ -2559,11 +2583,13 @@ occAnal env (Case scrut bndr ty alts) do_alt !env (Alt con bndrs rhs) = addInScopeList env bndrs $ \ env -> let WUD rhs_usage rhs' = occAnal env rhs - tagged_bndrs = tagLamBinders rhs_usage bndrs + !tagged_bndrs = tagLamBinders rhs_usage bndrs + -- See Note [Strictness in the occurrence analyser] in -- See Note [Binders in case alternatives] WUD rhs_usage (Alt con tagged_bndrs rhs') occAnal env (Let bind body) + -- TODO: Would be nice to use a strict version of mkLets here = occAnalBind env NotTopLevel noImpRuleEdges bind (\env -> occAnal env body) mkLets @@ -2644,10 +2670,12 @@ occAnalApp !env (Var fun, args, ticks) | fun `hasKey` runRWKey , [t1, t2, arg] <- args , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg - = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] + in WUD usage app_out occAnalApp env (Var fun_id, args, ticks) - = WUD all_uds (mkTicks ticks app') + = let app_out = mkTicks ticks app' + in WUD all_uds app_out where -- Lots of banged bindings: this is a very heavily bit of code, -- so it pays not to make lots of thunks here, all of which @@ -2692,8 +2720,9 @@ occAnalApp env (Var fun_id, args, ticks) -- See Note [Sources of one-shot information], bullet point A'] occAnalApp env (fun, args, ticks) - = WUD (markAllNonTail (fun_uds `andUDs` args_uds)) - (mkTicks ticks app') + = let app_out = mkTicks ticks app' + in WUD (markAllNonTail (fun_uds `andUDs` args_uds)) app_out + where !(WUD args_uds app') = occAnalArgs env fun' args [] !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun @@ -3650,8 +3679,8 @@ data WithTailUsageDetails a = WTUD !TailUsageDetails !a ------------------- -- UsageDetails API -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails +andUDs:: UsageDetails -> UsageDetails -> UsageDetails +orUDs :: UsageDetails -> UsageDetails -> UsageDetails andUDs = combineUsageDetailsWith andLocalOcc orUDs = combineUsageDetailsWith orLocalOcc @@ -3766,10 +3795,13 @@ combineUsageDetailsWith plus_occ_info | isEmptyVarEnv env1 = uds2 | isEmptyVarEnv env2 = uds1 | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 - , ud_z_many = plusVarEnv z_many1 z_many2 + -- See Note [Strictness in the occurrence analyser] + -- Using strictPlusVarEnv here speeds up the test T26425 by about 10% by avoiding + -- intermediate thunks. + = UD { ud_env = strictPlusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = strictPlusVarEnv z_many1 z_many2 , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + , ud_z_tail = strictPlusVarEnv z_tail1 z_tail2 } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) @@ -3847,7 +3879,8 @@ tagLamBinders :: UsageDetails -- Of scope -> [Id] -- Binders -> [IdWithOccInfo] -- Tagged binders tagLamBinders usage binders - = map (tagLamBinder usage) binders + -- See Note [Strictness in the occurrence analyser] + = strictMap (tagLamBinder usage) binders tagLamBinder :: UsageDetails -- Of scope -> Id -- Binder @@ -3856,6 +3889,7 @@ tagLamBinder :: UsageDetails -- Of scope -- No-op on TyVars -- A lambda binder never has an unfolding, so no need to look for that tagLamBinder usage bndr + -- See Note [Strictness in the occurrence analyser] = setBinderOcc (markNonTail occ) bndr -- markNonTail: don't try to make an argument into a join point where ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -51,7 +51,9 @@ module GHC.Types.Unique.FM ( delListFromUFM, delListFromUFM_Directly, plusUFM, + strictPlusUFM, plusUFM_C, + strictPlusUFM_C, plusUFM_CD, plusUFM_CD2, mergeUFM, @@ -261,16 +263,24 @@ delListFromUFM_Directly = foldl' delFromUFM_Directly delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) --- Bindings in right argument shadow those in the left +-- | Bindings in right argument shadow those in the left. +-- +-- Unlike containers this union is right-biased for historic reasons. plusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt --- M.union is left-biased, plusUFM should be right-biased. plusUFM (UFM x) (UFM y) = UFM (M.union y x) -- Note (M.union y x), with arguments flipped -- M.union is left-biased, plusUFM should be right-biased. +-- | Right biased +strictPlusUFM :: UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM (UFM x) (UFM y) = UFM (MS.union y x) + plusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) +strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt +strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y) + -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the -- combinding function and `d1` resp. `d2` as the default value if -- there is no entry in `m1` reps. `m2`. The domain is the union of ===================================== compiler/GHC/Types/Var/Env.hs ===================================== @@ -12,7 +12,8 @@ module GHC.Types.Var.Env ( elemVarEnv, disjointVarEnv, anyVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, - plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + strictPlusVarEnv, plusVarEnv, plusVarEnv_C, strictPlusVarEnv_C, + plusVarEnv_CD, plusMaybeVarEnv_C, plusVarEnvList, alterVarEnv, delVarEnvList, delVarEnv, minusVarEnv, @@ -511,6 +512,7 @@ extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a varEnvDomain :: VarEnv elt -> UnVarSet @@ -522,6 +524,7 @@ delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +strictPlusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b @@ -548,6 +551,7 @@ extendVarEnv_C = addToUFM_C extendVarEnv_Acc = addToUFM_Acc extendVarEnvList = addListToUFM plusVarEnv_C = plusUFM_C +strictPlusVarEnv_C = strictPlusUFM_C plusVarEnv_CD = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList = delListFromUFM @@ -556,6 +560,7 @@ delVarEnvList = delListFromUFM delVarEnv = delFromUFM minusVarEnv = minusUFM plusVarEnv = plusUFM +strictPlusVarEnv = strictPlusUFM plusVarEnvList = plusUFMList -- lookupVarEnv is very hot (in part due to being called by substTyVar), -- if it's not inlined than the mere allocation of the Just constructor causes ===================================== testsuite/tests/perf/compiler/T26425.hs ===================================== @@ -0,0 +1,514 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Reproducer (strToInt) where + +import qualified Data.Text as T + +{- This program results in a nested chain of join points and cases which tests + primarily OccAnal and Unfolding performance. +-} + +strToInt :: T.Text -> Maybe Int +strToInt txt = case txt of + "0" -> Just 0 + "1" -> Just 1 + "2" -> Just 2 + "3" -> Just 3 + "4" -> Just 4 + "5" -> Just 5 + "6" -> Just 6 + "7" -> Just 7 + "8" -> Just 8 + "9" -> Just 9 + "10" -> Just 10 + "11" -> Just 11 + "12" -> Just 12 + "13" -> Just 13 + "14" -> Just 14 + "15" -> Just 15 + "16" -> Just 16 + "17" -> Just 17 + "18" -> Just 18 + "19" -> Just 19 + "20" -> Just 20 + "21" -> Just 21 + "22" -> Just 22 + "23" -> Just 23 + "24" -> Just 24 + "25" -> Just 25 + "26" -> Just 26 + "27" -> Just 27 + "28" -> Just 28 + "29" -> Just 29 + "30" -> Just 30 + "31" -> Just 31 + "32" -> Just 32 + "33" -> Just 33 + "34" -> Just 34 + "35" -> Just 35 + "36" -> Just 36 + "37" -> Just 37 + "38" -> Just 38 + "39" -> Just 39 + "40" -> Just 40 + "41" -> Just 41 + "42" -> Just 42 + "43" -> Just 43 + "44" -> Just 44 + "45" -> Just 45 + "46" -> Just 46 + "47" -> Just 47 + "48" -> Just 48 + "49" -> Just 49 + "50" -> Just 50 + "51" -> Just 51 + "52" -> Just 52 + "53" -> Just 53 + "54" -> Just 54 + "55" -> Just 55 + "56" -> Just 56 + "57" -> Just 57 + "58" -> Just 58 + "59" -> Just 59 + "60" -> Just 60 + "61" -> Just 61 + "62" -> Just 62 + "63" -> Just 63 + "64" -> Just 64 + "65" -> Just 65 + "66" -> Just 66 + "67" -> Just 67 + "68" -> Just 68 + "69" -> Just 69 + "70" -> Just 70 + "71" -> Just 71 + "72" -> Just 72 + "73" -> Just 73 + "74" -> Just 74 + "75" -> Just 75 + "76" -> Just 76 + "77" -> Just 77 + "78" -> Just 78 + "79" -> Just 79 + "80" -> Just 80 + "81" -> Just 81 + "82" -> Just 82 + "83" -> Just 83 + "84" -> Just 84 + "85" -> Just 85 + "86" -> Just 86 + "87" -> Just 87 + "88" -> Just 88 + "89" -> Just 89 + "90" -> Just 90 + "91" -> Just 91 + "92" -> Just 92 + "93" -> Just 93 + "94" -> Just 94 + "95" -> Just 95 + "96" -> Just 96 + "97" -> Just 97 + "98" -> Just 98 + "99" -> Just 99 + "100" -> Just 100 + "101" -> Just 101 + "102" -> Just 102 + "103" -> Just 103 + "104" -> Just 104 + "105" -> Just 105 + "106" -> Just 106 + "107" -> Just 107 + "108" -> Just 108 + "109" -> Just 109 + "110" -> Just 110 + "111" -> Just 111 + "112" -> Just 112 + "113" -> Just 113 + "114" -> Just 114 + "115" -> Just 115 + "116" -> Just 116 + "117" -> Just 117 + "118" -> Just 118 + "119" -> Just 119 + "120" -> Just 120 + "121" -> Just 121 + "122" -> Just 122 + "123" -> Just 123 + "124" -> Just 124 + "125" -> Just 125 + "126" -> Just 126 + "127" -> Just 127 + "128" -> Just 128 + "129" -> Just 129 + "130" -> Just 130 + "131" -> Just 131 + "132" -> Just 132 + "133" -> Just 133 + "134" -> Just 134 + "135" -> Just 135 + "136" -> Just 136 + "137" -> Just 137 + "138" -> Just 138 + "139" -> Just 139 + "140" -> Just 140 + "141" -> Just 141 + "142" -> Just 142 + "143" -> Just 143 + "144" -> Just 144 + "145" -> Just 145 + "146" -> Just 146 + "147" -> Just 147 + "148" -> Just 148 + "149" -> Just 149 + "150" -> Just 150 + "151" -> Just 151 + "152" -> Just 152 + "153" -> Just 153 + "154" -> Just 154 + "155" -> Just 155 + "156" -> Just 156 + "157" -> Just 157 + "158" -> Just 158 + "159" -> Just 159 + "160" -> Just 160 + "161" -> Just 161 + "162" -> Just 162 + "163" -> Just 163 + "164" -> Just 164 + "165" -> Just 165 + "166" -> Just 166 + "167" -> Just 167 + "168" -> Just 168 + "169" -> Just 169 + "170" -> Just 170 + "171" -> Just 171 + "172" -> Just 172 + "173" -> Just 173 + "174" -> Just 174 + "175" -> Just 175 + "176" -> Just 176 + "177" -> Just 177 + "178" -> Just 178 + "179" -> Just 179 + "180" -> Just 180 + "181" -> Just 181 + "182" -> Just 182 + "183" -> Just 183 + "184" -> Just 184 + "185" -> Just 185 + "186" -> Just 186 + "187" -> Just 187 + "188" -> Just 188 + "189" -> Just 189 + "190" -> Just 190 + "191" -> Just 191 + "192" -> Just 192 + "193" -> Just 193 + "194" -> Just 194 + "195" -> Just 195 + "196" -> Just 196 + "197" -> Just 197 + "198" -> Just 198 + "199" -> Just 199 + "200" -> Just 200 + "201" -> Just 201 + "202" -> Just 202 + "203" -> Just 203 + "204" -> Just 204 + "205" -> Just 205 + "206" -> Just 206 + "207" -> Just 207 + "208" -> Just 208 + "209" -> Just 209 + "210" -> Just 210 + "211" -> Just 211 + "212" -> Just 212 + "213" -> Just 213 + "214" -> Just 214 + "215" -> Just 215 + "216" -> Just 216 + "217" -> Just 217 + "218" -> Just 218 + "219" -> Just 219 + "220" -> Just 220 + "221" -> Just 221 + "222" -> Just 222 + "223" -> Just 223 + "224" -> Just 224 + "225" -> Just 225 + "226" -> Just 226 + "227" -> Just 227 + "228" -> Just 228 + "229" -> Just 229 + "230" -> Just 230 + "231" -> Just 231 + "232" -> Just 232 + "233" -> Just 233 + "234" -> Just 234 + "235" -> Just 235 + "236" -> Just 236 + "237" -> Just 237 + "238" -> Just 238 + "239" -> Just 239 + "240" -> Just 240 + "241" -> Just 241 + "242" -> Just 242 + "243" -> Just 243 + "244" -> Just 244 + "245" -> Just 245 + "246" -> Just 246 + "247" -> Just 247 + "248" -> Just 248 + "249" -> Just 249 + "250" -> Just 250 + "251" -> Just 251 + "252" -> Just 252 + "253" -> Just 253 + "254" -> Just 254 + "255" -> Just 255 + "256" -> Just 256 + "257" -> Just 257 + "258" -> Just 258 + "259" -> Just 259 + "260" -> Just 260 + "261" -> Just 261 + "262" -> Just 262 + "263" -> Just 263 + "264" -> Just 264 + "265" -> Just 265 + "266" -> Just 266 + "267" -> Just 267 + "268" -> Just 268 + "269" -> Just 269 + "270" -> Just 270 + "271" -> Just 271 + "272" -> Just 272 + "273" -> Just 273 + "274" -> Just 274 + "275" -> Just 275 + "276" -> Just 276 + "277" -> Just 277 + "278" -> Just 278 + "279" -> Just 279 + "280" -> Just 280 + "281" -> Just 281 + "282" -> Just 282 + "283" -> Just 283 + "284" -> Just 284 + "285" -> Just 285 + "286" -> Just 286 + "287" -> Just 287 + "288" -> Just 288 + "289" -> Just 289 + "290" -> Just 290 + "291" -> Just 291 + "292" -> Just 292 + "293" -> Just 293 + "294" -> Just 294 + "295" -> Just 295 + "296" -> Just 296 + "297" -> Just 297 + "298" -> Just 298 + "299" -> Just 299 + "300" -> Just 300 + "301" -> Just 301 + "302" -> Just 302 + "303" -> Just 303 + "304" -> Just 304 + "305" -> Just 305 + "306" -> Just 306 + "307" -> Just 307 + "308" -> Just 308 + "309" -> Just 309 + "310" -> Just 310 + "311" -> Just 311 + "312" -> Just 312 + "313" -> Just 313 + "314" -> Just 314 + "315" -> Just 315 + "316" -> Just 316 + "317" -> Just 317 + "318" -> Just 318 + "319" -> Just 319 + "320" -> Just 320 + "321" -> Just 321 + "322" -> Just 322 + "323" -> Just 323 + "324" -> Just 324 + "325" -> Just 325 + "326" -> Just 326 + "327" -> Just 327 + "328" -> Just 328 + "329" -> Just 329 + "330" -> Just 330 + "331" -> Just 331 + "332" -> Just 332 + "333" -> Just 333 + "334" -> Just 334 + "335" -> Just 335 + "336" -> Just 336 + "337" -> Just 337 + "338" -> Just 338 + "339" -> Just 339 + "340" -> Just 340 + "341" -> Just 341 + "342" -> Just 342 + "343" -> Just 343 + "344" -> Just 344 + "345" -> Just 345 + "346" -> Just 346 + "347" -> Just 347 + "348" -> Just 348 + "349" -> Just 349 + "350" -> Just 350 + "351" -> Just 351 + "352" -> Just 352 + "353" -> Just 353 + "354" -> Just 354 + "355" -> Just 355 + "356" -> Just 356 + "357" -> Just 357 + "358" -> Just 358 + "359" -> Just 359 + "360" -> Just 360 + "361" -> Just 361 + "362" -> Just 362 + "363" -> Just 363 + "364" -> Just 364 + "365" -> Just 365 + "366" -> Just 366 + "367" -> Just 367 + "368" -> Just 368 + "369" -> Just 369 + "370" -> Just 370 + "371" -> Just 371 + "372" -> Just 372 + "373" -> Just 373 + "374" -> Just 374 + "375" -> Just 375 + "376" -> Just 376 + "377" -> Just 377 + "378" -> Just 378 + "379" -> Just 379 + "380" -> Just 380 + "381" -> Just 381 + "382" -> Just 382 + "383" -> Just 383 + "384" -> Just 384 + "385" -> Just 385 + "386" -> Just 386 + "387" -> Just 387 + "388" -> Just 388 + "389" -> Just 389 + "390" -> Just 390 + "391" -> Just 391 + "392" -> Just 392 + "393" -> Just 393 + "394" -> Just 394 + "395" -> Just 395 + "396" -> Just 396 + "397" -> Just 397 + "398" -> Just 398 + "399" -> Just 399 + "400" -> Just 400 + "401" -> Just 401 + "402" -> Just 402 + "403" -> Just 403 + "404" -> Just 404 + "405" -> Just 405 + "406" -> Just 406 + "407" -> Just 407 + "408" -> Just 408 + "409" -> Just 409 + "410" -> Just 410 + "411" -> Just 411 + "412" -> Just 412 + "413" -> Just 413 + "414" -> Just 414 + "415" -> Just 415 + "416" -> Just 416 + "417" -> Just 417 + "418" -> Just 418 + "419" -> Just 419 + "420" -> Just 420 + "421" -> Just 421 + "422" -> Just 422 + "423" -> Just 423 + "424" -> Just 424 + "425" -> Just 425 + "426" -> Just 426 + "427" -> Just 427 + "428" -> Just 428 + "429" -> Just 429 + "430" -> Just 430 + "431" -> Just 431 + "432" -> Just 432 + "433" -> Just 433 + "434" -> Just 434 + "435" -> Just 435 + "436" -> Just 436 + "437" -> Just 437 + "438" -> Just 438 + "439" -> Just 439 + "440" -> Just 440 + "441" -> Just 441 + "442" -> Just 442 + "443" -> Just 443 + "444" -> Just 444 + "445" -> Just 445 + "446" -> Just 446 + "447" -> Just 447 + "448" -> Just 448 + "449" -> Just 449 + "450" -> Just 450 + "451" -> Just 451 + "452" -> Just 452 + "453" -> Just 453 + "454" -> Just 454 + "455" -> Just 455 + "456" -> Just 456 + "457" -> Just 457 + "458" -> Just 458 + "459" -> Just 459 + "460" -> Just 460 + "461" -> Just 461 + "462" -> Just 462 + "463" -> Just 463 + "464" -> Just 464 + "465" -> Just 465 + "466" -> Just 466 + "467" -> Just 467 + "468" -> Just 468 + "469" -> Just 469 + "470" -> Just 470 + "471" -> Just 471 + "472" -> Just 472 + "473" -> Just 473 + "474" -> Just 474 + "475" -> Just 475 + "476" -> Just 476 + "477" -> Just 477 + "478" -> Just 478 + "479" -> Just 479 + "480" -> Just 480 + "481" -> Just 481 + "482" -> Just 482 + "483" -> Just 483 + "484" -> Just 484 + "485" -> Just 485 + "486" -> Just 486 + "487" -> Just 487 + "488" -> Just 488 + "489" -> Just 489 + "490" -> Just 490 + "491" -> Just 491 + "492" -> Just 492 + "493" -> Just 493 + "494" -> Just 494 + "495" -> Just 495 + "496" -> Just 496 + "497" -> Just 497 + "498" -> Just 498 + "499" -> Just 499 + "500" -> Just 500 + _ -> Nothing ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -806,3 +806,8 @@ test('interpreter_steplocal', ], ghci_script, ['interpreter_steplocal.script']) + +test ('T26425', + [ collect_compiler_stats('all',5) ], + compile, + ['-O']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d69ea8fe2ddb71d9ecae049317d072… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d69ea8fe2ddb71d9ecae049317d072… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/bytecode-lib-shared-object] 3 commits: WIP
by Matthew Pickering (＠mpickering) 30 Oct '25

30 Oct '25

Matthew Pickering pushed to branch wip/bytecode-lib-shared-object at Glasgow Haskell Compiler / GHC Commits: 35968c75 by Matthew Pickering at 2025-10-30T10:11:34+00:00 WIP - - - - - 0655c75c by Matthew Pickering at 2025-10-30T10:47:28+00:00 Comments - - - - - 15c6d35a by Matthew Pickering at 2025-10-30T16:30:49+00:00 WIP - - - - - 9 changed files: - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Unit/State.hs - utils/ghc-pkg/Main.hs Changes: ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -28,7 +28,6 @@ import GHCi.ResolvedBCO import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids -import GHC.Unit.Module.Env import GHC.Unit.Types import GHC.Data.FastString @@ -57,17 +56,16 @@ import GHC.Exts linkBCO :: Interp -> PkgsLoaded - -> LinkerEnv - -> LinkedBreaks + -> BytecodeLoaderState -> NameEnv Int -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp pkgs_loaded le lb bco_ix +linkBCO interp pkgs_loaded bytecode_state 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 lb) (elemsFlatBag lits0) - ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0) + (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded bytecode_state) (elemsFlatBag lits0) + ptrs <- mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0) let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian , resolvedBCOArity = arity @@ -77,17 +75,17 @@ linkBCO interp pkgs_loaded le lb bco_ix , resolvedBCOPtrs = addListToSS emptySS ptrs } -lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word -lookupLiteral interp pkgs_loaded le lb ptr = case ptr of +lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word +lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of BCONPtrWord lit -> return lit BCONPtrLbl sym -> do Ptr a# <- lookupStaticPtr interp sym return (W# (int2Word# (addr2Int# a#))) BCONPtrItbl nm -> do - Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm + Ptr a# <- lookupIE interp pkgs_loaded bytecode_state nm return (W# (int2Word# (addr2Int# a#))) BCONPtrAddr nm -> do - Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm + Ptr a# <- lookupAddr interp pkgs_loaded bytecode_state nm return (W# (int2Word# (addr2Int# a#))) BCONPtrStr bs -> do RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs] @@ -100,7 +98,7 @@ lookupLiteral interp pkgs_loaded le lb ptr = case ptr of pure $ fromIntegral p BCONPtrCostCentre InternalBreakpointId{..} | interpreterProfiled interp -> do - case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of + case expectJust (lookupCCSBytecodeState bytecode_state ibi_info_mod) ! ibi_info_index of RemotePtr p -> pure $ fromIntegral p | otherwise -> case toRemotePtr nullPtr of @@ -114,9 +112,9 @@ lookupStaticPtr interp addr_of_label_string = do Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" (ppr addr_of_label_string) -lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ()) -lookupIE interp pkgs_loaded ie con_nm = - case lookupNameEnv ie con_nm of +lookupIE :: Interp -> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (Ptr ()) +lookupIE interp pkgs_loaded bytecode_state con_nm = + case lookupInfoTableBytecodeState bytecode_state con_nm of Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = IConInfoSymbol con_nm @@ -134,9 +132,9 @@ lookupIE interp pkgs_loaded ie con_nm = ppr sym_to_find2) -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode -lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ()) -lookupAddr interp pkgs_loaded ae addr_nm = do - case lookupNameEnv ae addr_nm of +lookupAddr :: Interp -> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (Ptr ()) +lookupAddr interp pkgs_loaded bytecode_state addr_nm = do + case lookupAddressBytecodeState bytecode_state addr_nm of Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) Nothing -> do -- try looking up in the object files. let sym_to_find = IBytesSymbol addr_nm @@ -158,17 +156,16 @@ lookupPrimOp interp pkgs_loaded primop = do resolvePtr :: Interp -> PkgsLoaded - -> LinkerEnv - -> LinkedBreaks + -> BytecodeLoaderState -> NameEnv Int -> BCOPtr -> IO ResolvedBCOPtr -resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of +resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group - | Just (_, rhv) <- lookupNameEnv (closure_env le) nm + | Just (_, rhv) <- lookupNameBytecodeState bco_loader_state nm -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) | otherwise @@ -184,10 +181,10 @@ resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op BCOPtrBCO bco - -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco + -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded bco_loader_state bco_ix bco BCOPtrBreakArray tick_mod -> - withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $ + withForeignRef (expectJust (lookupBreakArrayBytecodeState bco_loader_state tick_mod)) $ \ba -> pure $ ResolvedBCOPtrBreakArray ba -- | Look up the address of a Haskell symbol in the currently ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -822,7 +822,7 @@ pruneCache hpt summ unload :: Interp -> HscEnv -> IO () unload interp hsc_env = case ghcLink (hsc_dflags hsc_env) of - LinkInMemory -> Linker.unload interp hsc_env [] + LinkInMemory -> Linker.unload interp hsc_env _other -> return () ===================================== compiler/GHC/Driver/Phases.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Driver.Phases ( isHaskellSrcFilename, isHaskellSigFilename, isObjectFilename, + isBytecodeFilename, isCishFilename, isDynLibFilename, isHaskellUserSrcFilename, @@ -235,7 +236,9 @@ phaseInputExt Js = "js" phaseInputExt StopLn = "o" haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes + js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes, + bytecode_suffixes + :: [String] -- When a file with an extension in the haskellish_src_suffixes group is -- loaded in --make mode, its imports will be loaded too. @@ -252,6 +255,7 @@ haskellish_user_src_suffixes = haskellish_boot_suffixes = [ "hs-boot", "lhs-boot" ] haskellish_sig_suffixes = [ "hsig", "lhsig" ] backpackish_suffixes = [ "bkp" ] +bytecode_suffixes = [ "gbc" ] objish_suffixes :: Platform -> [String] -- Use the appropriate suffix for the system on which @@ -267,7 +271,8 @@ dynlib_suffixes platform = case platformOS platform of _ -> ["so"] isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix + isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix, + isBytecodeSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isBackpackishSuffix s = s `elem` backpackish_suffixes @@ -277,6 +282,7 @@ isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes isJsSuffix s = s `elem` js_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes +isBytecodeSuffix s = s `elem` bytecode_suffixes isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool isObjectSuffix platform s = s `elem` objish_suffixes platform @@ -306,7 +312,8 @@ isHaskellishTarget (_,Just phase) = , StopLn] isHaskellishFilename, isHaskellSrcFilename, isCishFilename, - isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename, + isBytecodeFilename :: FilePath -> Bool -- takeExtension return .foo, so we drop 1 to get rid of the . isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) @@ -315,6 +322,7 @@ isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) +isBytecodeFilename f = isBytecodeSuffix (drop 1 $ takeExtension f) isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -27,7 +27,7 @@ module GHC.Linker.Loader -- * LoadedEnv , withExtendedLoadedEnv , extendLoadedEnv - , deleteFromLoadedEnv + , deleteFromLoadedHomeEnv , lookupFromLoadedEnv -- * Internals , allocateBreakArrays @@ -183,19 +183,11 @@ getLoaderState interp = readMVar (loader_state (interpLoader interp)) emptyLoaderState :: LoaderState emptyLoaderState = LoaderState - { linker_env = LinkerEnv - { closure_env = emptyNameEnv - , itbl_env = emptyNameEnv - , addr_env = emptyNameEnv - } + { bco_loader_state = emptyBytecodeLoaderState , 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. @@ -204,18 +196,18 @@ emptyLoaderState = LoaderState -- explicit list. See rts/Linker.c for details. where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) -extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () -extendLoadedEnv interp new_bindings = +extendLoadedEnv :: Interp -> BytecodeLoaderStateModifier -> [(Name,ForeignHValue)] -> IO () +extendLoadedEnv interp modify_bytecode_loader_state new_bindings = modifyLoaderState_ interp $ \pls -> do - return $! modifyClosureEnv pls $ \ce -> - extendClosureEnv ce new_bindings + return $! modifyBytecodeLoaderState modify_bytecode_loader_state pls $ \bco_loader_state -> + modifyClosureEnv bco_loader_state $ \ce -> extendClosureEnv ce new_bindings -- strictness is important for not retaining old copies of the pls -deleteFromLoadedEnv :: Interp -> [Name] -> IO () -deleteFromLoadedEnv interp to_remove = +deleteFromLoadedHomeEnv :: Interp -> [Name] -> IO () +deleteFromLoadedHomeEnv interp to_remove = modifyLoaderState_ interp $ \pls -> do - return $ modifyClosureEnv pls $ \ce -> - delListFromNameEnv ce to_remove + return $ modifyBytecodeLoaderState modifyHomePackageBytecodeState pls $ \bco_state -> + modifyClosureEnv bco_state $ \ce -> delListFromNameEnv ce to_remove -- | Have we already loaded a name into the interpreter? lookupFromLoadedEnv :: Interp -> Name -> IO (Maybe ForeignHValue) @@ -223,7 +215,7 @@ lookupFromLoadedEnv interp name = do mstate <- getLoaderState interp return $ do pls <- mstate - res <- lookupNameEnv (closure_env (linker_env pls)) name + res <- lookupNameBytecodeState (bco_loader_state pls) name return (snd res) -- | Load the module containing the given Name and get its associated 'HValue'. @@ -242,7 +234,7 @@ loadName interp hsc_env name = do then throwGhcExceptionIO (ProgramError "") else return (pls', links, pkgs) - case lookupNameEnv (closure_env (linker_env pls)) name of + case lookupNameBytecodeState (bco_loader_state pls) name of Just (_,aa) -> return (pls,(aa, links, pkgs)) Nothing -> assertPpr (isExternalName name) (ppr name) $ do let sym_to_find = IClosureSymbol name @@ -289,7 +281,7 @@ withExtendedLoadedEnv -> m a -> m a withExtendedLoadedEnv interp new_env action - = MC.bracket (liftIO $ extendLoadedEnv interp new_env) + = MC.bracket (liftIO $ extendLoadedEnv interp modifyHomePackageBytecodeState new_env) (\_ -> reset_old_env) (\_ -> action) where @@ -299,7 +291,7 @@ withExtendedLoadedEnv interp new_env action -- package), so the reset action only removes the names we -- added earlier. reset_old_env = liftIO $ - deleteFromLoadedEnv interp (map fst new_env) + deleteFromLoadedHomeEnv interp (map fst new_env) -- | Display the loader state. @@ -862,7 +854,7 @@ loadObjects interp hsc_env pls objs = do if succeeded ok then return (pls1, Succeeded) else do - pls2 <- unload_wkr interp [] pls1 + pls2 <- unload_wkr interp pls1 return (pls2, Failed) @@ -981,21 +973,33 @@ dynLinkBCOs interp pls keep_spec bcos = cbcs :: [CompiledByteCode] cbcs = concatMap linkableBCOs new_bcos - in dynLinkCompiledByteCode interp pls1 keep_spec cbcs - -dynLinkCompiledByteCode :: Interp -> LoaderState -> KeepModuleLinkableDefinitions -> [CompiledByteCode] -> IO LoaderState -dynLinkCompiledByteCode interp pls keep_spec cbcs = do - let - 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 (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 lb2 cbcs + in do + bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls) (bco_loader_state pls) traverseHomePackageBytecodeState keep_spec cbcs + return $! pls1 { bco_loader_state = bco_state } + +dynLinkCompiledByteCode :: Interp + -> PkgsLoaded + -> BytecodeLoaderState + -> BytecodeLoaderStateTraverser IO -- ^ The traverser tells us to update home package bytecode state or external package bytecode state + -> KeepModuleLinkableDefinitions + -> [CompiledByteCode] + -> IO BytecodeLoaderState +dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecode_state keep_spec cbcs = do + st1 <- traverse_bytecode_state whole_bytecode_state $ \bytecode_state -> do + let + le1 = bco_linker_env bytecode_state + lb1 = bco_linked_breaks bytecode_state + 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 (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 } + return $! bytecode_state { bco_linker_env = le2, bco_linked_breaks = lb2 } + + -- NB: Important to pass the whole bytecode loader state to linkSomeBCOs so that you can find Names in local + -- and external packages. + names_and_refs <- linkSomeBCOs interp pkgs_loaded st1 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (keepDefinitions keep_spec . fst) names_and_refs @@ -1005,14 +1009,11 @@ dynLinkCompiledByteCode interp pls keep_spec cbcs = do -- Wrap finalizers on the ones we want to keep new_binds <- makeForeignNamedHValueRefs interp to_add - - let ce2 = extendClosureEnv (closure_env le2) new_binds - - -- Add SPT entries - mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs) - - return $! pls { linker_env = le2 { closure_env = ce2 } - , linked_breaks = lb2 } + traverse_bytecode_state st1 $ \bytecode_state -> do + let ce2 = extendClosureEnv (closure_env (bco_linker_env bytecode_state)) new_binds + -- Add SPT entries + mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs) + return $! bytecode_state { bco_linker_env = (bco_linker_env bytecode_state) { closure_env = ce2 } } -- | Register SPT entries for this module in the interpreter -- Assumes that the name from the SPT has already been loaded into the interpreter. @@ -1030,15 +1031,14 @@ linkSptEntry interp ce (SptEntry name fpr) = do -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp -> PkgsLoaded - -> LinkerEnv - -> LinkedBreaks + -> BytecodeLoaderState -> [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 lb mods = foldr fun do_link mods [] +linkSomeBCOs interp pkgs_loaded bytecode_state mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = inner (Foldable.toList bc_bcos : accum) @@ -1048,7 +1048,7 @@ linkSomeBCOs interp pkgs_loaded le lb 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 lb bco_ix bco | bco <- flat ] + resolved <- sequence [ linkBCO interp pkgs_loaded bytecode_state bco_ix bco | bco <- flat ] hvrefs <- createBCOs interp resolved return (zip names hvrefs) @@ -1071,66 +1071,39 @@ linkITbls interp = foldlM $ \env (nm, itbl) -> do -- --------------------------------------------------------------------------- -- | Unloading old objects ready for a new compilation sweep. --- --- The compilation manager provides us with a list of linkables that it --- considers \"stable\", i.e. won't be recompiled this time around. For --- each of the modules current linked in memory, --- --- * if the linkable is stable (and it's the same one -- the user may have --- recompiled the module on the side), we keep it, --- --- * otherwise, we unload it. --- +-- * compilation artifacts for home modules that we might be about to recompile +-- are unloaded from the interpreter. -- * we also implicitly unload all temporary bindings at this point. -- unload :: Interp -> HscEnv - -> [Linkable] -- ^ The linkables to *keep*. -> IO () -unload interp hsc_env linkables +unload interp hsc_env = mask_ $ do -- mask, so we're safe from Ctrl-C in here -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env - new_pls - <- modifyLoaderState interp $ \pls -> do - pls1 <- unload_wkr interp linkables pls + _new_pls <- modifyLoaderState interp $ \pls -> do + pls1 <- unload_wkr interp pls return (pls1, pls1) - let logger = hsc_logger hsc_env - debugTraceMsg logger 3 $ - text "unload: retaining objs" <+> ppr (moduleEnvElts $ objs_loaded new_pls) - debugTraceMsg logger 3 $ - text "unload: retaining bcos" <+> ppr (moduleEnvElts $ bcos_loaded new_pls) return () unload_wkr :: Interp - -> [Linkable] -- stable linkables -> LoaderState -> IO LoaderState -- Does the core unload business -- (the wrapper blocks exceptions and deals with the LS get and put) -unload_wkr interp keep_linkables pls@LoaderState{..} = do +unload_wkr interp pls@LoaderState{..} = do -- NB. careful strictness here to avoid keeping the old LS when -- we're unloading some code. -fghci-leak-check with the tests in -- testsuite/ghci can detect space leaks here. - let (objs_to_keep', bcos_to_keep') = partition linkableIsNativeCodeOnly keep_linkables - objs_to_keep = mkLinkableSet objs_to_keep' - bcos_to_keep = mkLinkableSet bcos_to_keep' - - discard keep l = not (linkableInSet l keep) - - (objs_to_unload, remaining_objs_loaded) = - partitionModuleEnv (discard objs_to_keep) objs_loaded - (bcos_to_unload, remaining_bcos_loaded) = - partitionModuleEnv (discard bcos_to_keep) bcos_loaded - - linkables_to_unload = moduleEnvElts objs_to_unload ++ moduleEnvElts bcos_to_unload + let linkables_to_unload = moduleEnvElts objs_loaded ++ moduleEnvElts bcos_loaded mapM_ unloadObjs linkables_to_unload @@ -1139,20 +1112,10 @@ unload_wkr interp keep_linkables pls@LoaderState{..} = do when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $ purgeLookupSymbolCache interp - let -- Note that we want to remove all *local* - -- (i.e. non-isExternal) names too (these are the - -- temporary bindings from the command line). - keep_name :: Name -> Bool - keep_name n = isExternalName n && - nameModule n `elemModuleEnv` remaining_bcos_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 } + let !new_pls = pls { bco_loader_state = modifyHomePackageBytecodeState bco_loader_state $ \_ -> emptyBytecodeState, + -- NB: we don't unload the external package + bcos_loaded = emptyModuleEnv, + objs_loaded = emptyModuleEnv } return new_pls where @@ -1296,6 +1259,8 @@ loadPackage interp hsc_env pkgs pls <- sequenceA [mapM (locateLib interp hsc_env False [] dirs_env_ gcc_paths) extra_libs_ | (dirs_env_, extra_libs_) <- zip dirs_env extra_libs] let classifieds = zipWith (++) hs_classifieds extra_classifieds + maybePutSDoc logger (text "Using these library specs: " $$ (vcat (map ppr classifieds))) + -- Complication: all the .so's must be loaded before any of the .o's. let known_hs_dlls = [[ dll | DLLPath dll <- hs_classifieds_ ] | hs_classifieds_ <- hs_classifieds] known_extra_dlls = [ dll | extra_classifieds_ <- extra_classifieds, DLLPath dll <- extra_classifieds_ ] @@ -1372,15 +1337,19 @@ loadBytecodeLibrary hsc_env interp pls path = do -- 0. Get the modification time of the module _mod_time <- expectJust <$> modificationTimeIfExists path' -- 1. Read the bytecode library - (BytecodeLib _uid cbcs stubs_so) <- decodeOnDiskBytecodeLib hsc_env =<< readBytecodeLib hsc_env path' - pls' <-case stubs_so of + (BytecodeLib uid cbcs stubs_so) <- decodeOnDiskBytecodeLib hsc_env =<< readBytecodeLib hsc_env path' + debugTraceMsg (hsc_logger hsc_env) 3 $ text "loadBytecodeLibrary: " $$ vcat [ text "uid: " <+> ppr uid + , text "cbcs: " <+> ppr (length cbcs) + , text "stubs_so: " <+> ppr stubs_so ] + pls' <- case stubs_so of Nothing -> return pls Just (SharedObject so_file libdir libname) -> do m <- loadDLLs interp [so_file] case m of Right _ -> return $! pls { temp_sos = (libdir, libname) : temp_sos pls } Left err -> linkFail err (text err) - dynLinkCompiledByteCode interp pls' KeepExternalDefinitions cbcs + bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls') (bco_loader_state pls') traverseExternalPackageBytecodeState KeepExternalDefinitions cbcs + return $! pls' { bco_loader_state = bco_state } {- ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -12,14 +12,32 @@ module GHC.Linker.Types ( Loader (..) , LoaderState (..) , uninitializedLoader + + -- * Bytecode Loader State + , BytecodeLoaderState(..) + , BytecodeState(..) + , emptyBytecodeLoaderState + , emptyBytecodeState + , modifyHomePackageBytecodeState + , modifyExternalPackageBytecodeState + , modifyBytecodeLoaderState + , lookupNameBytecodeState + , lookupBreakArrayBytecodeState + , lookupInfoTableBytecodeState + , lookupAddressBytecodeState + , lookupCCSBytecodeState + , BytecodeLoaderStateModifier + , BytecodeLoaderStateTraverser + , traverseHomePackageBytecodeState + , traverseExternalPackageBytecodeState , modifyClosureEnv , LinkerEnv(..) - , filterLinkerEnv + , emptyLinkerEnv , ClosureEnv , emptyClosureEnv , extendClosureEnv , LinkedBreaks(..) - , filterLinkedBreaks + , emptyLinkedBreaks , LinkableSet , mkLinkableSet , unionLinkableSet @@ -62,7 +80,7 @@ import GHCi.RemoteTypes import GHCi.Message ( LoadedDLL ) import GHC.Stack.CCS -import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) +import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, lookupNameEnv ) import GHC.Types.Name ( Name ) import GHC.Types.SptEntry @@ -78,6 +96,8 @@ import GHC.Unit.Module.WholeCoreBindings import Data.Maybe (mapMaybe) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NE +import Control.Applicative ((<|>)) +import Data.Functor.Identity {- ********************************************************************** @@ -149,8 +169,9 @@ and be able to lookup symbols specifically in them too (similarly to newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } data LoaderState = LoaderState - { linker_env :: !LinkerEnv - -- ^ Current global mapping from Names to their true values + { bco_loader_state :: !BytecodeLoaderState + -- ^ Information about bytecode objects we have loaded into the + -- interpreter. , bcos_loaded :: !LinkableSet -- ^ The currently loaded interpreted modules (home package) @@ -165,19 +186,110 @@ 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 +data BytecodeState = BytecodeState + { bco_linker_env :: !LinkerEnv + -- ^ Current global mapping from Names to their true values + , bco_linked_breaks :: !LinkedBreaks -- ^ Mapping from loaded modules to their breakpoint arrays + } + +-- | The 'BytecodeLoaderState' captures all the information about bytecode loaded +-- into the interpreter. +-- It is separated into two parts. One for bytecode objects loaded by the home package and +-- one for bytecode objects loaded from bytecode libraries for external packages. +-- Much like the HPT/EPS split, the home package state can be unloaded by calling 'unload'. +data BytecodeLoaderState = BytecodeLoaderState + { homePackage_loaded :: BytecodeState + -- ^ Information about bytecode objects from the home package we have loaded into the interpreter. + , externalPackage_loaded :: BytecodeState + -- ^ Information about bytecode objects from external packages we have loaded into the interpreter. + } + + +-- | Find a name loaded from bytecode +lookupNameBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ForeignHValue) +lookupNameBytecodeState (BytecodeLoaderState home_package external_package) name = do + lookupNameEnv (closure_env (bco_linker_env home_package)) name + <|> lookupNameEnv (closure_env (bco_linker_env external_package)) name + +-- | Look up a break array in the bytecode loader state. +lookupBreakArrayBytecodeState :: BytecodeLoaderState -> Module -> Maybe (ForeignRef BreakArray) +lookupBreakArrayBytecodeState (BytecodeLoaderState home_package external_package) break_mod = do + lookupModuleEnv (breakarray_env (bco_linked_breaks home_package)) break_mod + <|> lookupModuleEnv (breakarray_env (bco_linked_breaks external_package)) break_mod + +-- | Look up an info table in the bytecode loader state. +lookupInfoTableBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ItblPtr) +lookupInfoTableBytecodeState (BytecodeLoaderState home_package external_package) info_mod = do + lookupNameEnv (itbl_env (bco_linker_env home_package)) info_mod + <|> lookupNameEnv (itbl_env (bco_linker_env external_package)) info_mod + +-- | Look up an address in the bytecode loader state. +lookupAddressBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, AddrPtr) +lookupAddressBytecodeState (BytecodeLoaderState home_package external_package) addr_mod = do + lookupNameEnv (addr_env (bco_linker_env home_package)) addr_mod + <|> lookupNameEnv (addr_env (bco_linker_env external_package)) addr_mod + +-- | Look up a cost centre stack in the bytecode loader state. +lookupCCSBytecodeState :: BytecodeLoaderState -> Module -> Maybe (Array BreakTickIndex (RemotePtr CostCentre)) +lookupCCSBytecodeState (BytecodeLoaderState home_package external_package) ccs_mod = do + lookupModuleEnv (ccs_env (bco_linked_breaks home_package)) ccs_mod + <|> lookupModuleEnv (ccs_env (bco_linked_breaks external_package)) ccs_mod + +emptyBytecodeLoaderState :: BytecodeLoaderState +emptyBytecodeLoaderState = BytecodeLoaderState + { homePackage_loaded = emptyBytecodeState + , externalPackage_loaded = emptyBytecodeState } +emptyBytecodeState :: BytecodeState +emptyBytecodeState = BytecodeState + { bco_linker_env = emptyLinkerEnv + , bco_linked_breaks = emptyLinkedBreaks + } + + +-- Some parts of the compiler can be used to load bytecode into either the home package or +-- external package state. They are parameterised by a 'BytecodeLoaderStateModifier' or +-- 'BytecodeLoaderStateTraverser' so they know which part of the state to update. + +type BytecodeLoaderStateModifier = BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState +type BytecodeLoaderStateTraverser m = BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState + +-- | Only update the home package bytecode state. +modifyHomePackageBytecodeState :: BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState +modifyHomePackageBytecodeState bls f = runIdentity $ traverseHomePackageBytecodeState bls (return . f) + +-- | Only update the external package bytecode state. +modifyExternalPackageBytecodeState :: BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState +modifyExternalPackageBytecodeState bls f = runIdentity $ traverseExternalPackageBytecodeState bls (return . f) + +-- | Effectfully update the home package bytecode state. +traverseHomePackageBytecodeState :: Monad m => BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState +traverseHomePackageBytecodeState bls f = do + home_package <- f (homePackage_loaded bls) + return bls { homePackage_loaded = home_package } + +-- | Effectfully update the external package bytecode state. +traverseExternalPackageBytecodeState :: Monad m => BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState +traverseExternalPackageBytecodeState bls f = do + external_package <- f (externalPackage_loaded bls) + return bls { externalPackage_loaded = external_package } + + +modifyBytecodeLoaderState :: BytecodeLoaderStateModifier -> LoaderState -> (BytecodeState -> BytecodeState) -> LoaderState +modifyBytecodeLoaderState modify_bytecode_loader_state pls f = pls { bco_loader_state = modify_bytecode_loader_state (bco_loader_state pls) f } + uninitializedLoader :: IO Loader uninitializedLoader = Loader <$> newMVar Nothing -modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState +modifyClosureEnv :: BytecodeState -> (ClosureEnv -> ClosureEnv) -> BytecodeState modifyClosureEnv pls f = - let le = linker_env pls + let le = bco_linker_env pls ce = closure_env le - in pls { linker_env = le { closure_env = f ce } } + in pls { bco_linker_env = le { closure_env = f ce } } data LinkerEnv = LinkerEnv { closure_env :: !ClosureEnv @@ -195,11 +307,11 @@ data LinkerEnv = LinkerEnv -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. } -filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv -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 +emptyLinkerEnv :: LinkerEnv +emptyLinkerEnv = LinkerEnv + { closure_env = emptyNameEnv + , itbl_env = emptyNameEnv + , addr_env = emptyNameEnv } type ClosureEnv = NameEnv (Name, ForeignHValue) @@ -228,10 +340,10 @@ data LinkedBreaks -- 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 +emptyLinkedBreaks :: LinkedBreaks +emptyLinkedBreaks = LinkedBreaks + { breakarray_env = emptyModuleEnv + , ccs_env = emptyModuleEnv } type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo ===================================== compiler/GHC/Runtime/Debugger.hs ===================================== @@ -56,6 +56,7 @@ import Data.List ( partition ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.IORef +import GHC.Linker.Types ------------------------------------- -- | The :print & friends commands @@ -161,7 +162,7 @@ bindSuspensions t = do | (name,ty) <- zip names tys] new_ic = extendInteractiveContextWithIds ictxt ids interp = hscInterp hsc_env - liftIO $ extendLoadedEnv interp (zip names fhvs) + liftIO $ extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs) setSession hsc_env {hsc_IC = new_ic } return t' where ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -64,7 +64,7 @@ import GHCi.RemoteTypes import GHC.ByteCode.Types import GHC.Linker.Loader as Loader -import GHC.Linker.Types (LinkedBreaks (..)) +import GHC.Linker.Types import GHC.Hs @@ -310,7 +310,7 @@ handleRunStatus step expr bindings final_ids status history0 = do let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids final_names = map getName final_ids - liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals) + liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} setSession hsc_env' return (ExecComplete (Right final_names) allocs) @@ -433,7 +433,7 @@ resumeExec step mbCnt , not (n `elem` old_names) ] interp = hscInterp hsc_env dflags = hsc_dflags hsc_env - liftIO $ Loader.deleteFromLoadedEnv interp new_names + liftIO $ Loader.deleteFromLoadedHomeEnv interp new_names case r of Resume { resumeStmt = expr @@ -474,18 +474,18 @@ setupBreakpoint interp ibi cnt = do getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray) getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do - breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp + breaks0 <- bco_linked_breaks . homePackage_loaded . bco_loader_state . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of Just ba -> return ba Nothing -> do modifyLoaderState interp $ \ld_st -> do - let lb = linked_breaks ld_st + let lb = bco_linked_breaks . homePackage_loaded . bco_loader_state $ 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 ld_st' = modifyBytecodeLoaderState modifyHomePackageBytecodeState ld_st $ \bco_state -> bco_state { bco_linked_breaks = (bco_linked_breaks bco_state) { breakarray_env = ba_env } } let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod return @@ -575,7 +575,7 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] interp = hscInterp hsc_env -- - Loader.extendLoadedEnv interp [(exn_name, apStack)] + Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(exn_name, apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name]) -- Just case: we stopped at a breakpoint, we have information about the location @@ -634,8 +634,8 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do names = map idName new_ids let fhvs = catMaybes mb_hValues - Loader.extendLoadedEnv interp (zip names fhvs) - when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)] + Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs) + when result_ok $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } return (hsc_env1, if result_ok then result_name:names else names) where ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -851,7 +851,8 @@ distrustAllUnits pkgs = map distrust pkgs mungeUnitInfo :: FilePath -> FilePath -> UnitInfo -> UnitInfo mungeUnitInfo top_dir pkgroot = - mungeDynLibFields + mungeBytecodeLibFields + . mungeDynLibFields . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot) mungeDynLibFields :: UnitInfo -> UnitInfo @@ -862,6 +863,15 @@ mungeDynLibFields pkg = ds -> ds } +-- | Default to using library-dirs if bytecode library dirs is not explicitly set. +mungeBytecodeLibFields :: UnitInfo -> UnitInfo +mungeBytecodeLibFields pkg = + pkg { + unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -2056,7 +2056,8 @@ checkHSLib _verbosity dirs lib = do "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", - lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll" + lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", + lib ++ ".bytecode" ] b <- liftIO $ doesFileExistOnPath filenames dirs when (not b) $ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/25af941ad306f08e115ab5f32f8626… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/25af941ad306f08e115ab5f32f8626… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-spj] 15 commits: Skip uniques test if sources are not available
by Simon Peyton Jones (＠simonpj) 30 Oct '25

30 Oct '25

Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 5dc2e9ea by Julian Ospald at 2025-10-27T18:17:23-04:00 Skip uniques test if sources are not available - - - - - 544b9ec9 by Vladislav Zavialov at 2025-10-27T18:18:06-04:00 Re-export GHC.Hs.Basic from GHC.Hs Clean up some import sections in GHC by re-exporting GHC.Hs.Basic from GHC.Hs. - - - - - 643ce801 by Julian Ospald at 2025-10-28T18:18:55-04:00 rts: remove unneccesary cabal flags We perform those checks via proper autoconf macros instead that do the right thing and then add those libs to the rts buildinfo. - - - - - d69ea8fe by Vladislav Zavialov at 2025-10-28T18:19:37-04:00 Test case for #17705 Starting with GHC 9.12 (the first release to include 5745dbd3), all examples in this ticket are handled as expected. - - - - - dca8a98e by Richard Eisenberg at 2025-10-30T15:37:48+00:00 Refactor fundep solving This commit is a large-scale refactor of the increasingly-messy code that handles functional dependencies. It has virtually no effect on what compiles but improves error messages a bit. And it does the groundwork for #23162. The big picture is described in Note [Overview of functional dependencies in type inference] in GHC.Tc.Solver.FunDeps * New module GHC.Tc.Solver.FunDeps contains all the fundep-handling code for the constraint solver. * Fundep-equalities are solved in a nested scope; they may generate unifications but otherwise have no other effect. See GHC.Tc.Solver.FunDeps.solveFunDeps The nested needs to start from the Givens in the inert set, but not the Wanteds; hence a new function `resetInertCans`, used in `nestFunDepsTcS`. * That in turn means that fundep equalities never show up in error messages, so the complicated FunDepOrigin tracking can all disappear. * We need to be careful about tracking unifications, so we kick out constraints from the inert set after doing unifications. Unification tracking has been majorly reformed: see Note [WhatUnifications] in GHC.Tc.Utils.Unify. A good consequence is that the hard-to-grok `resetUnificationFlag` has been replaced with a simpler use of `reportCoarseGrainUnifications` Smaller things: * Rename `FunDepEqn` to `FunDepEqns` since it contains multiple type equalities. Some compile time improvement Metrics: compile_time/bytes allocated Baseline Test value New value Change ---------------------- -------------------------------------- T5030(normal) 173,839,232 148,115,248 -14.8% GOOD hard_hole_fits(normal) 286,768,048 284,015,416 -1.0% geo. mean -0.2% minimum -14.8% maximum +0.3% Metric Decrease: T5030 - - - - - d6fdfe70 by Simon Peyton Jones at 2025-10-30T15:37:48+00:00 QuickLook's tcInstFun should make instantiation variables directly tcInstFun must make "instantiation variables", not regular unification variables, when instantiating function types. That was previously implemented by a hack: set the /ambient/ level to QLInstTyVar. But the hack finally bit me, when I was refactoring WhatUnifications. And it was always wrong: see the now-expunged (TCAPP2) note. This commit does it right, by making tcInstFun call its own instantiation functions. That entails a small bit of duplication, but the result is much, much cleaner. - - - - - 3221621c by Simon Peyton Jones at 2025-10-30T15:37:48+00:00 Build implication for constraints from (static e) This commit addresses #26466, by buiding an implication for the constraints arising from a (static e) form. The implication has a special ic_info field of StaticFormSkol, which tells the constraint solver to use an empty set of Givens. See (SF3) in Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable This commit also reinstates an `assert` in GHC.Tc.Solver.Equality. The test `StaticPtrTypeFamily` was failing with an assertion failure, but it now works. - - - - - 69c729c3 by Simon Peyton Jones at 2025-10-30T15:37:48+00:00 Comments about defaulting representation equalities - - - - - 2af2d759 by Simon Peyton Jones at 2025-10-30T15:37:48+00:00 Improve tracking of rewriter-sets This refactor substantially improves the treatment of so-called "rewriter-sets" in the constraint solver. The story is described in the rewritten Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint Some highlights * Trace the free coercion holes of a filled CoercionHole, in CoercionPlusHoles. See Note [Coercion holes] (COH5) This avoids taking having to take the free coercion variables of a coercion when zonking a rewrriter-set * Many knock on changes * Make fillCoercionHole take CoercionPlusHoles as its argument rather than to separate arguments. * Similarly setEqIfWanted, setWantedE, wrapUnifierAndEmit. * Be more careful about passing the correct CoHoleSet to `rewriteEqEvidence` and friends * Make kickOurAfterFillingCoercionHole more clever. See new Note [Kick out after filling a coercion hole] Smaller matters * Rename RewriterSet to CoHoleSet * Add special-case helper `rewriteEqEvidenceSwapOnly` - - - - - 67dc6a11 by Simon Peyton Jones at 2025-10-30T15:37:49+00:00 Tidy up constraint solving for foralls * In `can_eq_nc_forall` make sure to track Givens that are used in the nested solve step. * Tiny missing-swap bug-fix in `lookup_eq_in_qcis` * Fix some leftover mess from commit 14123ee646f2b9738a917b7cec30f9d3941c13de Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Wed Aug 20 00:35:48 2025 +0100 Solve forall-constraints via an implication, again Specifically, trySolveImplication is now dead. - - - - - 17246438 by Simon Peyton Jones at 2025-10-30T15:37:49+00:00 Do not treat CoercionHoles as free variables in coercions This fixes a long-standing wart in the free-variable finder; now CoercionHoles are no longer treated as a "free variable" of a coercion. I got big and unexpected performance regressions when making this change. Turned out that CallArity didn't discover that the free variable finder could be eta-expanded, which gave very poor code. So I re-used Note [The one-shot state monad trick] for Endo, resulting in GHC.Utils.EndoOS. Very simple, big win. - - - - - 95f88f99 by Simon Peyton Jones at 2025-10-30T15:37:49+00:00 Update debug-tracing in CallArity No effect on behaviour, and commented out anyway - - - - - 8b4873e8 by Simon Peyton Jones at 2025-10-30T15:37:49+00:00 Comments only -- remove dangling Note references - - - - - 017968d9 by Simon Peyton Jones at 2025-10-30T15:37:49+00:00 Accept error message wibbles - - - - - 040919fe by Simon Peyton Jones at 2025-10-30T15:37:49+00:00 Comments only - - - - - 125 changed files: - compiler/GHC/Core/Opt/CallArity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Utils.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - + compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Irred.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Solver/Solve.hs-boot - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Concrete.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Unique/DSM.hs - + compiler/GHC/Utils/EndoOS.hs - compiler/ghc.cabal.in - m4/fp_check_pthreads.m4 - rts/configure.ac - + rts/rts.buildinfo.in - rts/rts.cabal - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/default/default-fail05.stderr - testsuite/tests/dependent/should_fail/T13135_simple.stderr - testsuite/tests/deriving/should_fail/T3621.stderr - testsuite/tests/indexed-types/should_fail/T14369.stderr - testsuite/tests/indexed-types/should_fail/T1897b.stderr - testsuite/tests/linters/all.T - testsuite/tests/linters/notes.stdout - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr - testsuite/tests/parser/should_fail/T20654a.stderr - testsuite/tests/partial-sigs/should_fail/T14584a.stderr - testsuite/tests/polykinds/T6068.stdout - testsuite/tests/quantified-constraints/T15359.hs - testsuite/tests/rep-poly/RepPolyNPlusK.stderr - testsuite/tests/rep-poly/RepPolyRightSection.stderr - testsuite/tests/rep-poly/T13233.stderr - testsuite/tests/rep-poly/T19709b.stderr - testsuite/tests/rep-poly/T23903.stderr - testsuite/tests/typecheck/no_skolem_info/T13499.stderr - testsuite/tests/typecheck/should_compile/T13651.hs - − testsuite/tests/typecheck/should_compile/T13651.stderr - + testsuite/tests/typecheck/should_compile/T14745.hs - + testsuite/tests/typecheck/should_compile/T17705.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr - testsuite/tests/typecheck/should_compile/tc126.hs - testsuite/tests/typecheck/should_fail/AmbigFDs.hs - − testsuite/tests/typecheck/should_fail/AmbigFDs.stderr - testsuite/tests/typecheck/should_fail/FD3.stderr - testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr - testsuite/tests/typecheck/should_fail/T13506.stderr - testsuite/tests/typecheck/should_fail/T16512a.stderr - testsuite/tests/typecheck/should_fail/T18851b.hs - − testsuite/tests/typecheck/should_fail/T18851b.stderr - testsuite/tests/typecheck/should_fail/T18851c.hs - − testsuite/tests/typecheck/should_fail/T18851c.stderr - testsuite/tests/typecheck/should_fail/T19415.stderr - testsuite/tests/typecheck/should_fail/T19415b.stderr - testsuite/tests/typecheck/should_fail/T22684.stderr - + testsuite/tests/typecheck/should_fail/T23162a.hs - + testsuite/tests/typecheck/should_fail/T23162a.stderr - testsuite/tests/typecheck/should_fail/T25325.stderr - testsuite/tests/typecheck/should_fail/T5246.stderr - testsuite/tests/typecheck/should_fail/T5978.stderr - testsuite/tests/typecheck/should_fail/T7368a.stderr - testsuite/tests/typecheck/should_fail/T7696.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail122.stderr - testsuite/tests/typecheck/should_fail/tcfail143.stderr - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e0a84ca02839f463a9fd7cb0f11da0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e0a84ca02839f463a9fd7cb0f11da0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ghc-sample-profiler] Sample Profiler commit
by Hannes Siebenhandl (＠fendor) 30 Oct '25

30 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/ghc-sample-profiler at Glasgow Haskell Compiler / GHC Commits: fc7c9231 by fendor at 2025-10-30T16:09:58+01:00 Sample Profiler commit - - - - - 7 changed files: - .gitmodules - + eventlog-live-profiling-prototype - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs Changes: ===================================== .gitmodules ===================================== @@ -124,3 +124,6 @@ [submodule "libraries/template-haskell-quasiquoter"] path = libraries/template-haskell-quasiquoter url = https://gitlab.haskell.org/ghc/template-haskell-quasiquoter.git +[submodule "eventlog-live-profiling-prototype"] + path = eventlog-live-profiling-prototype + url = git@gitlab.well-typed.com:well-typed/eventlog-live-profiling-prototype.git ===================================== eventlog-live-profiling-prototype ===================================== @@ -0,0 +1 @@ +Subproject commit db767230707a50f206ec446e63b7de6bca92dcf0 ===================================== ghc/Main.hs ===================================== @@ -80,6 +80,7 @@ import GHC.Iface.Errors.Ppr import GHC.Driver.Session.Mode import GHC.Driver.Session.Lint import GHC.Driver.Session.Units +import GHC.Driver.Monad -- Standard Haskell libraries import System.IO @@ -91,6 +92,17 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Data.List ( isPrefixOf, partition, intercalate ) import Prelude import qualified Data.List.NonEmpty as NE +#if defined(SAMPLE_TRACER) +import qualified Sampler +#endif + +runWithSampleProfiler :: IO () -> IO () +runWithSampleProfiler = +#if defined(SAMPLE_TRACER) + Sampler.withSampleProfiler 10000 {- Every 10 ms -} +#else + id +#endif ----------------------------------------------------------------------------- -- ToDo: @@ -153,7 +165,8 @@ main = do ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode -> - main' postLoadMode units dflags argv3 flagWarnings + reifyGhc $ \session -> runWithSampleProfiler $ + reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn] -> Ghc () ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -27,6 +27,11 @@ Flag threaded Default: True Manual: True +Flag sampleTracer + Description: Whether we instrument the ghc binary with sample tracer when the eventlog is enabled + Default: False + Manual: True + Executable ghc Default-Language: GHC2021 @@ -45,6 +50,10 @@ Executable ghc ghc-boot == @ProjectVersionMunged@, ghc == @ProjectVersionMunged@ + if flag(sampleTracer) + build-depends: ghc-sampler-eventlog + CPP-OPTIONS: -DSAMPLE_TRACER + if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 else ===================================== hadrian/src/Packages.hs ===================================== @@ -13,6 +13,7 @@ module Packages ( transformers, unlit, unix, win32, xhtml, lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, ghcPackages, isGhcPackage, + ghc_sampler_eventlog, -- * Package information crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath, @@ -43,7 +44,8 @@ ghcPackages = , terminfo, text, time, transformers, unlit, unix, win32, xhtml, fileio , timeout , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , ghc_sampler_eventlog + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -135,6 +137,7 @@ unlit = util "unlit" unix = lib "unix" win32 = lib "Win32" xhtml = lib "xhtml" +ghc_sampler_eventlog = lib "ghc-sampler-eventlog" `setPath` "eventlog-live-profiling-prototype/sampler" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -180,6 +180,7 @@ stage1Packages = do , unlit , xhtml , if winTarget then win32 else unix + , ghc_sampler_eventlog ] , when (not cross) [ hpcBin ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -108,6 +108,12 @@ packageArgs = do , builder (Haddock BuildPackage) ? arg ("--optghc=-I" ++ path) ] + , package ghc_sampler_eventlog ? mconcat + [ builder (Cabal Flags) ? mconcat + [ arg "-use-ghc-trace-events" + ] + ] + ---------------------------------- ghc --------------------------------- , package ghc ? mconcat [ builder Ghc ? mconcat @@ -116,6 +122,7 @@ packageArgs = do , builder (Cabal Flags) ? mconcat [ (expr (ghcWithInterpreter stage)) `cabalFlag` "internal-interpreter" + , notStage0 `cabalFlag` "sampleTracer" , ifM stage0 -- We build a threaded stage 1 if the bootstrapping compiler -- supports it. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc7c9231a6beef7b84fd08c5dadb500… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fc7c9231a6beef7b84fd08c5dadb500… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/post-string-len-assertion] Fix assertion in `postStringLen` to account for \0 byte
by Hannes Siebenhandl (＠fendor) 30 Oct '25

30 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/post-string-len-assertion at Glasgow Haskell Compiler / GHC Commits: 35f37d3b by fendor at 2025-10-30T13:16:50+01:00 Fix assertion in `postStringLen` to account for \0 byte We fix the assertion to handle trailing \0 bytes in `postStringLen`. Before this change, the assertion looked like this: ASSERT(eb->begin + eb->size > eb->pos + len + 1); Let's assume some values to see why this is actually off by one: eb->begin = 0 eb->size = 1 eb->pos = 0 len = 1 then the assertion would trigger correctly: 0 + 1 > 0 + 1 + 1 => 1 > 2 => false as there is not enough space for the \0 byte (which is the trailing +1). However, if we change `eb->size = 2`, then we do have enough space for a string of length 1, but the assertion still fails: 0 + 2 > 0 + 1 + 1 => 2 > 2 => false Which causes the assertion to fail if there is exactly enough space for the string with a trailing \0 byte. Clearly, the assertion should be `>=`! If we switch around the operand, it should become more obvious that `<=` is the correct comparison: ASSERT(eb->pos + len + 1 <= eb->begin + eb->size); This is expresses more naturally that the current position plus the length of the string (and the null byte) must be smaller or equal to the overall size of the buffer. This change also is in line with the implementation in `hasRoomForEvent` and `hasRoomForVariableEvent`: ``` StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum) { uint32_t size = ...; if (eb->pos + size > eb->begin + eb->size) ... ``` the check `eb->pos + size > eb->begin + eb->size` is identical to `eb->pos + size <= eb->begin + eb->size` plus a negation. - - - - - 1 changed file: - rts/eventlog/EventLog.c Changes: ===================================== rts/eventlog/EventLog.c ===================================== @@ -197,7 +197,7 @@ static inline void postBuf(EventsBuf *eb, const StgWord8 *buf, uint32_t size) static inline void postStringLen(EventsBuf *eb, const char *buf, StgWord len) { if (buf) { - ASSERT(eb->begin + eb->size > eb->pos + len + 1); + ASSERT(eb->pos + len + 1 <= eb->begin + eb->size); memcpy(eb->pos, buf, len); eb->pos += len; } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35f37d3bb62a675bc6a761fb42a18da… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35f37d3bb62a675bc6a761fb42a18da… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/post-string-len-assertion] Fix assertion in `postStringLen` to account for \0 byte
by Hannes Siebenhandl (＠fendor) 30 Oct '25

30 Oct '25

Hannes Siebenhandl pushed to branch wip/fendor/post-string-len-assertion at Glasgow Haskell Compiler / GHC Commits: 50a62b35 by fendor at 2025-10-30T13:16:32+01:00 Fix assertion in `postStringLen` to account for \0 byte We fix the assertion to handle trailing \0 bytes in `postStringLen`. Before this change, the assertion looked like this: ASSERT(eb->begin + eb->size > eb->pos + len + 1); Let's assume some values to see why this is actually off by one: eb->begin = 0 eb->size = 1 eb->pos = 0 len = 1 then the assertion would trigger correctly: 0 + 1 > 0 + 1 + 1 => 1 > 2 => false as there is not enough space for the \0 byte (which is the trailing +1). However, if we change `eb->size = 2`, then we do have enough space for a string of length 1, but the assertion still fails: 0 + 2 > 0 + 1 + 1 => 2 > 2 => false Which causes the assertion to fail if there is exactly enough space for the string with a trailing \0 byte. Clearly, the assertion should be `>=`! If we switch around the operand, it should become more obvious that `<=` is the correct comparison: ASSERT(eb->pos + len + 1 <= eb->begin + eb->size); This is expresses more naturally that the current position plus the length of the string (and the null byte) must be smaller or equal to the overall size of the buffer. This change also is in line with the implementation in `hasRoomForEvent` and `hasRoomForVariableEvent`: ``` StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum) { uint32_t size = ...; if (eb->pos + size > eb->begin + eb->size) ... ``` the check `eb->pos + size > eb->begin + eb->size` is identical to `eb->pos + size <= eb->begin + eb->size` plus a negation. - - - - - 1 changed file: - rts/eventlog/EventLog.c Changes: ===================================== rts/eventlog/EventLog.c ===================================== @@ -197,7 +197,7 @@ static inline void postBuf(EventsBuf *eb, const StgWord8 *buf, uint32_t size) static inline void postStringLen(EventsBuf *eb, const char *buf, StgWord len) { if (buf) { - ASSERT(eb->begin + eb->size > eb->pos + len + 1); + ASSERT(eb->pos + len + 1 <= eb->begin + eb->size); memcpy(eb->pos, buf, len); eb->pos += len; } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50a62b35af5de5564d60c9b28a1536e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/50a62b35af5de5564d60c9b28a1536e… You're receiving this email because of your account on gitlab.haskell.org.

1 0