- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/26435] 19 commits: Streamline expansions using HsExpansion (#25001)
by Zubin (＠wz1000) 07 Apr '26

07 Apr '26

Zubin pushed to branch wip/26435 at Glasgow Haskell Compiler / GHC Commits: 58009c14 by Apoorv Ingle at 2026-04-02T09:51:24+01:00 Streamline expansions using HsExpansion (#25001) Notes added [Error Context Stack] [Typechecking by expansion: overview] Notes updated Note [Expanding HsDo with XXExprGhcRn] [tcApp: typechecking applications] ------------------------- Metric Decrease: T9020 ------------------------- There are 2 key changes: 1. `HsExpand` datatype mediates between expansions 2. Replace `ErrCtxtM` to a simpler `HsCtxt` that does not depend on a `TidyEnv` This has some consequences detailed below: 1. `HsExpand` datatype mediates between expansions * Simplifies the implementations of `tcExpr` to work on `XExpr` * Removes `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`. * Removes the function `addHeadCtxt` as it is now mearly setting a location * The function `tcValArgs` does its own argument number management * move `splitHsTypes` out of `tcApp` * Removes special case of tcBody from `tcLambdaMatches` * Removes special case of `dsExpr` for `ExpandedThingTc` * Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr` * Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span` * Remove `PopErrCtxt` from `XXExprGhcRn` * `fun_orig` in tcInstFun depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) - it references the application chain head if it is user located, or uses the error context stack as a fallback if it's a generated location * Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes - Expressions wrapped around `GeneratedSrcSpan` are ignored and never added to the error context stack - In Explicit list expansion `fromListN` is wrapped with a `GeneratedSrcSpan` with `GeneratedSrcSpanDetails` field to store the original srcspan 2. Replace `ErrCtxtM` to a simpler `HsCtxt` that does not depend on a `TidyEnv` * Merge `HsThingRn` to `HsCtxt` * Landmark Error messages are now just computed on the fly * Make HsExpandedRn and HsExpandedTc payload a located HsExpr GhcRn * `HsCtxt` are tidied and zonked at the end right before printing Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - bc4b4487 by Zubin Duggal at 2026-04-03T14:22:27-04:00 driver: recognise .dyn_o as a valid object file to link if passed on the command line. This allows plugins compiled with this suffix to run. Fixes #24486 - - - - - 5ebb9121 by Simon Jakobi at 2026-04-03T14:23:11-04:00 Add regression test for #16145 Closes #16145. - - - - - c1fc1c44 by Simon Peyton Jones at 2026-04-03T19:56:07-04:00 Refactor eta-expansion in Prep The Prep pass does eta-expansion but I found cases where it was doing bad things. So I refactored and simplified it quite a bit. In the new design * There is no distinction between `rhs` and `body`; in particular, lambdas can now appear anywhere, rather than just as the RHS of a let-binding. * This change led to a significant simplification of Prep, and a more straightforward explanation of eta-expansion. See the new Note [Eta expansion] * The consequences is that CoreToStg needs to handle naked lambdas. This is very easy; but it does need a unique supply, which forces some simple refactoring. Having a unique supply to hand is probably a good thing anyway. - - - - - 21beda2c by Simon Peyton Jones at 2026-04-03T19:56:07-04:00 Clarify Note [Interesting dictionary arguments] Ticket #26831 ended up concluding that the code for GHC.Core.Opt.Specialise.interestingDict was good, but the commments were a bit inadequate. This commit improves the comments slightly. - - - - - 3eaac1f2 by Simon Peyton Jones at 2026-04-03T19:56:07-04:00 Make inlining a bit more eager for overloaded functions If we have f d = ... (class-op d x y) ... we should be eager to inline `f`, because that may change the higher order call (class-op d x y) into a call to a statically known function. See the discussion on #26831. Even though this does a bit /more/ inlining, compile times decrease by an average of 0.4%. Compile time changes: DsIncompleteRecSel3(normal) 431,786,104 -2.2% ManyAlternatives(normal) 670,883,768 -1.6% ManyConstructors(normal) 3,758,493,832 -2.6% GOOD MultilineStringsPerf(normal) 29,900,576 -2.8% T14052Type(ghci) 1,047,600,848 -1.2% T17836(normal) 392,852,328 -5.2% T18478(normal) 442,785,768 -1.4% T21839c(normal) 341,536,992 -14.1% GOOD T3064(normal) 174,086,152 +5.3% BAD T5631(normal) 506,867,800 +1.0% hard_hole_fits(normal) 209,530,736 -1.3% info_table_map_perf(normal) 19,523,093,184 -1.2% parsing001(normal) 377,810,528 -1.1% pmcOrPats(normal) 60,075,264 -0.5% geo. mean -0.4% minimum -14.1% maximum +5.3% Runtime changes haddock.Cabal(normal) 27,351,988,792 -0.7% haddock.base(normal) 26,997,212,560 -0.6% haddock.compiler(normal) 219,531,332,960 -1.0% Metric Decrease: LinkableUsage01 ManyConstructors T17949 T21839c T13035 TcPlugin_RewritePerf hard_hole_fits Metric Increase: T3064 - - - - - 5cbc2c82 by Matthew Pickering at 2026-04-03T19:57:02-04:00 bytecode: Add magic header/version to bytecode files In order to avoid confusing errors when using stale interface files (ie from an older compiler version), we add a simple header/version check like the one for interface files. Fixes #27068 - - - - - d95a1936 by fendor at 2026-04-03T19:57:02-04:00 Add constants for bytecode in-memory buffer size Introduce a common constant for the default size of the .gbc and .bytecodelib binary buffer. The buffer is by default set to 1 MB. - - - - - b822c30a by mangoiv at 2026-04-03T19:57:49-04:00 testsuite: filter stderr for static001 on darwin This reactivates the test on x86_64 darwin as this should have been done long ago and ignores warnings emitted by ranlib on newer version of the darwin toolchain since they are benign. (no symbols for stub libraries) Fixes #27116 - - - - - 28ce1f8a by Andreas Klebinger at 2026-04-03T19:58:44-04:00 Give the Data instance for ModuleName a non-bottom toConstr implementation. I've also taken the liberty to add Note [Data.Data instances for GHC AST Types] describing some of the uses of Data.Data I could find. Fixes #27129 - - - - - 8ca41ffe by mangoiv at 2026-04-03T19:59:30-04:00 issue template: fix add bug label - - - - - 3981db0c by Sylvain Henry at 2026-04-03T20:00:33-04:00 Add more canned GC functions for common register patterns (#27142) Based on analysis of heap-check sites across the GHC compiler and Cabal, the following patterns were not covered by existing canned GC functions but occurred frequently enough to warrant specialisation: stg_gc_ppppp -- 5 GC pointers stg_gc_ip -- unboxed word + GC pointer stg_gc_pi -- GC pointer + unboxed word stg_gc_ii -- two unboxed words stg_gc_bpp -- byte (I8) + two GC pointers Adding these reduces the fraction of heap-check sites falling back to the generic GC path from ~1.4% to ~0.4% when compiling GHC itself. Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - d17d1435 by Matthew Pickering at 2026-04-03T20:01:19-04:00 Make home unit dependencies stored as sets Co-authored-by: Wolfgang Jeltsch <wolfgang(a)well-typed.com> - - - - - 92a97015 by Simon Peyton Jones at 2026-04-05T00:58:57+01:00 Add Invariant (NoTypeShadowing) to Core This commit addresses #26868, by adding a new invariant (NoTypeShadowing) to Core. See Note [No type-shadowing in Core] in GHC.Core - - - - - 8b5a5020 by Simon Peyton Jones at 2026-04-05T00:58:57+01:00 Major refactor of free-variable functions For some time we have had two free-variable mechanims for types: * The "FV" mechanism, embodied in GHC.Utils.FV, which worked OK, but was fragile where eta-expansion was concerned. * The TyCoFolder mechanism, using a one-shot EndoOS accumulator I finally got tired of this and refactored the whole thing, thereby addressing #27080. Now we have * `GHC.Types.Var.FV`, which has a composable free-variable result type, very much in the spirit of the old `FV`, but much more robust. (It uses the "one shot trick".) * GHC.Core.TyCo.FVs now has just one technology for free variables. All this led to a lot of renaming. There are couple of error-message changes. The change in T18451 makes an already-poor error message even more mysterious. But it really needs a separate look. We also now traverse the AST in a different order leading to a different but still deterministic order for FVs and test output has been adjusted accordingly. - - - - - 4bf040c6 by sheaf at 2026-04-05T14:56:29-04:00 Add utility pprTrace_ function This function is useful for quick debugging, as it can be added to a where clause to pretty-print debugging information: fooBar x y | cond = body1 | otherwise = body2 where !_ = pprTrace_ "fooBar" $ vcat [ text "x:" <+> ppr x , text "y:" <+> ppr y , text "cond:" <+> ppr cond ] - - - - - 502e6ffe by Andrew Lelechenko at 2026-04-07T04:47:21-04:00 base: improve error message for Data.Char.chr As per https://github.com/haskell/core-libraries-committee/issues/384 - - - - - b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00 Refactor FunResCtxt a bit Fixes #27154 - - - - - 7fe84ea5 by Zubin Duggal at 2026-04-07T19:11:52+05:30 compiler: Warn when -finfo-table-map is used with -fllvm These are currently not supported together. Fixes #26435 - - - - - 239 changed files: - .gitlab/issue_templates/default.md - compiler/GHC.hs - compiler/GHC/Builtin/PrimOps.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Tidy.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Unfold.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Expr.hs-boot - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Lit.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Splice.hs-boot - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/StgToCmm/Heap.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.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/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - + compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Instance/FunDeps.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - 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/TcType.hs-boot - 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/Types/Error.hs - + compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Name/Set.hs - compiler/GHC/Types/SrcLoc.hs - + compiler/GHC/Types/Var/FV.hs - compiler/GHC/Types/Var/Set.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/State.hs - + compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/EndoOS.hs - − compiler/GHC/Utils/FV.hs - compiler/GHC/Utils/Logger.hs - compiler/GHC/Utils/Trace.hs - compiler/Language/Haskell/Syntax/Module/Name.hs - compiler/ghc.cabal.in - docs/users_guide/debug-info.rst - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - libraries/base/changelog.md - libraries/base/tests/enum01.stdout - libraries/base/tests/enum01.stdout-alpha-dec-osf3 - libraries/base/tests/enum01.stdout-ws-64 - libraries/ghc-internal/src/GHC/Internal/Char.hs - rts/HeapStackCheck.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h - testsuite/driver/testlib.py - testsuite/tests/arityanal/should_compile/Arity01.stderr - testsuite/tests/arityanal/should_compile/Arity05.stderr - testsuite/tests/arityanal/should_compile/Arity08.stderr - testsuite/tests/arityanal/should_compile/Arity11.stderr - testsuite/tests/arityanal/should_compile/Arity14.stderr - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/cpranal/should_compile/T18401.stderr - testsuite/tests/deriving/should_fail/deriving-via-fail4.stderr - + testsuite/tests/driver/T26435.ghc.stderr - + testsuite/tests/driver/T26435.hs - + testsuite/tests/driver/T26435.stdout - testsuite/tests/driver/all.T - testsuite/tests/driver/bytecode-object/Makefile - testsuite/tests/driver/bytecode-object/all.T - testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/monadfail/MonadFailErrors.stderr - testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr - testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr - testsuite/tests/partial-sigs/should_compile/T10403.stderr - testsuite/tests/partial-sigs/should_compile/T12844.stderr - testsuite/tests/partial-sigs/should_compile/T15039a.stderr - testsuite/tests/partial-sigs/should_compile/T15039b.stderr - testsuite/tests/partial-sigs/should_compile/T15039c.stderr - testsuite/tests/partial-sigs/should_compile/T15039d.stderr - testsuite/tests/partial-sigs/should_fail/T10999.stderr - testsuite/tests/partial-sigs/should_fail/T12634.stderr - testsuite/tests/plugins/Makefile - + testsuite/tests/plugins/T24486-plugin/Makefile - + testsuite/tests/plugins/T24486-plugin/Setup.hs - + testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal - + testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs - + testsuite/tests/plugins/T24486.hs - + testsuite/tests/plugins/T24486_Helper.hs - testsuite/tests/plugins/all.T - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/polykinds/T15789.stderr - testsuite/tests/polykinds/T18451.stderr - testsuite/tests/polykinds/T7328.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - testsuite/tests/runghc/Makefile - + testsuite/tests/runghc/T16145.hs - + testsuite/tests/runghc/T16145.stdout - + testsuite/tests/runghc/T16145_aux.hs - testsuite/tests/runghc/all.T - testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr - testsuite/tests/simplCore/should_compile/T15205.stderr - testsuite/tests/simplCore/should_compile/T24229a.stderr - testsuite/tests/simplCore/should_compile/T24229b.stderr - testsuite/tests/simplCore/should_compile/T24359a.stderr - testsuite/tests/simplCore/should_compile/T26116.stderr - testsuite/tests/simplCore/should_compile/T4908.stderr - testsuite/tests/simplCore/should_compile/spec-inline.stderr - testsuite/tests/typecheck/no_skolem_info/T20063.stderr - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/T25180.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/free_monad_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T12589.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T17773.stderr - testsuite/tests/typecheck/should_fail/T2846b.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail140.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr - testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92024d717f1af51503c38eee85eb75… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/92024d717f1af51503c38eee85eb75… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding] Introduce `ModuleNameProvidersMap` use for home units
by Wolfgang Jeltsch (＠jeltsch) 07 Apr '26

07 Apr '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC Commits: 3cf48831 by Matthew Pickering at 2026-04-07T16:23:25+03:00 Introduce `ModuleNameProvidersMap` use for home units This contribution introduces a home modules cache to the module graph and changes the finder to use that cache to cut down home unit search work. The particular changes are as follows: * In `GHC.Unit.Module.Graph`, `ModuleGraph` is extended with a new field `mg_home_map`, exposed as `mgHomeModuleMap`. This is a data structure that caches the following: - The set of home units for which the graph has a complete module listing - For each module name, the set of home unit IDs that define it Operations that construct module graphs are updated such that this cache stays synchronized. * In `GHC.Unit.Finder`, `findImportedModule` is changed to pull `mgHomeModuleMap` from `hsc_mod_graph` and pass it to `findImportedModuleNoHsc`, which first consults the cache to find the home unit of the respective module and only falls back to the usual search when that home unit could not be found via the cache. The practical effect is that for unqualified and `this-package` imports, the finder avoids blindly searching every home unit dependency when the current module graph already states which units may provide that module. This is a performance optimization, especially for multi-home-unit builds. Resolves #27055. Co-authored-by: Wolfgang Jeltsch <wolfgang(a)well-typed.com> - - - - - 2 changed files: - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Module/Graph.hs Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -44,6 +44,7 @@ import GHC.Data.OsPath import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module +import GHC.Unit.Module.Graph (ModuleNameHomeMap (..), mgHomeModuleMap) import GHC.Unit.Home import GHC.Unit.Home.Graph (UnitEnvGraph) import qualified GHC.Unit.Home.Graph as HUG @@ -72,7 +73,7 @@ import GHC.Driver.Config.Finder import GHC.Types.Unique.Set import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) -import qualified Data.Set as Set (toList) +import qualified Data.Set as Set import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE @@ -182,7 +183,8 @@ findImportedModule hsc_env mod pkg_qual = dflags = hsc_dflags hsc_env fopts = initFinderOpts dflags in do - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual + let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env) + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_map mhome_unit mod pkg_qual findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do @@ -195,22 +197,27 @@ findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv + -> ModuleNameHomeMap -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import - | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) + | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os) | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where + ModuleNameHomeMap complete_units module_name_map = home_module_map + module_home_units = M.findWithDefault Set.empty mod_name module_name_map + current_unit_id = homeUnitId <$> mhome_unit all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + Nothing -> other_fopts_list + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list + other_fopts_map = M.fromList other_fopts_list home_import = case mhome_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name @@ -221,7 +228,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue home_module_map (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual | elementOfUniqSet mod_name (finder_hiddenModules opts) = return (mkHomeHidden uid) | otherwise = @@ -230,7 +237,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import:| map home_pkg_import other_fopts) + any_home_import = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts_list) pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg @@ -241,9 +248,21 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = units = case mhome_unit of Nothing -> ue_homeUnitState ue Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue - hpt_deps :: [UnitId] - hpt_deps = Set.toList (homeUnitDepends units) - other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + hpt_deps :: Set.Set UnitId + hpt_deps = homeUnitDepends units + dep_providers = Set.intersection module_home_units hpt_deps + known_other_uids = + let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id + in Set.toList providers + unknown_units = + let candidates = Set.difference hpt_deps complete_units + excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id + in Set.toList (Set.difference candidates excluded) + other_home_uids = known_other_uids ++ unknown_units + other_fopts_list = + [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) + | uid <- other_home_uids + ] -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -67,6 +67,8 @@ module GHC.Unit.Module.Graph , mgLookupModule , mgLookupModuleName , mgHasHoles + , ModuleNameHomeMap (ModuleNameHomeMap) + , mgHomeModuleMap , showModMsg -- ** Reachability queries @@ -156,10 +158,11 @@ import GHC.Unit.Module.ModIface import GHC.Utils.Misc ( partitionWith ) import System.FilePath +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) import qualified Data.Map as Map import GHC.Types.Unique.DSet -import qualified Data.Set as Set -import Data.Set (Set) import GHC.Unit.Module import GHC.Unit.Module.ModNodeKey import GHC.Unit.Module.Stage @@ -202,14 +205,47 @@ data ModuleGraph = ModuleGraph -- Cached computation, whether any of the ModuleGraphNode are isHoleModule, -- This is only used for a hack in GHC.Iface.Load to do with backpack, please -- remove this at the earliest opportunity. + , mg_home_map :: ModuleNameHomeMap + -- ^ For each module name, which home unit UnitIds define it together with the set of units for which the listing is complete. } +data ModuleNameHomeMap = ModuleNameHomeMap !(Set UnitId) + !(Map ModuleName (Set UnitId)) + +mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap +mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where + + providerMap :: Map ModuleName (Set UnitId) + providerMap + = Map.fromListWith Set.union $ + [ + (ms_mod_name modSummary, Set.singleton (ms_unitid modSummary)) | + ModuleNode _ (ModuleNodeCompile modSummary) <- nodes + ] + + completeUnits :: Set UnitId + completeUnits + = Set.fromList $ + [ + ms_unitid modSummary | + ModuleNode _ (ModuleNodeCompile modSummary) <- nodes + ] + + {-NOTE: + The matching with `ModuleNodeCompile` results in nodes with + `ModuleNodeFixed` in their info being dropped. + -} + +mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap +mgHomeModuleMap = mg_home_map + -- | Why do we ever need to construct empty graphs? Is it because of one shot mode? emptyMG :: ModuleGraph emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) False + (ModuleNameHomeMap Set.empty Map.empty) -- | Construct a module graph. This function should be the only entry point for -- building a 'ModuleGraph', since it is supposed to be built once and never modified. @@ -308,7 +344,7 @@ checkModuleGraph ModuleGraph{..} = where duplicate_errs = rights (Map.elems node_types) - node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + node_types :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ] where -- Multiple nodes with the same key are not allowed. @@ -319,7 +355,7 @@ checkModuleGraph ModuleGraph{..} = -- | Check that all dependencies in the graph are present in the node_types map. -- This is a helper function used by checkModuleGraph. -checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) +checkAllDependenciesInGraph :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) -> ModuleGraphNode -> Maybe ModuleGraphInvariantError checkAllDependenciesInGraph node_types node = @@ -334,7 +370,7 @@ checkAllDependenciesInGraph node_types node = -- | Check if for the fixed module node invariant: -- -- Fixed nodes can only depend on other fixed nodes. -checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) +checkFixedModuleInvariant :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) -> ModuleGraphNode -> Maybe ModuleGraphInvariantError checkFixedModuleInvariant node_types node = case node of @@ -484,13 +520,17 @@ isEmptyMG = null . mg_mss -- To preserve invariants, 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg - { mg_mss = flip fmap mg_mss $ \case - InstantiationNode uid iuid -> InstantiationNode uid iuid - LinkNode uid nks -> LinkNode uid nks - ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc) - ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms)) - UnitNode deps uid -> UnitNode deps uid + { mg_mss = new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = + flip fmap mg_mss $ \case + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc) + ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms)) + UnitNode deps uid -> UnitNode deps uid -- | Map a function 'f' over all the 'ModSummaries', in 'IO'. -- To preserve invariants, 'f' can't change the isBoot status. @@ -856,7 +896,7 @@ moduleNodeInfoBootString mn@(ModuleNodeFixed {}) = -- described in the export list haddocks. -------------------------------------------------------------------------------- -newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a } +newtype NodeMap a = NodeMap { unNodeMap :: Map NodeKey a } deriving (Functor, Traversable, Foldable) -- | Transitive dependencies, including SOURCE edges @@ -932,7 +972,7 @@ moduleGraphNodesZero summaries = lookup_key :: ZeroScopeKey -> Maybe Int lookup_key = fmap zeroSummaryNodeKey . lookup_node - node_map :: Map.Map ZeroScopeKey ZeroSummaryNode + node_map :: Map ZeroScopeKey ZeroSummaryNode node_map = Map.fromList [ (s, node) | node <- nodes @@ -1031,7 +1071,7 @@ moduleGraphNodesStages summaries = lookup_key :: (NodeKey, ModuleStage) -> Maybe Int lookup_key = fmap stageSummaryNodeKey . lookup_node - node_map :: Map.Map (NodeKey, ModuleStage) StageSummaryNode + node_map :: Map (NodeKey, ModuleStage) StageSummaryNode node_map = Map.fromList [ (s, node) | node <- nodes @@ -1049,10 +1089,13 @@ moduleGraphNodesStages summaries = extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph extendMG ModuleGraph{..} node = ModuleGraph - { mg_mss = node : mg_mss - , mg_graph = mkTransDeps (node : mg_mss) - , mg_loop_graph = mkTransLoopDeps (node : mg_mss) - , mg_zero_graph = mkTransZeroDeps (node : mg_mss) + { mg_mss = new_mss + , mg_graph = mkTransDeps new_mss + , mg_loop_graph = mkTransLoopDeps new_mss + , mg_zero_graph = mkTransZeroDeps new_mss , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node) + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = node : mg_mss View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3cf48831971cde68e432829a1666fa8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3cf48831971cde68e432829a1666fa8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/jeltsch/more-efficient-home-unit-imports-finding
by Wolfgang Jeltsch (＠jeltsch) 07 Apr '26

07 Apr '26

Wolfgang Jeltsch pushed new branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/more-efficient-home-u… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/reentrant-tys] Working prototype
by Andreas Klebinger (＠AndreasK) 07 Apr '26

07 Apr '26

Andreas Klebinger pushed to branch wip/andreask/reentrant-tys at Glasgow Haskell Compiler / GHC Commits: 89da6c0f by Andreas Klebinger at 2026-04-07T12:29:28+00:00 Working prototype - - - - - 10 changed files: - compiler/GHC/Core/TyCon.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/Make.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - + testsuite/tests/perf/should_run/T27114.hs - + testsuite/tests/perf/should_run/T27114.stdout - testsuite/tests/perf/should_run/all.T Changes: ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -830,7 +830,7 @@ The tyConUpdatable flag is controlled by the {-# RECOMPUTING T #-} pragma. defaultTyConFlags :: TyConFlags -defaultTyConFlags = TyConFlags { tyConUpdatable = False } +defaultTyConFlags = TyConFlags { tyConUpdatable = True } instance Binary TyConFlags where put_ bh (TyConFlags updatable) = put_ bh updatable ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Types.Id.Make ( coercionTokenId ) import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.CostCentre +import GHC.Types.Demand ( isAtMostOnceDmd ) import GHC.Types.Tickish import GHC.Types.Var.Env import GHC.Types.Name ( isExternalName ) @@ -354,7 +355,7 @@ coreToTopStgRhs opts this_mod ccs (bndr, rhs) ; let (stg_rhs, ccs') = mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts)) (coreToStg_AutoSccsOnIndividualCafs opts) - this_mod ccs bndr new_rhs + this_mod ccs (mkStgUpdateFlag bndr new_rhs) bndr new_rhs stg_arity = stgRhsArity stg_rhs @@ -704,7 +705,7 @@ coreToStgRhs :: (Id,CoreExpr) coreToStgRhs (bndr, rhs) = do new_rhs <- coreToMkStgRhs bndr rhs - return (mkStgRhs bndr new_rhs) + return (mkStgRhs (mkStgUpdateFlag bndr new_rhs) new_rhs) -- Convert the RHS of a binding from Core to STG. This is a wrapper around -- coreToStgExpr that can handle value lambdas. @@ -722,6 +723,24 @@ coreToMkStgRhs bndr expr = do } pure mk_rhs +mkStgUpdateFlag :: Id -> MkStgRhs -> UpdateFlag +mkStgUpdateFlag bndr (MkStgRhs bndrs _rhs typ is_join) + | is_join = JumpedTo + | not (null bndrs) = ReEntrant + | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry + | non_updatable_tycon = ReEntrant + | otherwise = Updatable + where + non_updatable_tycon + | isDataConId bndr = False + | otherwise = + case splitTyConApp_maybe typ of + Just (tycon, _) -> + if not (tyConUpdatable (tyConFlags tycon)) + then pprTrace "nonUpdatableTyCon:" (ppr tycon) True + else False + Nothing -> False + -- --------------------------------------------------------------------------- -- A monad for the core-to-STG pass -- --------------------------------------------------------------------------- ===================================== compiler/GHC/Stg/Make.hs ===================================== @@ -19,8 +19,8 @@ import GHC.Stg.Utils (stripStgTicksTop) import GHC.Types.Id import GHC.Types.Name import GHC.Types.CostCentre -import GHC.Types.Demand ( isAtMostOnceDmd ) import GHC.Types.Tickish +import GHC.Types.Demand (isAtMostOnceDmd) -- Represents the RHS of a binding for use with mk(Top)StgRhs and -- mk(Top)StgRhsCon_maybe. @@ -36,8 +36,8 @@ data MkStgRhs = MkStgRhs -- appended to `CollectedCCs` argument. mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool) -> Bool -> Module -> CollectedCCs - -> Id -> MkStgRhs -> (StgRhs, CollectedCCs) -mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _) + -> UpdateFlag -> Id -> MkStgRhs -> (StgRhs, CollectedCCs) +mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs upd_flag_core bndr mk_rhs@(MkStgRhs bndrs rhs typ _) -- try to make a StgRhsCon first | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs = ( rhs_con, ccs ) @@ -46,7 +46,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd = -- The list of arguments is non-empty, so not CAF ( StgRhsClosure noExtFieldSilent dontCareCCS - ReEntrant + upd_flag bndrs rhs typ , ccs ) @@ -65,7 +65,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd where upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable + | otherwise = upd_flag_core -- CAF cost centres generated for -fcaf-all caf_cc = mkAutoCC bndr modl @@ -81,8 +81,8 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialization plan]. -mkStgRhs :: Id -> MkStgRhs -> StgRhs -mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join) +mkStgRhs :: UpdateFlag -> MkStgRhs -> StgRhs +mkStgRhs upd_flag mk_rhs@(MkStgRhs bndrs rhs typ _is_join) -- try to make a StgRhsCon first | Just rhs_con <- mkStgRhsCon_maybe mk_rhs = rhs_con @@ -91,11 +91,6 @@ mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join) = StgRhsClosure noExtFieldSilent currentCCS upd_flag bndrs rhs typ - where - upd_flag | is_join = JumpedTo - | not (null bndrs) = ReEntrant - | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable {- SDM: disabled. Eval/Apply can't handle functions with arity zero very ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -785,15 +785,18 @@ tcRnHsBootDecls boot_or_sig decls = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations - ; (tcg_env, HsGroup { hs_tyclds = tycl_decls - , hs_derivds = deriv_decls - , hs_fords = for_decls - , hs_defds = def_decls - , hs_ruleds = rule_decls - , hs_annds = _ - , hs_valds = XValBindsLR (HsVBG val_binds val_sigs) }) + ; (tcg_env0, HsGroup { hs_tyclds = tycl_decls + , hs_derivds = deriv_decls + , hs_fords = for_decls + , hs_defds = def_decls + , hs_ruleds = rule_decls + , hs_annds = _ + , hs_recomputing_tyds = recomputing_tycons + , hs_valds = XValBindsLR (HsVBG val_binds val_sigs) }) <- rnTopSrcDecls first_group + ; let tcg_env = extendRecomputingTyCons recomputing_tycons tcg_env0 + ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { -- NB: setGblEnv **before** captureTopConstraints so that -- if the latter reports errors, it knows what's in scope @@ -1699,6 +1702,13 @@ rnTopSrcDecls group return (tcg_env', rn_decls) } +extendRecomputingTyCons :: [LIdP GhcRn] -> TcGblEnv -> TcGblEnv +extendRecomputingTyCons tycons tcg_env + = tcg_env + { tcg_recomputing_tycons = + tcg_recomputing_tycons tcg_env `unionNameSet` + mkNameSet (map unLoc tycons) } + tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -1706,9 +1716,12 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_defds = default_decls, hs_annds = annotation_decls, hs_ruleds = rule_decls, + hs_recomputing_tyds = recomputing_tycons, hs_valds = hs_val_binds@(XValBindsLR (HsVBG val_binds val_sigs)) }) - = do { -- Type-check the type and class decls, and all imported decls + = do { tcg_env <- getGblEnv + ; setGblEnv (extendRecomputingTyCons recomputing_tycons tcg_env) $ do { + -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc "Tc2 (src)" empty ; @@ -1785,7 +1798,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; return (tcg_env', tcl_env) - }}}}} + }}}}}} tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -3595,6 +3595,13 @@ tcDataDefn err_ctxt roles_info tc_name ; res_kind <- zonkTcTypeToTypeX res_kind ; return (kind, bndrs, stupid_theta, res_kind) } + ; tcg_env <- getGblEnv + ; let tycon_flags + | tc_name `elemNameSet` tcg_recomputing_tycons tcg_env + = defaultTyConFlags { tyConUpdatable = False } + | otherwise + = defaultTyConFlags + ; tycon <- fixM $ \ rec_tycon -> do { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons @@ -3603,7 +3610,7 @@ tcDataDefn err_ctxt roles_info tc_name bndrs nb_eta res_kind (roles_info tc_name) - defaultTyConFlags + tycon_flags (fmap (typeCheckCType . unLoc) cType) stupid_theta tc_rhs (VanillaAlgTyCon tc_rep_nm) ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -644,6 +644,7 @@ data TcGblEnv tcg_rules :: [LRuleDecl GhcTc], -- ...Rules tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports tcg_patsyns :: [PatSyn], -- ...Pattern synonyms + tcg_recomputing_tycons :: NameSet, -- ...TyCons marked by RECOMPUTING pragmas tcg_hdr_info :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)), -- ^ Maybe Haddock header docs and Maybe located module name ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -384,6 +384,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_rules = [] , tcg_fords = [] , tcg_patsyns = [] + , tcg_recomputing_tycons = emptyNameSet , tcg_merged = [] , tcg_dfun_n = dfun_n_var , tcg_zany_n = zany_n_var ===================================== testsuite/tests/perf/should_run/T27114.hs ===================================== @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC + +-dsuppress-uniques + + #-} +module Main where + +import System.Environment + +foo :: Foldable t => t a -> Int +foo = undefined + +{-# RECOMPUTING Nats #-} +data Nats = Nats Int Nats + +{-# NOINLINE loop #-} +loop :: Int -> Nats -> (Int -> IO ()) -> IO () +loop 0 _ _ = return () +loop n (Nats i is) k = k i >> loop (n - 1) is k + +main :: IO () +main = do + args <- getArgs + let count = case args of + (a:args) -> read $ filter (/= '_') a + _ -> 10_000_000 + + let nats n = Nats n (nats (n + 1)) + let ele_action x = if (x `mod` (count `div` 10)) == 0 then print x else seq x (pure ()) + loop count (nats 0) ele_action + -- With saring for @Nats@ disabled we will not retain the fully materialized nats data structure. + -- Instead the second loop will recompute it. + loop count (nats 0) ele_action + ===================================== testsuite/tests/perf/should_run/T27114.stdout ===================================== @@ -0,0 +1,20 @@ +0 +1000000 +2000000 +3000000 +4000000 +5000000 +6000000 +7000000 +8000000 +9000000 +0 +1000000 +2000000 +3000000 +4000000 +5000000 +6000000 +7000000 +8000000 +9000000 ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -441,3 +441,10 @@ test('SpecTyFamRun', [ grep_errmsg(r'foo') , collect_stats('bytes allocated', 5)], multimod_compile_and_run, ['SpecTyFamRun', '-O2']) + +test('T27114', + [collect_runtime_residency(50), + only_ways(['normal']) + ], + compile_and_run, + ['-O']) \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89da6c0f793d9d6ecc286fab30543b5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89da6c0f793d9d6ecc286fab30543b5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 10 commits: base: improve error message for Data.Char.chr
by Marge Bot (＠marge-bot) 07 Apr '26

07 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 502e6ffe by Andrew Lelechenko at 2026-04-07T04:47:21-04:00 base: improve error message for Data.Char.chr As per https://github.com/haskell/core-libraries-committee/issues/384 - - - - - b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00 Refactor FunResCtxt a bit Fixes #27154 - - - - - 45fde18c by Matthew Pickering at 2026-04-07T07:55:50-04:00 packaging: correctly propagate build/host/target to bindist configure script At the moment the host and target which we will produce a compiler for is fixed at the initial configure time. Therefore we need to persist the choice made at this time into the installation bindist as well so we look for the right tools, with the right prefixes at install time. In the future, we want to provide a bit more control about what kind of bindist we produce so the logic about what the host/target will have to be written by hadrian rather than persisted by the configure script. In particular with cross compilers we want to either build a normal stage 2 cross bindist or a stage 3 bindist, which creates a bindist which has a native compiler for the target platform. Fixes #21970 Co-authored-by: Sven Tennie <sven.tennie(a)gmail.com> - - - - - dffb4e08 by Sven Tennie at 2026-04-07T07:55:51-04:00 Cross --host and --target no longer required for cross (#21970) We set sane defaults in the configure script. Thus, these paramenters aren't required any longer. - - - - - 1773374b by Sven Tennie at 2026-04-07T07:55:51-04:00 ci: Define USER_CONF_CC_OPTS_STAGE2 for aarch64/mingw ghc-toolchain doesn't see $CONF_CC_OPTS_STAGE2 when the bindist gets configured. So, the hack to override the compiler gets lost. - - - - - a61597c6 by Duncan Coutts at 2026-04-07T07:55:52-04:00 Add a rts posix FdWakup utility module This will be used to implement wakeupIOManager for in-RTS I/O managers. It provides a notification/wakeup mechanism using FDs, suitable for situations when a thread is blocked on a set of fds anyway. It uses the classic self-pipe trick, or equivalently eventfd on supported platforms. This will initially be used to implement prompt interrupt or shutdown of the posix ticker thread. - - - - - 69ee18dc by Duncan Coutts at 2026-04-07T07:55:52-04:00 Add prompt shutdown to the pthread ticker implementation. The Linux timerfd ticker monitors a pipe which is used by exitTicker to ensure a prompt wakeup and shutdown. The pthread ticker lacked this and so would only exit at the next ticker wakeup (10ms by default). This patch adds the same mechanism to the pthread ticker. This changes the pthread ticker from waiting by using nanosleep() to waiting using either ppoll() or select(), so that it can wait on both a time and a file descriptor. On Linux at least, a test program to compare the timing jitter of these APIs shows that using nanpsleep, ppoll or select makes no statistical difference to the maximum or average jitter. This is a step towards unifying the posix ticker implementations, so that we can have just one portable one (albeit with some limited cpp). It is also a step towards using the ticker as part of a more general implementation of wakeUpRts, since this will require a method to wake the rts from a signal handler context (ctl-c handler). - - - - - e43f2f0c by Duncan Coutts at 2026-04-07T07:55:53-04:00 Update ticker header commentary It was antique and didn't apply even to the previous implementation, and certainly not to the updated one. - - - - - 0769a25d by Duncan Coutts at 2026-04-07T07:55:53-04:00 Remove the timerfd-based ticker implementation There does not appear to be any remaining advantage on Linux to using the timerfd ticker implementation over the portable one (using ppoll on Linux for precise timing). The eventfd implementation was originally added at a time when Linux was still using a signal based implementation. So it made sense at the time. See (closed) issue #10840. - - - - - 7df6bd16 by Duncan Coutts at 2026-04-07T07:55:53-04:00 Consolidate to a single posix ticker implementation Previously we had four implementations, two using signals and two using threads. Having just one should make behaviour more consistent between platforms, and should make maintenance easier. - - - - - 27 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Zonk/TcType.hs - configure.ac - distrib/configure.ac.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Default.hs - libraries/base/changelog.md - libraries/base/tests/enum01.stdout - libraries/base/tests/enum01.stdout-alpha-dec-osf3 - libraries/base/tests/enum01.stdout-ws-64 - libraries/ghc-internal/src/GHC/Internal/Char.hs - m4/fptools_set_platform_vars.m4 - m4/ghc_toolchain.m4 - + rts/posix/FdWakeup.c - + rts/posix/FdWakeup.h - rts/posix/Ticker.c - − rts/posix/ticker/Pthread.c - − rts/posix/ticker/TimerFd.c - rts/rts.cabal Changes: ===================================== .gitlab/ci.sh ===================================== @@ -628,20 +628,6 @@ function install_bindist() { *) read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}" - if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then - # We suppose that host target = build target. - # By the fact above it is clearly turning out which host value is - # for currently built compiler. - # The fix for #21970 will probably remove this if-branch. - local -r CROSS_HOST_GUESS=$($SHELL ./config.guess) - args+=( "--target=$CROSS_TARGET" "--host=$CROSS_HOST_GUESS" ) - - # FIXME: The bindist configure script shouldn't need to be reminded of - # the target platform. See #21970. - elif [ -n "${CROSS_TARGET:-}" ]; then - args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" ) - fi - run ${CONFIGURE_WRAPPER:-} ./configure \ --prefix="$instdir" \ "${args[@]+"${args[@]}"}" || fail "bindist configure failed" ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -1316,6 +1316,13 @@ cross_jobs = [ -- unexpected triple. . setVariable "CFLAGS" cflags . setVariable "CONF_CC_OPTS_STAGE2" cflags + -- For bindists `$USER_CONF_CC_OPTS_STAGE2` is not automatically set + -- to `$CONF_CC_OPTS_STAGE2`. But, we still have to deal with the hack + -- mentioned in the previous comment. + -- + -- TODO: It would be nice to get rid of this hack. This would probably + -- involve setting the toolchain up in a different way. + . setVariable "USER_CONF_CC_OPTS_STAGE2" cflags ) where llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-" cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt" ===================================== .gitlab/jobs.yaml ===================================== @@ -331,6 +331,7 @@ "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres" } }, @@ -412,6 +413,7 @@ "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres" } }, @@ -1123,6 +1125,7 @@ "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres", "XZ_OPT": "-9" } @@ -1205,6 +1208,7 @@ "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres", "XZ_OPT": "-9" } ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7710,12 +7710,8 @@ pprHsCtxt = \case PatSigErrCtxt sig_ty res_ty -> vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ] - where - -- Zonking will have turned Infer into Check - pp_res_ty = case res_ty of - Check ty -> ppr ty - Infer ir -> text "OOPS" <+> ppr ir + , nest 2 (hang (text "fits the type of its context:") + 2 (ppr (getCheckExpType res_ty))) ] PatCtxt pat -> hang (text "In the pattern:") 2 (ppr pat) @@ -7777,7 +7773,7 @@ pprHsCtxt = \case full_herald = pprExpectedFunTyHerald herald <+> speakNOf n_vis_args_in_call (text "visible argument") -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic - FunResCtxt fun n_val_args res_fun res_env n_fun n_env + FunResCtxt fun n_val_args fun_res_ty env_ty | -- Check for too few args -- fun_tau = a -> b, res_tau = Int n_fun > n_env @@ -7801,6 +7797,18 @@ pprHsCtxt = \case -> empty -- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env] where + -- See Note [Splitting nested sigma types in mismatched + -- function types] + -- env_ty is an ExpRhoTy, but with simple subsumption it + -- is not /deeply/ skolemised, so still use tcSplitNestedSigmaTys + + (_,_,fun_tau) = tcSplitNestedSigmaTys fun_res_ty + (_, _, env_tau) = tcSplitNestedSigmaTys (getCheckExpType env_ty) + (args_fun, res_fun) = tcSplitFunTys fun_tau + (args_env, res_env) = tcSplitFunTys env_tau + n_fun = length args_fun + n_env = length args_env + not_fun ty -- ty is definitely not an arrow type, -- and cannot conceivably become one = case tcSplitTyConApp_maybe ty of ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Builtin.Names import GHC.Driver.DynFlags import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic import GHC.Data.Maybe @@ -961,7 +960,8 @@ See Note [-fno-code mode]. * * ********************************************************************* -} -addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] +addFunResCtxt :: HasDebugCallStack + => HsExpr GhcTc -> [HsExprArg p] -> TcType -> ExpRhoType -> TcM a -> TcM a -- When we have a mis-match in the return type of a function @@ -969,33 +969,10 @@ addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] -- But not in generated code, where we don't want -- to mention internal (rebindable syntax) function names addFunResCtxt fun args fun_res_ty env_ty thing_inside - = do { env_tv <- newFlexiTyVarTy liftedTypeKind - ; dumping <- doptM Opt_D_dump_tc_trace - ; msg <- mk_msg dumping env_tv - ; addErrCtxt msg thing_inside } + = addErrCtxt (FunResCtxt fun (count isValArg args) fun_res_ty env_ty) $ + thing_inside -- NB: use a landmark error context, so that an empty context -- doesn't suppress some more useful context - where - mk_msg dumping env_tv - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; env' <- case mb_env_ty of - Just env_ty -> return env_ty - Nothing -> do { massert dumping; return env_tv } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res_ty - (_, _, env_tau) = tcSplitNestedSigmaTys env' - -- env_ty is an ExpRhoTy, but with simple subsumption it - -- is not deeply skolemised, so still use tcSplitNestedSigmaTys - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - info = - FunResCtxt fun (count isValArg args) res_fun res_env - (length args_fun) (length args_env) - ; return info } - {- Note [Splitting nested sigma types in mismatched function types] ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -251,7 +251,10 @@ data HsCtxt -- | In the instance type signature of a class method. | MethSigCtxt !Name !TcType !TcType -- | In a pattern type signature. + | PatSigErrCtxt !TcType !ExpType + -- ExpType: see Note [ExpType in HsCtxt] + -- | In a pattern. | PatCtxt !(Pat GhcRn) -- | In a pattern synonym declaration. @@ -268,7 +271,10 @@ data HsCtxt -- | In a function call. | FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int -- | In the result of a function call. - | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int + + | FunResCtxt !(HsExpr GhcTc) !Int !TcType !ExpType + -- ExpType: see Note [ExpType in HsCtxt] + -- | In the declaration of a type constructor. | TyConDeclCtxt !Name !(TyConFlavour TyCon) -- | In a type or data family instance (or default instance). @@ -377,3 +383,14 @@ isHsCtxtLandmark (DerivBindCtxt{}) = True isHsCtxtLandmark (FunResCtxt{}) = True isHsCtxtLandmark (VDQWarningCtxt{}) = True isHsCtxtLandmark _ = False + +{- Note [ExpType in HsCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A couple of HsCtxt constructors have ExpTypes in them. When zonking the +Infer{} case we read the hole, which should be filled in by now, and zonk +that type. Now we want to put it back: we use (Check ty') for this, so that +clients of a zonked HsCtxt don't need to be monadic. + +Result: after zonking, these ExpTypes are always (Check ty). It woudl be nice +to guarantee this statically, but it's hard to do so. +-} ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Tc.Utils.TcType ( ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..), ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR, ExpRhoType, ExpRhoTypeFRR, - mkCheckExpType, + mkCheckExpType, getCheckExpType, checkingExpType_maybe, checkingExpType, ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType, @@ -440,11 +440,12 @@ data InferInstFlag -- Specifies whether the inference should return an uninstan | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top) -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole - -- Typically used when inferring the type of an expression + -- Used only for view patterns; see Note [View patterns and polymorphism] | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption) -- If DeepSubsumption is off, same as IIF_ShallowRho -- If DeepSubsumption is on, instantiate deeply before filling the hole + -- Typically used when inferring the type of an expression type ExpSigmaType = ExpType type ExpRhoType = ExpType @@ -490,6 +491,12 @@ instance Outputable InferResult where mkCheckExpType :: TcType -> ExpType mkCheckExpType = Check +getCheckExpType :: HasDebugCallStack => ExpType -> TcType +-- Expect a (Check ty). +-- See Note [ExpType in HsCtxt] in GHC.Tc.Types.ErrCtxt +getCheckExpType (Check ty) = ty +getCheckExpType (Infer ir) = pprPanic "getCheckExpType" (ppr ir) + -- | Returns the expected type when in checking mode. checkingExpType_maybe :: ExpType -> Maybe TcType checkingExpType_maybe (Check ty) = Just ty ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -818,19 +818,26 @@ zonkTidyHsCtxt env e@(FunAppCtxt{}) = return (env, e) zonkTidyHsCtxt env (FunTysCtxt ctxt ty i1 i2) = do (env', ty') <- zonkTidyTcType env ty return $ (env', FunTysCtxt ctxt ty' i1 i2) -zonkTidyHsCtxt env (FunResCtxt e i1 ty1 ty2 i2 i3) = do - (env', ty1') <- zonkTidyTcType env ty1 - (env', ty2') <- zonkTidyTcType env' ty2 - return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3) +zonkTidyHsCtxt env (FunResCtxt e n ty1 env_ty) = do + (env', ty1') <- zonkTidyTcType env ty1 + (env', env_ty') <- zonkExpType env' env_ty + return $ (env', FunResCtxt e n ty1' env_ty') zonkTidyHsCtxt env (PatSigErrCtxt sig_ty res_ty) = do (env', sig_ty') <- zonkTidyTcType env sig_ty - (env', res_ty') <- - case res_ty of - Check ty -> zonkTidyTcType env' ty - Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops - mb_ty <- liftIO $ readIORef ref - case mb_ty of - Nothing -> error "zonkTidyHsCtxt PatSigErrCtxt" - Just ty -> zonkTidyTcType env' ty - return (env', PatSigErrCtxt sig_ty' (Check res_ty')) + (env', res_ty') <- zonkExpType env' res_ty + return (env', PatSigErrCtxt sig_ty' res_ty') zonkTidyHsCtxt env p = return (env, p) + +zonkExpType :: TidyEnv -> ExpType -> ZonkM (TidyEnv, ExpType) +-- Zonk Infer{} to Check. The hole should have been filled in by now +zonkExpType env (Check ty) + = do { (env', ty') <- zonkTidyTcType env ty + ; return (env', Check ty') } +zonkExpType env (Infer ir@(IR { ir_ref = ref })) + = do { -- inlining readExpTyp_maybe to avoid module dep loops + ; mb_ty <- liftIO $ readIORef ref + ; case mb_ty of + Nothing -> pprPanic "zonkTidyHsCtxt PatSigErrCtxt" (ppr ir) + Just ty -> do { (env', ty') <- zonkTidyTcType env ty + ; return (env', Check ty') } } + ===================================== configure.ac ===================================== @@ -255,6 +255,7 @@ if test "${WithGhc}" != "" then bootstrap_host=`"${WithGhc}" --info | grep '^ ,("Host platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'` bootstrap_target=`"${WithGhc}" --info | grep '^ ,("Target platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'` + bootstrap_build="$bootstrap_host" if test "$bootstrap_host" != "$bootstrap_target" then echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work" @@ -394,8 +395,33 @@ then else TargetPlatformFull="${target_alias}" fi + +if test -z "${build_alias}" +then + # --target wasn't given; use result from AC_CANONICAL_TARGET + BuildPlatformFull="${build}" +else + BuildPlatformFull="${build_alias}" +fi +if test -z "${host_alias}" +then + # --target wasn't given; use result from AC_CANONICAL_TARGET + HostPlatformFull="${host}" +else + HostPlatformFull="${host_alias}" +fi +if test "$CrossCompiling" = "YES" +then + # Use value passed by user from --target= + CrossCompilePrefix="${TargetPlatformFull}-" +else + CrossCompilePrefix="" +fi + AC_SUBST(CrossCompiling) AC_SUBST(TargetPlatformFull) +AC_SUBST(BuildPlatformFull) +AC_SUBST(HostPlatformFull) dnl ** Which gcc to use? dnl -------------------------------------------------------------- ===================================== distrib/configure.ac.in ===================================== @@ -15,7 +15,18 @@ dnl-------------------------------------------------------------------- dnl * Deal with arguments telling us gmp is somewhere odd dnl-------------------------------------------------------------------- +build_alias=@BuildPlatformFull@ +host_alias=@HostPlatformFull@ +target_alias=@TargetPlatformFull@ + +dnl this makes sure `./configure --target=<cross-compile-target>` +dnl works as expected, since we're slightly modifying how Autoconf +dnl interprets build/host/target and how this interacts with $CC tests +test -n "$target_alias" && ac_tool_prefix=$target_alias- + dnl Various things from the source distribution configure +bootstrap_build=@BuildPlatform@ +bootstrap_host=@HostPlatform@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -50,6 +50,9 @@ use-ghc-toolchain = @EnableGhcToolchain@ # And we can reconstruct the platform info using targetPlatformTriple # Q: What is TargetPlatformFull? target-platform-full = @TargetPlatformFull@ +build-platform-full = @BuildPlatformFull@ +host-platform-full = @HostPlatformFull@ + cross-compiling = @CrossCompiling@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -69,6 +69,8 @@ data Setting = CursesIncludeDir | ProjectPatchLevel2 | SystemGhc | TargetPlatformFull + | BuildPlatformFull + | HostPlatformFull | BourneShell | EmsdkVersion @@ -107,6 +109,8 @@ setting key = lookupSystemConfig $ case key of ProjectPatchLevel2 -> "project-patch-level2" SystemGhc -> "system-ghc" TargetPlatformFull -> "target-platform-full" + BuildPlatformFull -> "build-platform-full" + HostPlatformFull -> "host-platform-full" BourneShell -> "bourne-shell" EmsdkVersion -> "emsdk-version" ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -424,6 +424,8 @@ bindistRules = do , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ yesNo <$> getTarget tgtHasLibm , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple + , interpolateVar "BuildPlatform" $ interp $ queryBuild targetPlatformTriple + , interpolateVar "HostPlatform" $ interp $ queryHost targetPlatformTriple , interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian , interpolateVar "TargetWordSize" $ getTarget wordSize , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised @@ -431,6 +433,9 @@ bindistRules = do , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP , interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base + , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull) + , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull) + , interpolateVar "HostPlatformFull" (setting HostPlatformFull) ] where interp = interpretInContext (semiEmptyTarget Stage2) ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -122,7 +122,11 @@ stage0Packages = do -- for upper stages. As we only use stage0 to build upper stages, -- this should be fine. ++ [ terminfo | not windowsHost, not cross ] - ++ [ timeout | windowsHost ] + ++ [ timeout | windowsHost ] + -- Due to some weird logic, we need ghcToolchainBin in Stage0 and + -- Stage1 packages if we're cross compiling. "Stage2 cross-compilers" + -- will solve this. + ++ [ ghcToolchainBin | cross ] -- | Packages built in 'Stage1' by default. You can change this in "UserSettings". stage1Packages :: Action [Package] @@ -181,12 +185,12 @@ stage1Packages = do , transformers , unlit , xhtml + , ghcToolchainBin , if winTarget then win32 else unix ] , when (not cross) [ hpcBin , runGhc - , ghcToolchainBin ] , when (winTarget && not cross) [ -- See Note [Hadrian's ghci-wrapper package] ===================================== libraries/base/changelog.md ===================================== @@ -28,6 +28,7 @@ * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) + * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/tests/enum01.stdout ===================================== @@ -81,7 +81,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-2147483648)" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-2147483648)" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/base/tests/enum01.stdout-alpha-dec-osf3 ===================================== @@ -65,7 +65,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111:" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/base/tests/enum01.stdout-ws-64 ===================================== @@ -81,7 +81,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-9223372036854775808)" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-9223372036854775808)" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/ghc-internal/src/GHC/Internal/Char.hs ===================================== @@ -12,7 +12,7 @@ module GHC.Internal.Char import GHC.Internal.Classes (eqChar, neChar) import GHC.Internal.Base (otherwise, (++)) -import GHC.Internal.Err (errorWithoutStackTrace) +import GHC.Internal.Err (error) import GHC.Internal.Show import GHC.Internal.Prim (chr#, int2Word#, leWord#, Int#, Char#) import GHC.Internal.Types (Char(..), Int(..), isTrue#) @@ -29,4 +29,7 @@ safe_chr# i# {-# NOINLINE chr_error #-} chr_error :: Int# -> Char# -chr_error i# = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) (I# i#) "") +chr_error i# = error ("Data.Char.chr: argument outside Unicode range: 0..1114111: " ++ showSignedInt (I# 9#) (I# i#) "") +-- It's not really "Data.Char", but we assume that +-- the majority of users will import it from "base:Data.Char" +-- and not from "ghc-internal:GHC.Internal.Char". ===================================== m4/fptools_set_platform_vars.m4 ===================================== @@ -77,9 +77,9 @@ dnl fi # compiler's target platform. AC_DEFUN([FPTOOLS_OVERRIDE_PLATFORM_FROM_BOOTSTRAP], [ - if test "$bootstrap_target" != "" + if test "$bootstrap_$1" != "" then - $1=$bootstrap_target + $1=$bootstrap_$1 echo "$1 platform inferred as: [$]$1" else echo "Can't work out $1 platform" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -136,8 +136,10 @@ dnl and that we must compile ghc-toolchain before invoking it AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[ case "$1" in YES) - # We're configuring the bindist, and the binary is already available - GHC_TOOLCHAIN_BIN="bin/ghc-toolchain-bin" + # We're configuring the bindist, and the binary is already available. + # For cross-compilation bindists, Hadrian names the binary with the + # cross-compile prefix (e.g. riscv64-linux-gnu-ghc-toolchain-bin). + GHC_TOOLCHAIN_BIN="bin/${CrossCompilePrefix}ghc-toolchain-bin" ;; NO) # We're in the source tree, so compile ghc-toolchain ===================================== rts/posix/FdWakeup.c ===================================== @@ -0,0 +1,141 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2025 + * + * Utilities for a simple fd-based cross-thread wakeup mechanism. + * + * This is used to provide a mechanism to wake a thread when it is blocked + * waiting on fds and timeouts. The mechanism works by including the read end + * fd into the set of fds the thread waits on, and when a wake up is needed, + * the write end fd is used. + * + * This is implemented using either eventfd() or pipe(). + * + * Linux 2.6.22+ and FreeBSD 13+ support eventfd. It is a single fd with a + * 64bit counter. It uses fewer resources than a pipe (less memory and one + * rather than two fds), and is a tad faster (on the order of 5-10%). Using + * write() adds to the counter, while read() reads and resets it. Thus + * multiple writes are combined automatically into a single corresponding + * read. + * + * Otherwise we use a classic unix pipe. + * + * In both implementations, multiple sendFdWakeup notifcations (without + * interleaved collectFdWakeup) are combined to a single notification. This + * is automatic given the semantics of eventfd, while for pipe we implement + * it explicitly by draining the pipe in collectFdWakeup. + * + * -------------------------------------------------------------------------*/ + +#include "rts/PosixSource.h" +#include "Rts.h" + +#include "FdWakeup.h" + +#include <fcntl.h> +#include <unistd.h> + +#ifdef HAVE_SYS_EVENTFD_H +#include <sys/eventfd.h> +#endif + +#if !defined(HAVE_EVENTFD) \ + || (defined(HAVE_EVENTFD) && !(defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK))) +static void fcntl_CLOEXEC_NONBLOCK(int fd) +{ + int res1 = fcntl(fd, F_SETFD, FD_CLOEXEC); + int res2 = fcntl(fd, F_SETFL, O_NONBLOCK); + if (RTS_UNLIKELY(res1 < 0 || res2 < 0)) { + sysErrorBelch("newFdWakeup fcntl()"); + stg_exit(EXIT_FAILURE); + } +} +#endif + +void newFdWakeup(int *wakeup_fd_r, int *wakeup_fd_w) +{ +#if defined(HAVE_EVENTFD) + int wakeup_fd; +#if defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK) + wakeup_fd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK); +#else + wakeup_fd = eventfd(0, 0); + if (wakeup_fd >= 0) fcntl_CLOEXEC_NONBLOCK(wakeup_fd); +#endif + if (RTS_UNLIKELY(wakeup_fd < 0)) { + sysErrorBelch("newFdWakeup eventfd()"); + stg_exit(EXIT_FAILURE); + } + /* eventfd uses the same fd for each end */ + *wakeup_fd_r = wakeup_fd; + *wakeup_fd_w = wakeup_fd; +#else + int pipefd[2]; + int res; + res = pipe(pipefd); + if (RTS_UNLIKELY(res < 0)) { + sysErrorBelch("newFdWakeup pipe"); + stg_exit(EXIT_FAILURE); + } + fcntl_CLOEXEC_NONBLOCK(pipefd[0]); + fcntl_CLOEXEC_NONBLOCK(pipefd[1]); + *wakeup_fd_r = pipefd[0]; /* read end */ + *wakeup_fd_w = pipefd[1]; /* write end */ +#endif +} + +void closeFdWakeup(int wakeup_fd_r, int wakeup_fd_w) +{ +#if defined(HAVE_EVENTFD) + ASSERT(wakeup_fd_r == wakeup_fd_w); + close(wakeup_fd_r); +#else + ASSERT(wakeup_fd_r != wakeup_fd_w); + close(wakeup_fd_r); + close(wakeup_fd_w); +#endif +} + +/* This is safe to use from a signal handler. Using write() to a pipe + * or eventfd is fine. */ +void sendFdWakeup(int wakeup_fd_w) +{ + int res; +#if defined(HAVE_EVENTFD) + uint64_t val = 1; + res = write(wakeup_fd_w, &val, 8); +#else + unsigned char buf = 1; + res = write(wakeup_fd_w, &buf, 1); +#endif + if (RTS_UNLIKELY(res < 0)) { + /* Unlikely the pipe buffer will fill, but it would not be an error. */ + if (errno == EAGAIN) return; + sysErrorBelch("sendFdWakeup write"); + stg_exit(EXIT_FAILURE); + } +} + +void collectFdWakeup(int wakeup_fd_r) +{ + int res; +#if defined(HAVE_EVENTFD) + uint64_t buf; + /* eventfd combines events into one counter, so a single read is enough */ + res = read(wakeup_fd_r, &buf, 8); +#else + /* Drain the pipe buffer. Multiple wakeup notifications could + * have been sent before we have a chance to collect them. + */ + uint64_t buf; + do { + res = read(wakeup_fd_r, &buf, 8); + } while (res == 8); +#endif + if (RTS_UNLIKELY(res < 0)) { + /* After the first pipe read, it could block */ + if (errno == EAGAIN) return; + sysErrorBelch("collectFdWakeup read"); + stg_exit(EXIT_FAILURE); + } +} ===================================== rts/posix/FdWakeup.h ===================================== @@ -0,0 +1,40 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2025 + * + * Utilities for a simple fd-based cross-thread wakeup mechanism. + * + * It provides a mechanism for a thread that block on fds to add a simple + * wakeup/notification feature. + * + * Start with newFdWakeup, and pass the fd_r to the thread that needs the + * wakeup feature. The thread that needs to be woken should include the fd_r + * into the set of fds that the thread waits on (e.g. using poll or similar). + * If this fd becomes ready for read, the thread must call collectFdWakeup, + * and when a wake up is needed, the write end fd is used. In any other thread + * (or in a signal handler), call sendFdWakeup(fd_w) to (asynchronously) cause + * the wakeup. + * + * There is no message payload. Multiple wakeups may be combined (if they're + * sent multiple times before the notified thread can wake and call + * collectFdWakeup). + * + * The implementation uses pipe() or eventfd() on supported OSs. + * + * Prototypes for functions in FdWakeup.c + * + * -------------------------------------------------------------------------*/ + +#pragma once + +#include "BeginPrivate.h" + +void newFdWakeup(int *fd_r, int *fd_w); +void closeFdWakeup(int fd_r, int fd_w); + +/* This is safe to use from a signal handler */ +void sendFdWakeup(int fd_w); +void collectFdWakeup(int fd_r); + +#include "EndPrivate.h" + ===================================== rts/posix/Ticker.c ===================================== @@ -1,19 +1,53 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 1995-2007 + * (c) The GHC Team, 1995-2026 * - * Posix implementation(s) of the interval timer for profiling and pre-emptive - * scheduling. + * The posix implementation of the interval timer, used for pre-emptive + * scheduling of Haskell threads, and for sample based profiling. + * + * This file defines the "ticker": the platform-specific service to install and + * run the timer. See rts/Timer.c for the platform-dependent view of interval + * timing. * * ---------------------------------------------------------------------------*/ -/* The interval timer is used for profiling and for context switching. - * This file defines the platform-specific services to install and run the - * timers, and we call this the ticker. See rts/Timer.c for the - * platform-dependent view of interval timing. +/* This implementation uses a posix thread which repeatedly blocks on a timeout + * using either the ppoll() or select() API. This lets it also block on a file + * descriptor for early wakeup. + * + * The design uses a simple relative time delay with no catchup. That is, time + * spent by the ticker thread itself (e.g. flushing eventlog buffers) is not + * accounted for, and the next tick is delayed by that much (modulo wakeup + * jitter). This is probably the right thing to do: generally in realtime + * systems one does not want to try to catch up when behind, since that tends + * towards oversubscribing resources. Graceful degredation is usually + * preferable. + * + * Experimental results (on Linux 6.18 on x86-64) to measure the typical + * difference between the requested wakeup time and actual wakeup time for + * different delay intervals: + * + * interval typical actual wakeup time after due time + * 10000us 340 -- 400us (this is the default interval) + * 1000us 55 -- 100us + * 100us 55us + * 10us 55us + * + * While there's quite a bit of variance to these numbers, the results do not + * vary significantly between using select, ppoll or nanosleep. + * + * On Linux at least, for longer delays the kernel allows itself lower wakeup + * accuracy (which allows it to save power by coalescing multiple wakeups). + * Similarly, the reason for 55us on the low end is that the default thread + * timer slack on Linux is 50us, and context switch time accounts for the + * remainder. + * + * In conclusion, on Linux at least, the accuracy is fine, both for the + * default interval (10ms, 10000us) and for shorter intervals used during + * profiling. * * Historically we had ticker implementations using signals. This was always a - * rather shakey thing to do but we had few alternatives. + * rather shakey thing to do but we originally had few alternatives. * - One problem with using signals is that there are severe limits on what * code can be called from signal handlers. In particular it's not possible * to take locks in a signal handler contex. This was enough for contex @@ -23,17 +57,245 @@ * calls (#10840) or can be overwritten by user code. */ -/* Select a ticker implementation to use: - * - * On modern Linux, FreeBSD and NetBSD we can use timerfd_create and a thread - * that waits on it using poll. Linux has had timerfd since version 2.6.25. - * NetBSD has had timerfd since version 10, and FreeBSD since version 15. - * - * For older version of linux/bsd without timerfd, and for all other posix - * platforms, we use the implementation using posix pthreads and nanosleep(). +#include "rts/PosixSource.h" +#include "Rts.h" + +#include "Ticker.h" +#include "RtsUtils.h" +#include "Proftimer.h" +#include "Schedule.h" +#include "posix/Clock.h" +#include "posix/FdWakeup.h" + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 +/* We prefer the ppoll() function if available since it allows sanely waiting + * on a single fd with precise timeouts (nanosecond precision). It is not in + * the posix standard however and some platforms (notably glibc and freebsd) + * need special CPP defines to make it available: + */ +#define _GNU_SOURCE 1 +#define __BSD_VISIBLE 1 +#include <signal.h> +#include <poll.h> +#else +/* Otherwise we use the classic select(), which does have microsecond + * precision, but requires we build three whole 1024 bit (128 byte) fd sets + * just to wait on one fd. */ -#if defined(HAVE_SYS_TIMERFD_H) -#include "ticker/TimerFd.c" +#include <sys/select.h> +#endif + +#include <time.h> +#if HAVE_SYS_TIME_H +# include <sys/time.h> +#endif + +#if defined(HAVE_SIGNAL_H) +# include <signal.h> +#endif + +#include <string.h> + +#include <pthread.h> +#if defined(HAVE_PTHREAD_NP_H) +#include <pthread_np.h> +#endif +#include <unistd.h> +#include <fcntl.h> + +static Time itimer_interval = DEFAULT_TICK_INTERVAL; + +// Should we be firing ticks? +// Writers to this must hold the mutex below. +static bool stopped = false; + +// should the ticker thread exit? +// This can be set without holding the mutex. +static bool exited = true; + +// Signaled when we want to (re)start the timer +static Condition start_cond; +static Mutex mutex; +static OSThreadId thread; + +// fds for interrupting the ticker +static int interruptfd_r = -1, interruptfd_w = -1; + +static void *itimer_thread_func(void *_handle_tick) +{ + TickProc handle_tick = _handle_tick; + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 + struct pollfd pollfds[1]; + + pollfds[0].fd = interruptfd_r; + pollfds[0].events = POLLIN; + + struct timespec ts = { .tv_sec = TimeToSeconds(itimer_interval) + , .tv_nsec = TimeToNS(itimer_interval) % 1000000000 + }; #else -#include "ticker/Pthread.c" + fd_set selectfds; + FD_ZERO(&selectfds); + FD_SET(interruptfd_r, &selectfds); + + struct timeval tv = { .tv_sec = TimeToSeconds(itimer_interval) + /* convert remainder time in nanoseconds + to microseconds, rounding up: */ + , .tv_usec = ((TimeToNS(itimer_interval) % 1000000000) + + 999) / 1000 + }; +#endif + + // Relaxed is sufficient: If we don't see that exited was set in one iteration we will + // see it next time. + while (!RELAXED_LOAD_ALWAYS(&exited)) { + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 + int nfds = 1; + int nready = ppoll(pollfds, nfds, &ts, NULL); +#else + struct timeval tv_tmp = tv; // copy since select may change this value. + int nfds = interruptfd_r+1; + int nready = select(nfds, &selectfds, NULL, NULL, &tv_tmp); +#endif + // In either case (ppoll or select), the result nready is the number + // of fds that are ready. + if (RTS_LIKELY(nready == 0)) { + // Timer expired, not interrupted, continue. + } else if (nready > 0) { + // We only monitor one fd (the interruptfd_r), so we know + // it is that fd that is ready without any further checks. + collectFdWakeup(interruptfd_r); + // No further action needed, continue on to handling the final tick + // and then stop. + + // Note that we rely on sendFdWakeup and select/poll to provide the + // happens-before relation. So if 'exited' was set before calling + // sendFdWakeup, then we should be able to reliably read it after. + // And thus reading 'exited' in the while loop guard is ok. + } else { + // While the RTS attempts to mask signals, some foreign libraries + // that rely on signal delivery may unmask them. Consequently we + // may see EINTR. See #24610. + if (errno != EINTR) { + sysErrorBelch("Ticker: poll failed: %s", strerror(errno)); + } + } + + // first try a cheap test + if (RELAXED_LOAD_ALWAYS(&stopped)) { + OS_ACQUIRE_LOCK(&mutex); + // should we really stop? + if (stopped) { + waitCondition(&start_cond, &mutex); + } + OS_RELEASE_LOCK(&mutex); + } else { + handle_tick(0); + } + } + + return NULL; +} + +void +initTicker (Time interval, TickProc handle_tick) +{ + itimer_interval = interval; + stopped = true; + exited = false; +#if defined(HAVE_SIGNAL_H) + sigset_t mask, omask; + int sigret; +#endif + int ret; + + initCondition(&start_cond); + initMutex(&mutex); + + /* Open the interrupt fd synchronously. + * + * We used to do it in itimer_thread_func (i.e. in the timer thread) but it + * meant that some user code could run before it and get confused by the + * allocation of the timerfd. + * + * See hClose002 which unsafely closes a file descriptor twice expecting an + * exception the second time: it sometimes failed when the second call to + * "close" closed our own timerfd which inadvertently reused the same file + * descriptor closed by the first call! (see #20618) + */ + + if (interruptfd_r != -1) { + // don't leak the old file descriptors after a fork (#25280) + closeFdWakeup(interruptfd_r, interruptfd_w); + } + newFdWakeup(&interruptfd_r, &interruptfd_w); + + /* + * Create the thread with all blockable signals blocked, leaving signal + * handling to the main and/or other threads. This is especially useful in + * the non-threaded runtime, where applications might expect sigprocmask(2) + * to effectively block signals. + */ +#if defined(HAVE_SIGNAL_H) + sigfillset(&mask); + sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); +#endif + ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); +#if defined(HAVE_SIGNAL_H) + if (sigret == 0) + pthread_sigmask(SIG_SETMASK, &omask, NULL); #endif + + if (ret != 0) { + barf("Ticker: Failed to spawn thread: %s", strerror(errno)); + } +} + +void +startTicker(void) +{ + OS_ACQUIRE_LOCK(&mutex); + RELAXED_STORE(&stopped, false); + signalCondition(&start_cond); + OS_RELEASE_LOCK(&mutex); +} + +/* There may be at most one additional tick fired after a call to this */ +void +stopTicker(void) +{ + OS_ACQUIRE_LOCK(&mutex); + RELAXED_STORE(&stopped, true); + OS_RELEASE_LOCK(&mutex); +} + +/* There may be at most one additional tick fired after a call to this */ +void +exitTicker (bool wait) +{ + ASSERT(!SEQ_CST_LOAD(&exited)); + SEQ_CST_STORE(&exited, true); + // ensure that ticker wakes up if stopped + startTicker(); + sendFdWakeup(interruptfd_w); + + // wait for ticker to terminate if necessary + if (wait) { + if (pthread_join(thread, NULL)) { + sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); + } + closeFdWakeup(interruptfd_r, interruptfd_w); + closeMutex(&mutex); + closeCondition(&start_cond); + } else { + pthread_detach(thread); + } +} + +int +rtsTimerSignal(void) +{ + return SIGALRM; +} ===================================== rts/posix/ticker/Pthread.c deleted ===================================== @@ -1,195 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1995-2007 - * - * Interval timer for profiling and pre-emptive scheduling. - * - * ---------------------------------------------------------------------------*/ - -/* - * We use a realtime timer by default. I found this much more - * reliable than a CPU timer: - * - * Experiments with different frequencies: using - * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32, - * 1000us has <1% impact on runtime - * 100us has ~2% impact on runtime - * 10us has ~40% impact on runtime - * - * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32, - * I cannot get it to tick faster than 10ms (10000us) - * which isn't great for profiling. - * - * In the threaded RTS, we can't tick in CPU time because the thread - * which has the virtual timer might be idle, so the tick would never - * fire. Therefore we used to tick in realtime in the threaded RTS and - * in CPU time otherwise, but now we always tick in realtime, for - * several reasons: - * - * - resolution (see above) - * - consistency (-threaded is the same as normal) - * - more consistency: Windows only has a realtime timer - * - * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME, - * because the latter may jump around (NTP adjustments, leap seconds - * etc.). - */ - -#include "rts/PosixSource.h" -#include "Rts.h" - -#include "Ticker.h" -#include "RtsUtils.h" -#include "Proftimer.h" -#include "Schedule.h" -#include "posix/Clock.h" -#include <poll.h> - -#include <time.h> -#if HAVE_SYS_TIME_H -# include <sys/time.h> -#endif - -#if defined(HAVE_SIGNAL_H) -# include <signal.h> -#endif - -#include <string.h> - -#include <pthread.h> -#if defined(HAVE_PTHREAD_NP_H) -#include <pthread_np.h> -#endif -#include <unistd.h> -#include <fcntl.h> - -/* - * TFD_CLOEXEC has been added in Linux 2.6.26. - * If it is not available, we use fcntl(F_SETFD). - */ -#if !defined(TFD_CLOEXEC) -#define TFD_CLOEXEC 0 -#endif - -static Time itimer_interval = DEFAULT_TICK_INTERVAL; - -// Should we be firing ticks? -// Writers to this must hold the mutex below. -static bool stopped = false; - -// should the ticker thread exit? -// This can be set without holding the mutex. -static bool exited = true; - -// Signaled when we want to (re)start the timer -static Condition start_cond; -static Mutex mutex; -static OSThreadId thread; - -static void *itimer_thread_func(void *_handle_tick) -{ - TickProc handle_tick = _handle_tick; - - // Relaxed is sufficient: If we don't see that exited was set in one iteration we will - // see it next time. - while (!RELAXED_LOAD_ALWAYS(&exited)) { - if (rtsSleep(itimer_interval) != 0) { - sysErrorBelch("Ticker: sleep failed: %s", strerror(errno)); - } - - // first try a cheap test - if (RELAXED_LOAD_ALWAYS(&stopped)) { - OS_ACQUIRE_LOCK(&mutex); - // should we really stop? - if (stopped) { - waitCondition(&start_cond, &mutex); - } - OS_RELEASE_LOCK(&mutex); - } else { - handle_tick(0); - } - } - - return NULL; -} - -void -initTicker (Time interval, TickProc handle_tick) -{ - itimer_interval = interval; - stopped = true; - exited = false; -#if defined(HAVE_SIGNAL_H) - sigset_t mask, omask; - int sigret; -#endif - int ret; - - initCondition(&start_cond); - initMutex(&mutex); - - /* - * Create the thread with all blockable signals blocked, leaving signal - * handling to the main and/or other threads. This is especially useful in - * the non-threaded runtime, where applications might expect sigprocmask(2) - * to effectively block signals. - */ -#if defined(HAVE_SIGNAL_H) - sigfillset(&mask); - sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); -#endif - ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); -#if defined(HAVE_SIGNAL_H) - if (sigret == 0) - pthread_sigmask(SIG_SETMASK, &omask, NULL); -#endif - - if (ret != 0) { - barf("Ticker: Failed to spawn thread: %s", strerror(errno)); - } -} - -void -startTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, false); - signalCondition(&start_cond); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -stopTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, true); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -exitTicker (bool wait) -{ - ASSERT(!SEQ_CST_LOAD(&exited)); - SEQ_CST_STORE(&exited, true); - // ensure that ticker wakes up if stopped - startTicker(); - - // wait for ticker to terminate if necessary - if (wait) { - if (pthread_join(thread, NULL)) { - sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); - } - closeMutex(&mutex); - closeCondition(&start_cond); - } else { - pthread_detach(thread); - } -} - -int -rtsTimerSignal(void) -{ - return SIGALRM; -} ===================================== rts/posix/ticker/TimerFd.c deleted ===================================== @@ -1,291 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1995-2023 - * - * Interval timer for profiling and pre-emptive scheduling. - * - * ---------------------------------------------------------------------------*/ - -/* - * We use a realtime timer by default. I found this much more - * reliable than a CPU timer: - * - * Experiments with different frequencies: using - * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32, - * 1000us has <1% impact on runtime - * 100us has ~2% impact on runtime - * 10us has ~40% impact on runtime - * - * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32, - * I cannot get it to tick faster than 10ms (10000us) - * which isn't great for profiling. - * - * In the threaded RTS, we can't tick in CPU time because the thread - * which has the virtual timer might be idle, so the tick would never - * fire. Therefore we used to tick in realtime in the threaded RTS and - * in CPU time otherwise, but now we always tick in realtime, for - * several reasons: - * - * - resolution (see above) - * - consistency (-threaded is the same as normal) - * - more consistency: Windows only has a realtime timer - * - * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME, - * because the latter may jump around (NTP adjustments, leap seconds - * etc.). - */ - -#include "rts/PosixSource.h" -#include "Rts.h" - -#include "Ticker.h" -#include "RtsUtils.h" -#include "Proftimer.h" -#include "Schedule.h" -#include "posix/Clock.h" -#include <poll.h> - -#include <time.h> -#if HAVE_SYS_TIME_H -# include <sys/time.h> -#endif - -#if defined(HAVE_SIGNAL_H) -# include <signal.h> -#endif - -#include <string.h> - -#include <pthread.h> -#if defined(HAVE_PTHREAD_NP_H) -#include <pthread_np.h> -#endif -#include <unistd.h> -#include <fcntl.h> - -#include <sys/timerfd.h> - - -/* - * TFD_CLOEXEC has been added in Linux 2.6.26. - * If it is not available, we use fcntl(F_SETFD). - */ -#if !defined(TFD_CLOEXEC) -#define TFD_CLOEXEC 0 -#endif - -static Time itimer_interval = DEFAULT_TICK_INTERVAL; - -// Should we be firing ticks? -// Writers to this must hold the mutex below. -static bool stopped = false; - -// should the ticker thread exit? -// This can be set without holding the mutex. -static bool exited = true; - -// Signaled when we want to (re)start the timer -static Condition start_cond; -static Mutex mutex; -static OSThreadId thread; - -// file descriptor for the timer (Linux only) -static int timerfd = -1; - -// pipe for signaling exit -static int pipefds[2]; - -static void *itimer_thread_func(void *_handle_tick) -{ - TickProc handle_tick = _handle_tick; - uint64_t nticks; - ssize_t r = 0; - struct pollfd pollfds[2]; - - pollfds[0].fd = pipefds[0]; - pollfds[0].events = POLLIN; - pollfds[1].fd = timerfd; - pollfds[1].events = POLLIN; - - // Relaxed is sufficient: If we don't see that exited was set in one iteration we will - // see it next time. - while (!RELAXED_LOAD_ALWAYS(&exited)) { - if (poll(pollfds, 2, -1) == -1) { - // While the RTS attempts to mask signals, some foreign libraries - // may rely on signal delivery may unmask them. Consequently we may - // see EINTR. See #24610. - if (errno != EINTR) { - sysErrorBelch("Ticker: poll failed: %s", strerror(errno)); - } - } - - // We check the pipe first, even though the timerfd may also have triggered. - if (pollfds[0].revents & POLLIN) { - // the pipe is ready for reading, the only possible reason is that we're exiting - exited = true; // set this again to make sure even RELAXED_LOAD will read the proper value - // no further action needed, skip ahead to handling the final tick and then stopping - } - else if (pollfds[1].revents & POLLIN) { // the timerfd is ready for reading - r = read(timerfd, &nticks, sizeof(nticks)); // this should never block now - - if ((r == 0) && (errno == 0)) { - /* r == 0 is expected only for non-blocking fd (in which case - * errno should be EAGAIN) but we use a blocking fd. - * - * Due to a kernel bug (cf https://lkml.org/lkml/2019/8/16/335) - * on some platforms we could see r == 0 and errno == 0. - */ - IF_DEBUG(scheduler, debugBelch("read(timerfd) returned 0 with errno=0. This is a known kernel bug. We just ignore it.")); - } - else if (r != sizeof(nticks) && errno != EINTR) { - barf("Ticker: read(timerfd) failed with %s and returned %zd", strerror(errno), r); - } - } - - // first try a cheap test - if (RELAXED_LOAD_ALWAYS(&stopped)) { - OS_ACQUIRE_LOCK(&mutex); - // should we really stop? - if (stopped) { - waitCondition(&start_cond, &mutex); - } - OS_RELEASE_LOCK(&mutex); - } else { - handle_tick(0); - } - } - - close(timerfd); - return NULL; -} - -void -initTicker (Time interval, TickProc handle_tick) -{ - itimer_interval = interval; - stopped = true; - exited = false; -#if defined(HAVE_SIGNAL_H) - sigset_t mask, omask; - int sigret; -#endif - int ret; - - initCondition(&start_cond); - initMutex(&mutex); - - /* Open the file descriptor for the timer synchronously. - * - * We used to do it in itimer_thread_func (i.e. in the timer thread) but it - * meant that some user code could run before it and get confused by the - * allocation of the timerfd. - * - * See hClose002 which unsafely closes a file descriptor twice expecting an - * exception the second time: it sometimes failed when the second call to - * "close" closed our own timerfd which inadvertently reused the same file - * descriptor closed by the first call! (see #20618) - */ - struct itimerspec it; - it.it_value.tv_sec = TimeToSeconds(itimer_interval); - it.it_value.tv_nsec = TimeToNS(itimer_interval) % 1000000000; - it.it_interval = it.it_value; - - if (timerfd != -1) { - // don't leak the old file descriptors after a fork (#25280) - close(timerfd); - close(pipefds[0]); - close(pipefds[1]); - timerfd = -1; - } - - timerfd = timerfd_create(CLOCK_MONOTONIC, TFD_CLOEXEC); - if (timerfd == -1) { - barf("timerfd_create: %s", strerror(errno)); - } - if (!TFD_CLOEXEC) { - fcntl(timerfd, F_SETFD, FD_CLOEXEC); - } - if (timerfd_settime(timerfd, 0, &it, NULL)) { - barf("timerfd_settime: %s", strerror(errno)); - } - - if (pipe(pipefds) < 0) { - barf("pipe: %s", strerror(errno)); - } - - /* - * Create the thread with all blockable signals blocked, leaving signal - * handling to the main and/or other threads. This is especially useful in - * the non-threaded runtime, where applications might expect sigprocmask(2) - * to effectively block signals. - */ -#if defined(HAVE_SIGNAL_H) - sigfillset(&mask); - sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); -#endif - ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); -#if defined(HAVE_SIGNAL_H) - if (sigret == 0) - pthread_sigmask(SIG_SETMASK, &omask, NULL); -#endif - - if (ret != 0) { - barf("Ticker: Failed to spawn thread: %s", strerror(errno)); - } -} - -void -startTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, false); - signalCondition(&start_cond); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -stopTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, true); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -exitTicker (bool wait) -{ - ASSERT(!SEQ_CST_LOAD(&exited)); - SEQ_CST_STORE(&exited, true); - // ensure that ticker wakes up if stopped - startTicker(); - - // wait for ticker to terminate if necessary - if (wait) { - // write anything to the pipe to trigger poll() in the ticker thread - if (write(pipefds[1], "stop", 5) < 0) { - sysErrorBelch("Ticker: Failed to write to pipe: %s", strerror(errno)); - } - - if (pthread_join(thread, NULL)) { - sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); - } - - // These need to happen AFTER the ticker thread has finished to prevent a race condition - // where the ticker thread closes the read end of the pipe before we're done writing to it. - close(pipefds[0]); - close(pipefds[1]); - - closeMutex(&mutex); - closeCondition(&start_cond); - } else { - pthread_detach(thread); - } -} - -int -rtsTimerSignal(void) -{ - return SIGALRM; -} ===================================== rts/rts.cabal ===================================== @@ -582,11 +582,9 @@ library posix/Ticker.c posix/OSMem.c posix/OSThreads.c + posix/FdWakeup.c posix/Poll.c posix/Select.c posix/Signals.c posix/Timeout.c posix/TTY.c - -- ticker/*.c - -- We don't want to compile posix/ticker/*.c, these will be #included - -- from Ticker.c View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84c751d4b93c44f99ddea53236f23b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/84c751d4b93c44f99ddea53236f23b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/dcoutts/windows-dlls-experimental
by Duncan Coutts (＠dcoutts) 07 Apr '26

07 Apr '26

Duncan Coutts pushed new branch wip/dcoutts/windows-dlls-experimental at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dcoutts/windows-dlls-experime… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/hpc-bc-support] fixup! Add more tests for ghci and -fhpc
by Hannes Siebenhandl (＠fendor) 07 Apr '26

07 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: 94b3f5bf by fendor at 2026-04-07T11:11:54+02:00 fixup! Add more tests for ghci and -fhpc - - - - - 2 changed files: - testsuite/tests/hpc/function/test.T - testsuite/tests/hpc/simple/test.T Changes: ===================================== testsuite/tests/hpc/function/test.T ===================================== @@ -3,7 +3,7 @@ setTestOpts([when(fast(), skip), js_skip]) hpc_prefix = "./hpcrun.sh --clear --exeext={exeext} --hpc={hpc} --" test('tough', - [extra_files(['../hpcrun.pl']), + [extra_files(['hpcrun.sh']), cmd_prefix(hpc_prefix), ignore_extension, when(arch('wasm32'), fragile(23243))], ===================================== testsuite/tests/hpc/simple/test.T ===================================== @@ -1,4 +1,4 @@ -setTestOpts([omit_ghci, when(fast(), skip), js_skip]) +setTestOpts([when(fast(), skip), js_skip]) hpc_prefix = "perl hpcrun.pl --clear --exeext={exeext} --hpc={hpc}" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94b3f5bfde4590e608bc3083536d41a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/94b3f5bfde4590e608bc3083536d41a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ghci-messages-no-string] 4 commits: base: improve error message for Data.Char.chr
by Cheng Shao (＠TerrorJack) 07 Apr '26

07 Apr '26

Cheng Shao pushed to branch wip/ghci-messages-no-string at Glasgow Haskell Compiler / GHC Commits: 502e6ffe by Andrew Lelechenko at 2026-04-07T04:47:21-04:00 base: improve error message for Data.Char.chr As per https://github.com/haskell/core-libraries-committee/issues/384 - - - - - b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00 Refactor FunResCtxt a bit Fixes #27154 - - - - - 4b999500 by Cheng Shao at 2026-04-07T08:57:36+00:00 ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages This patch refactors ghci to use `ShortByteString` for `LookupSymbol`/`LookupSymbolInDLL`/`LookupClosure` messages as the first part of #27147. Co-authored-by: Codex <codex(a)openai.com> - - - - - 475642de by Cheng Shao at 2026-04-07T08:57:39+00:00 ghci: use ShortByteString for MkCostCentres message This patch refactors ghci to use `ShortByteString` for `MkCostCentres` messages as a first part of #27147. This also considerably lowers the memory overhead of breakpoints when cost center profiling is enabled. ------------------------- Metric Decrease: interpreter_steplocal ------------------------- Co-authored-by: Codex <codex(a)openai.com> - - - - - 22 changed files: - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Zonk/TcType.hs - libraries/base/changelog.md - libraries/base/tests/enum01.stdout - libraries/base/tests/enum01.stdout-alpha-dec-osf3 - libraries/base/tests/enum01.stdout-ws-64 - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/ObjLink.hs - libraries/ghci/GHCi/Run.hs - testsuite/tests/driver/linkwhole/Main.hs - testsuite/tests/ghci/should_run/T18064.script - testsuite/tests/rts/KeepCafsMain.hs - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -37,6 +37,7 @@ import GHC.Prelude import GHC.Types.SrcLoc import GHC.Types.Name.Occurrence import Control.DeepSeq +import qualified Data.ByteString.Short as SBS import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM @@ -235,8 +236,8 @@ getBreakVars = getBreakXXX modBreaks_vars getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String] getBreakDecls = getBreakXXX modBreaks_decls --- | Get the decls for this breakpoint -getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String)) +-- | Get the cost centre info for this breakpoint +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (SBS.ShortByteString, SBS.ShortByteString) getBreakCCS = getBreakXXX modBreaks_ccs -- | Internal utility to access a ModBreaks field at a particular breakpoint index ===================================== compiler/GHC/Driver/Plugins.hs ===================================== @@ -405,7 +405,7 @@ loadExternalPlugins ps = do symbol | null unit = ztmp | otherwise = zEncodeString unit ++ "_" ++ ztmp - plugin <- lookupSymbol symbol >>= \case + plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case Nothing -> pprPanic "loadExternalPlugins" (vcat [ text "Symbol not found" , text " Library path: " <> text path ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -23,6 +23,7 @@ module GHC.HsToCore.Breakpoints import GHC.Prelude import Data.Array +import qualified Data.ByteString.Short as SBS import GHC.HsToCore.Ticks (Tick (..)) import GHC.Data.SizedSeq @@ -31,6 +32,7 @@ import GHC.Types.Name (OccName) import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) import GHC.Unit.Module (Module) import GHC.Utils.Binary +import GHC.Utils.Encoding (utf8EncodeShortByteString) import GHC.Utils.Outputable import Data.List (intersperse) import Data.Coerce @@ -59,7 +61,7 @@ data ModBreaks , modBreaks_decls :: !(Array BreakTickIndex [String]) -- ^ An array giving the names of the declarations enclosing each breakpoint. -- See Note [Field modBreaks_decls] - , modBreaks_ccs :: !(Array BreakTickIndex (String, String)) + , modBreaks_ccs :: !(Array BreakTickIndex (SBS.ShortByteString, SBS.ShortByteString)) -- ^ Array pointing to cost centre info for each breakpoint; -- actual 'CostCentre' allocation is done at link-time. , modBreaks_module :: !Module @@ -89,8 +91,8 @@ mkModBreaks interpreterProfiled modl extendedMixEntries | interpreterProfiled = listArray (0, count - 1) - [ ( concat $ intersperse "." $ tick_path t, - renderWithContext defaultSDocContext $ ppr $ tick_loc t + [ ( utf8EncodeShortByteString $ concat $ intersperse "." $ tick_path t, + utf8EncodeShortByteString $ renderWithContext defaultSDocContext $ ppr $ tick_loc t ) | t <- entries ] ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -1846,7 +1846,7 @@ allocateCCS interp ce mbss ccs <- {- one ccs ptr per tick index -} mkCostCentres interp - (moduleNameString $ moduleName modBreaks_module) + (moduleNameFS $ moduleName modBreaks_module) (elems modBreaks_ccs) return $ M.fromList $ zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..] ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -107,6 +107,7 @@ import Control.Monad.IO.Class import Control.Monad.Catch as MC (mask) import Data.Binary import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as SBS import Foreign hiding (void) import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) @@ -352,9 +353,15 @@ evalStringToIOString interp fhv str = mallocData :: Interp -> ByteString -> IO (RemotePtr ()) mallocData interp bs = interpCmd interp (MallocData bs) -mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre] -mkCostCentres interp mod ccs = - interpCmd interp (MkCostCentres mod ccs) +mkCostCentres :: Interp -> FastString -> [(SBS.ShortByteString, SBS.ShortByteString)] -> IO [RemotePtr CostCentre] +mkCostCentres interp mod ccs = do + rp <- modifyMVar (interpStringCache interp) $ \fs_env -> + case lookupFsEnv fs_env mod of + Just rp -> pure (fs_env, rp) + Nothing -> do + rp <- fmap head $ interpCmd interp $ MallocStrings [bytesFS mod] + pure (extendFsEnv fs_env mod rp, rp) + interpCmd interp $ MkCostCentres rp ccs -- | Create a set of BCOs that may be mutually recursive. createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef] @@ -413,7 +420,7 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId evalBreakpointToId eval_break = let mkUnitId u = fsToUnit $ mkFastStringShortByteString u - toModule u n = mkModule (mkUnitId u) (mkModuleName n) + toModule u n = mkModule (mkUnitId u) (mkModuleNameFS (mkFastStringShortByteString n)) in InternalBreakpointId { ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break) @@ -465,27 +472,27 @@ lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ())) lookupSymbol interp str = withSymbolCache interp str $ case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ())) lookupSymbolInDLL interp dll str = withSymbolCache interp str $ case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str))) #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str))) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) -- wasm dyld doesn't track which symbol comes from which .so ExtWasm {} -> lookupSymbol interp str @@ -519,7 +526,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is - lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef) lookupClosure interp str = - interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str))) + interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str))) -- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' -- which maps symbols to the address where they are loaded. ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7710,12 +7710,8 @@ pprHsCtxt = \case PatSigErrCtxt sig_ty res_ty -> vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ] - where - -- Zonking will have turned Infer into Check - pp_res_ty = case res_ty of - Check ty -> ppr ty - Infer ir -> text "OOPS" <+> ppr ir + , nest 2 (hang (text "fits the type of its context:") + 2 (ppr (getCheckExpType res_ty))) ] PatCtxt pat -> hang (text "In the pattern:") 2 (ppr pat) @@ -7777,7 +7773,7 @@ pprHsCtxt = \case full_herald = pprExpectedFunTyHerald herald <+> speakNOf n_vis_args_in_call (text "visible argument") -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic - FunResCtxt fun n_val_args res_fun res_env n_fun n_env + FunResCtxt fun n_val_args fun_res_ty env_ty | -- Check for too few args -- fun_tau = a -> b, res_tau = Int n_fun > n_env @@ -7801,6 +7797,18 @@ pprHsCtxt = \case -> empty -- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env] where + -- See Note [Splitting nested sigma types in mismatched + -- function types] + -- env_ty is an ExpRhoTy, but with simple subsumption it + -- is not /deeply/ skolemised, so still use tcSplitNestedSigmaTys + + (_,_,fun_tau) = tcSplitNestedSigmaTys fun_res_ty + (_, _, env_tau) = tcSplitNestedSigmaTys (getCheckExpType env_ty) + (args_fun, res_fun) = tcSplitFunTys fun_tau + (args_env, res_env) = tcSplitFunTys env_tau + n_fun = length args_fun + n_env = length args_env + not_fun ty -- ty is definitely not an arrow type, -- and cannot conceivably become one = case tcSplitTyConApp_maybe ty of ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Builtin.Names import GHC.Driver.DynFlags import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic import GHC.Data.Maybe @@ -961,7 +960,8 @@ See Note [-fno-code mode]. * * ********************************************************************* -} -addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] +addFunResCtxt :: HasDebugCallStack + => HsExpr GhcTc -> [HsExprArg p] -> TcType -> ExpRhoType -> TcM a -> TcM a -- When we have a mis-match in the return type of a function @@ -969,33 +969,10 @@ addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] -- But not in generated code, where we don't want -- to mention internal (rebindable syntax) function names addFunResCtxt fun args fun_res_ty env_ty thing_inside - = do { env_tv <- newFlexiTyVarTy liftedTypeKind - ; dumping <- doptM Opt_D_dump_tc_trace - ; msg <- mk_msg dumping env_tv - ; addErrCtxt msg thing_inside } + = addErrCtxt (FunResCtxt fun (count isValArg args) fun_res_ty env_ty) $ + thing_inside -- NB: use a landmark error context, so that an empty context -- doesn't suppress some more useful context - where - mk_msg dumping env_tv - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; env' <- case mb_env_ty of - Just env_ty -> return env_ty - Nothing -> do { massert dumping; return env_tv } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res_ty - (_, _, env_tau) = tcSplitNestedSigmaTys env' - -- env_ty is an ExpRhoTy, but with simple subsumption it - -- is not deeply skolemised, so still use tcSplitNestedSigmaTys - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - info = - FunResCtxt fun (count isValArg args) res_fun res_env - (length args_fun) (length args_env) - ; return info } - {- Note [Splitting nested sigma types in mismatched function types] ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -251,7 +251,10 @@ data HsCtxt -- | In the instance type signature of a class method. | MethSigCtxt !Name !TcType !TcType -- | In a pattern type signature. + | PatSigErrCtxt !TcType !ExpType + -- ExpType: see Note [ExpType in HsCtxt] + -- | In a pattern. | PatCtxt !(Pat GhcRn) -- | In a pattern synonym declaration. @@ -268,7 +271,10 @@ data HsCtxt -- | In a function call. | FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int -- | In the result of a function call. - | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int + + | FunResCtxt !(HsExpr GhcTc) !Int !TcType !ExpType + -- ExpType: see Note [ExpType in HsCtxt] + -- | In the declaration of a type constructor. | TyConDeclCtxt !Name !(TyConFlavour TyCon) -- | In a type or data family instance (or default instance). @@ -377,3 +383,14 @@ isHsCtxtLandmark (DerivBindCtxt{}) = True isHsCtxtLandmark (FunResCtxt{}) = True isHsCtxtLandmark (VDQWarningCtxt{}) = True isHsCtxtLandmark _ = False + +{- Note [ExpType in HsCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A couple of HsCtxt constructors have ExpTypes in them. When zonking the +Infer{} case we read the hole, which should be filled in by now, and zonk +that type. Now we want to put it back: we use (Check ty') for this, so that +clients of a zonked HsCtxt don't need to be monadic. + +Result: after zonking, these ExpTypes are always (Check ty). It woudl be nice +to guarantee this statically, but it's hard to do so. +-} ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Tc.Utils.TcType ( ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..), ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR, ExpRhoType, ExpRhoTypeFRR, - mkCheckExpType, + mkCheckExpType, getCheckExpType, checkingExpType_maybe, checkingExpType, ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType, @@ -440,11 +440,12 @@ data InferInstFlag -- Specifies whether the inference should return an uninstan | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top) -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole - -- Typically used when inferring the type of an expression + -- Used only for view patterns; see Note [View patterns and polymorphism] | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption) -- If DeepSubsumption is off, same as IIF_ShallowRho -- If DeepSubsumption is on, instantiate deeply before filling the hole + -- Typically used when inferring the type of an expression type ExpSigmaType = ExpType type ExpRhoType = ExpType @@ -490,6 +491,12 @@ instance Outputable InferResult where mkCheckExpType :: TcType -> ExpType mkCheckExpType = Check +getCheckExpType :: HasDebugCallStack => ExpType -> TcType +-- Expect a (Check ty). +-- See Note [ExpType in HsCtxt] in GHC.Tc.Types.ErrCtxt +getCheckExpType (Check ty) = ty +getCheckExpType (Infer ir) = pprPanic "getCheckExpType" (ppr ir) + -- | Returns the expected type when in checking mode. checkingExpType_maybe :: ExpType -> Maybe TcType checkingExpType_maybe (Check ty) = Just ty ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -818,19 +818,26 @@ zonkTidyHsCtxt env e@(FunAppCtxt{}) = return (env, e) zonkTidyHsCtxt env (FunTysCtxt ctxt ty i1 i2) = do (env', ty') <- zonkTidyTcType env ty return $ (env', FunTysCtxt ctxt ty' i1 i2) -zonkTidyHsCtxt env (FunResCtxt e i1 ty1 ty2 i2 i3) = do - (env', ty1') <- zonkTidyTcType env ty1 - (env', ty2') <- zonkTidyTcType env' ty2 - return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3) +zonkTidyHsCtxt env (FunResCtxt e n ty1 env_ty) = do + (env', ty1') <- zonkTidyTcType env ty1 + (env', env_ty') <- zonkExpType env' env_ty + return $ (env', FunResCtxt e n ty1' env_ty') zonkTidyHsCtxt env (PatSigErrCtxt sig_ty res_ty) = do (env', sig_ty') <- zonkTidyTcType env sig_ty - (env', res_ty') <- - case res_ty of - Check ty -> zonkTidyTcType env' ty - Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops - mb_ty <- liftIO $ readIORef ref - case mb_ty of - Nothing -> error "zonkTidyHsCtxt PatSigErrCtxt" - Just ty -> zonkTidyTcType env' ty - return (env', PatSigErrCtxt sig_ty' (Check res_ty')) + (env', res_ty') <- zonkExpType env' res_ty + return (env', PatSigErrCtxt sig_ty' res_ty') zonkTidyHsCtxt env p = return (env, p) + +zonkExpType :: TidyEnv -> ExpType -> ZonkM (TidyEnv, ExpType) +-- Zonk Infer{} to Check. The hole should have been filled in by now +zonkExpType env (Check ty) + = do { (env', ty') <- zonkTidyTcType env ty + ; return (env', Check ty') } +zonkExpType env (Infer ir@(IR { ir_ref = ref })) + = do { -- inlining readExpTyp_maybe to avoid module dep loops + ; mb_ty <- liftIO $ readIORef ref + ; case mb_ty of + Nothing -> pprPanic "zonkTidyHsCtxt PatSigErrCtxt" (ppr ir) + Just ty -> do { (env', ty') <- zonkTidyTcType env ty + ; return (env', Check ty') } } + ===================================== libraries/base/changelog.md ===================================== @@ -28,6 +28,7 @@ * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) + * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/tests/enum01.stdout ===================================== @@ -81,7 +81,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-2147483648)" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-2147483648)" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/base/tests/enum01.stdout-alpha-dec-osf3 ===================================== @@ -65,7 +65,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111:" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/base/tests/enum01.stdout-ws-64 ===================================== @@ -81,7 +81,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-9223372036854775808)" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-9223372036854775808)" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/ghc-internal/src/GHC/Internal/Char.hs ===================================== @@ -12,7 +12,7 @@ module GHC.Internal.Char import GHC.Internal.Classes (eqChar, neChar) import GHC.Internal.Base (otherwise, (++)) -import GHC.Internal.Err (errorWithoutStackTrace) +import GHC.Internal.Err (error) import GHC.Internal.Show import GHC.Internal.Prim (chr#, int2Word#, leWord#, Int#, Char#) import GHC.Internal.Types (Char(..), Int(..), isTrue#) @@ -29,4 +29,7 @@ safe_chr# i# {-# NOINLINE chr_error #-} chr_error :: Int# -> Char# -chr_error i# = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) (I# i#) "") +chr_error i# = error ("Data.Char.chr: argument outside Unicode range: 0..1114111: " ++ showSignedInt (I# 9#) (I# i#) "") +-- It's not really "Data.Char", but we assume that +-- the majority of users will import it from "base:Data.Char" +-- and not from "ghc-internal:GHC.Internal.Char". ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -86,9 +86,9 @@ data Message a where -- These all invoke the corresponding functions in the RTS Linker API. InitLinker :: Message () - LookupSymbol :: String -> Message (Maybe (RemotePtr ())) - LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ())) - LookupClosure :: String -> Message (Maybe HValueRef) + LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ())) + LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ())) + LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef) LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL]) LoadArchive :: String -> Message () -- error? LoadObj :: String -> Message () -- error? @@ -162,8 +162,8 @@ data Message a where -- | Create a set of CostCentres with the same module name MkCostCentres - :: String -- module, RemotePtr so it can be shared - -> [(String,String)] -- (name, SrcSpan) + :: !(RemotePtr ()) -- ModuleName + -> ![(BS.ShortByteString, BS.ShortByteString)] -- (name, SrcSpan) -> Message [RemotePtr CostCentre] -- | Show a 'CostCentreStack' as a @[String]@ @@ -430,7 +430,7 @@ data EvalStatus_ a b instance Binary a => Binary (EvalStatus_ a b) data EvalBreakpoint = EvalBreakpoint - { eb_info_mod :: String -- ^ Breakpoint info module + { eb_info_mod :: !BS.ShortByteString -- ^ Breakpoint info module , eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id , eb_info_index :: Int -- ^ Breakpoint info index } ===================================== libraries/ghci/GHCi/ObjLink.hs ===================================== @@ -31,6 +31,8 @@ import GHCi.RemoteTypes import GHCi.Message (LoadedDLL) import Control.Exception (throwIO, ErrorCall(..)) import Control.Monad ( when ) +import qualified Data.ByteString.Short as BS +import Data.Char (ord) import Data.Foldable import Foreign.C import Foreign.Marshal.Alloc ( alloca, free ) @@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f purgeObj :: String -> IO () purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f -lookupSymbol :: String -> IO (Maybe (Ptr a)) -lookupSymbol sym = do - r <- js_lookupSymbol $ toJSString sym +lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a)) +lookupSymbol sym@(BS.SBS ba#) = do + r <- js_lookupSymbolPtr ba# (BS.length sym) evaluate $ if r == nullPtr then Nothing else Just r -foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)" - js_lookupSymbol :: JSString -> IO (Ptr a) +foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)" + js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a) -lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a)) +lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbolInDLL _ _ = pure Nothing resolveObjs :: IO Bool @@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO () initObjLinker RetainCAFs = c_initLinker_ 1 initObjLinker _ = c_initLinker_ 0 -lookupSymbol :: String -> IO (Maybe (Ptr a)) +lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbol str_in = do let str = prefixUnderscore str_in - withCAString str $ \c_str -> do + BS.useAsCString str $ \c_str -> do addr <- c_lookupSymbol c_str if addr == nullPtr then return Nothing else return (Just addr) -lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a)) +lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbolInDLL dll str_in = do let str = prefixUnderscore str_in - withCAString str $ \c_str -> do + BS.useAsCString str $ \c_str -> do addr <- c_lookupSymbolInNativeObj dll c_str if addr == nullPtr then return Nothing else return (Just addr) -prefixUnderscore :: String -> String +prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString prefixUnderscore - | cLeadingUnderscore = ('_':) + | cLeadingUnderscore = BS.cons (fromIntegral (ord '_')) | otherwise = id -- | loadDLL loads a dynamic library using the OS's native linker @@ -298,7 +300,7 @@ isWindowsHost = False #endif -lookupClosure :: String -> IO (Maybe HValueRef) +lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef) lookupClosure str = do m <- lookupSymbol str case m of ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -34,7 +34,7 @@ import Control.DeepSeq import Control.Exception import Control.Monad import Data.ByteString (ByteString) -import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Short.Internal as BS import qualified Data.ByteString.Unsafe as B import GHC.Exts import qualified GHC.Exts.Heap as Heap @@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #) -lookupJSClosure' :: String -> IO Int -lookupJSClosure' str = withCString str $ \cstr -> IO (\s -> +lookupJSClosure' :: BS.ShortByteString -> IO Int +lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s -> case lookupJSClosure# cstr s of (# s', r #) -> (# s', I# r #)) -lookupJSClosure :: String -> IO (Maybe HValueRef) +lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef) lookupJSClosure str = lookupJSClosure' str >>= \case 0 -> pure Nothing r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r)))) @@ -359,7 +359,7 @@ withBreakAction opts breakMVar statusMVar mtid act if is_exception then pure Nothing else do - info_mod <- peekCString (Ptr info_mod#) + info_mod <- BS.packCString (Ptr info_mod#) info_mod_uid <- BS.packCString (Ptr info_mod_uid#) pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#))) putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs @@ -434,17 +434,24 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do pokeElemOff (ptr :: Ptr CChar) len 0 return (castRemotePtr (toRemotePtr ptr)) -mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre] +mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre] #if defined(PROFILING) mkCostCentres mod ccs = do - c_module <- newCString mod + let c_module = fromRemotePtr $ castRemotePtr mod mapM (mk_one c_module) ccs where mk_one c_module (decl_path,srcspan) = do - c_name <- newCString decl_path - c_srcspan <- newCString srcspan + c_name <- newCStringFromSBS decl_path + c_srcspan <- newCStringFromSBS srcspan toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan + newCStringFromSBS sbs = do + let len = BS.length sbs + buf <- mallocBytes $ len + 1 + BS.copyToPtr sbs 0 buf (fromIntegral len) + pokeByteOff buf len (0 :: Word8) + pure buf + foreign import ccall unsafe "mkCostCentre" c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre) #else ===================================== testsuite/tests/driver/linkwhole/Main.hs ===================================== @@ -1,9 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main (main) where import Control.Exception import Control.Monad +import Data.ByteString.Short (ShortByteString) import Foreign @@ -15,7 +17,7 @@ import GHCi.ObjLink rotateSO :: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a))) - -> String + -> ShortByteString -> (Maybe FilePath, FilePath) -> IO a rotateSO dynamicCall symName (old, newDLL) = do ===================================== testsuite/tests/ghci/should_run/T18064.script ===================================== @@ -1,2 +1,3 @@ +:set -XOverloadedStrings import GHCi.ObjLink lookupClosure "blah" ===================================== testsuite/tests/rts/KeepCafsMain.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main (main) where import Foreign ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1334,6 +1334,13 @@ class DyLD { } return 0; } + + lookupSymbolPtr(symPtr, symLen) { + const sym = new TextDecoder("utf-8", { fatal: true }).decode( + new Uint8Array(this.#memory.buffer, symPtr, symLen) + ); + return this.lookupSymbol(sym); + } } // The main entry point of dyld that may be run on node/browser, and View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3506399809629de4e09c9aadc70100… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3506399809629de4e09c9aadc70100… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/full-eventlog-live] Support for `ghc-stack-profiler`
by Hannes Siebenhandl (＠fendor) 07 Apr '26

07 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/full-eventlog-live at Glasgow Haskell Compiler / GHC Commits: 3d2f9b80 by fendor at 2026-04-07T10:55:21+02:00 Support for `ghc-stack-profiler` Instrument GHC to run with `ghc-stack-profiler` - - - - - 10 changed files: - .gitmodules - + ghc-stack-profiler - ghc/Main.hs - ghc/ghc-bin.cabal.in - hadrian/src/Packages.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Packages.hs - + libraries/async - + libraries/hashable - + libraries/unordered-containers Changes: ===================================== .gitmodules ===================================== @@ -126,3 +126,15 @@ [submodule "eventlog-socket"] path = eventlog-socket url = https://github.com/well-typed/eventlog-socket.git +[submodule "ghc-stack-profiler"] + path = ghc-stack-profiler + url = https://github.com/well-typed/ghc-stack-profiler +[submodule "libraries/async"] + path = libraries/async + url = https://github.com/fendor/async.git +[submodule "libraries/unordered-containers"] + path = libraries/unordered-containers + url = https://github.com/fendor/unordered-containers.git +[submodule "libraries/hashable"] + path = libraries/hashable + url = https://github.com/fendor/hashable ===================================== ghc-stack-profiler ===================================== @@ -0,0 +1 @@ +Subproject commit d8edeeef0b5f0babdcffc008f249a35e19cc0c8b ===================================== ghc/Main.hs ===================================== @@ -79,6 +79,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 @@ -90,11 +91,24 @@ 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 GHC.Stack.Profiler as Profiler +#endif #if defined(EVENTLOG_SOCKET) import GHC.Eventlog.Socket #endif +runWithStackProfiler :: IO () -> IO () +runWithStackProfiler act = +#if defined(SAMPLE_TRACER) + Profiler.setupRootStackProfiler True $ \manager -> do + Profiler.withStackProfiler manager (Profiler.SampleIntervalMs 10) $ do + act +#else + act +#endif + ----------------------------------------------------------------------------- -- ToDo: @@ -166,7 +180,8 @@ main = do ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode -> - main' postLoadMode units dflags argv3 flagWarnings + reifyGhc $ \session -> runWithStackProfiler $ + reflectGhc (main' postLoadMode units dflags argv3 flagWarnings) session main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn] -> Ghc () ===================================== ghc/ghc-bin.cabal.in ===================================== @@ -32,6 +32,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: GHC2024 @@ -50,6 +55,10 @@ Executable ghc ghc-boot == @ProjectVersionMunged@, ghc == @ProjectVersionMunged@ + if flag(sampleTracer) + build-depends: ghc-stack-profiler + CPP-OPTIONS: -DSAMPLE_TRACER + if os(windows) Build-Depends: Win32 >= 2.3 && < 2.15 else ===================================== hadrian/src/Packages.hs ===================================== @@ -14,6 +14,7 @@ module Packages ( lintersCommon, lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace, eventlogSocket, eventlogSocketControl, ghcPackages, isGhcPackage, + async, hashable, unorderedContainers, ghc_stack_profiler, ghc_stack_profiler_core, -- * Package information crossPrefix, programName, nonHsMainPackage, programPath, timeoutPath, @@ -45,7 +46,9 @@ ghcPackages = , timeout , eventlogSocketControl, eventlogSocket , lintersCommon - , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace ] + , lintNotes, lintCodes, lintCommitMsg, lintSubmoduleRefs, lintWhitespace + , async, hashable, unorderedContainers, ghc_stack_profiler_core, ghc_stack_profiler + ] -- TODO: Optimise by switching to sets of packages. isGhcPackage :: Package -> Bool @@ -139,6 +142,11 @@ win32 = lib "Win32" xhtml = lib "xhtml" eventlogSocket = lib "eventlog-socket" `setPath` "eventlog-socket/eventlog-socket" eventlogSocketControl = lib "eventlog-socket-control" `setPath` "eventlog-socket/eventlog-socket-control" +async = lib "async" +hashable = lib "hashable" +unorderedContainers = lib "unordered-containers" +ghc_stack_profiler = lib "ghc-stack-profiler" `setPath` "ghc-stack-profiler/ghc-stack-profiler" +ghc_stack_profiler_core = lib "ghc-stack-profiler-core" `setPath` "ghc-stack-profiler/ghc-stack-profiler-core" lintersCommon = lib "linters-common" `setPath` "linters/linters-common" lintNotes = linter "lint-notes" ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -184,6 +184,11 @@ stage1Packages = do , unlit , xhtml , if winTarget then win32 else unix + , ghc_stack_profiler + , ghc_stack_profiler_core + , async + , hashable + , unorderedContainers ] , when (not cross) [ hpcBin ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -132,6 +132,7 @@ packageArgs = do , builder (Cabal Flags) ? mconcat [ (expr (ghcWithInterpreter stage)) `cabalFlag` "internal-interpreter" , notStage0 `cabalFlag` "eventlog-socket" + , notStage0 `cabalFlag` "sampleTracer" , ifM stage0 -- We build a threaded stage 1 if the bootstrapping compiler -- supports it. ===================================== libraries/async ===================================== @@ -0,0 +1 @@ +Subproject commit d5fdfb9117a983a3f07b213a8a4f8b1256a80f8c ===================================== libraries/hashable ===================================== @@ -0,0 +1 @@ +Subproject commit 535d33ef02bcabd06758f0ec6920ff9c02ef158f ===================================== libraries/unordered-containers ===================================== @@ -0,0 +1 @@ +Subproject commit 207901b4ded4799e41e0d4d45c3b198424ea4d17 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d2f9b80ed945fc38befbb9db355605… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3d2f9b80ed945fc38befbb9db355605… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Refactor FunResCtxt a bit
by Marge Bot (＠marge-bot) 07 Apr '26

07 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00 Refactor FunResCtxt a bit Fixes #27154 - - - - - 5 changed files: - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Zonk/TcType.hs Changes: ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7710,12 +7710,8 @@ pprHsCtxt = \case PatSigErrCtxt sig_ty res_ty -> vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ] - where - -- Zonking will have turned Infer into Check - pp_res_ty = case res_ty of - Check ty -> ppr ty - Infer ir -> text "OOPS" <+> ppr ir + , nest 2 (hang (text "fits the type of its context:") + 2 (ppr (getCheckExpType res_ty))) ] PatCtxt pat -> hang (text "In the pattern:") 2 (ppr pat) @@ -7777,7 +7773,7 @@ pprHsCtxt = \case full_herald = pprExpectedFunTyHerald herald <+> speakNOf n_vis_args_in_call (text "visible argument") -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic - FunResCtxt fun n_val_args res_fun res_env n_fun n_env + FunResCtxt fun n_val_args fun_res_ty env_ty | -- Check for too few args -- fun_tau = a -> b, res_tau = Int n_fun > n_env @@ -7801,6 +7797,18 @@ pprHsCtxt = \case -> empty -- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env] where + -- See Note [Splitting nested sigma types in mismatched + -- function types] + -- env_ty is an ExpRhoTy, but with simple subsumption it + -- is not /deeply/ skolemised, so still use tcSplitNestedSigmaTys + + (_,_,fun_tau) = tcSplitNestedSigmaTys fun_res_ty + (_, _, env_tau) = tcSplitNestedSigmaTys (getCheckExpType env_ty) + (args_fun, res_fun) = tcSplitFunTys fun_tau + (args_env, res_env) = tcSplitFunTys env_tau + n_fun = length args_fun + n_env = length args_env + not_fun ty -- ty is definitely not an arrow type, -- and cannot conceivably become one = case tcSplitTyConApp_maybe ty of ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Builtin.Names import GHC.Driver.DynFlags import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic import GHC.Data.Maybe @@ -961,7 +960,8 @@ See Note [-fno-code mode]. * * ********************************************************************* -} -addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] +addFunResCtxt :: HasDebugCallStack + => HsExpr GhcTc -> [HsExprArg p] -> TcType -> ExpRhoType -> TcM a -> TcM a -- When we have a mis-match in the return type of a function @@ -969,33 +969,10 @@ addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] -- But not in generated code, where we don't want -- to mention internal (rebindable syntax) function names addFunResCtxt fun args fun_res_ty env_ty thing_inside - = do { env_tv <- newFlexiTyVarTy liftedTypeKind - ; dumping <- doptM Opt_D_dump_tc_trace - ; msg <- mk_msg dumping env_tv - ; addErrCtxt msg thing_inside } + = addErrCtxt (FunResCtxt fun (count isValArg args) fun_res_ty env_ty) $ + thing_inside -- NB: use a landmark error context, so that an empty context -- doesn't suppress some more useful context - where - mk_msg dumping env_tv - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; env' <- case mb_env_ty of - Just env_ty -> return env_ty - Nothing -> do { massert dumping; return env_tv } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res_ty - (_, _, env_tau) = tcSplitNestedSigmaTys env' - -- env_ty is an ExpRhoTy, but with simple subsumption it - -- is not deeply skolemised, so still use tcSplitNestedSigmaTys - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - info = - FunResCtxt fun (count isValArg args) res_fun res_env - (length args_fun) (length args_env) - ; return info } - {- Note [Splitting nested sigma types in mismatched function types] ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -251,7 +251,10 @@ data HsCtxt -- | In the instance type signature of a class method. | MethSigCtxt !Name !TcType !TcType -- | In a pattern type signature. + | PatSigErrCtxt !TcType !ExpType + -- ExpType: see Note [ExpType in HsCtxt] + -- | In a pattern. | PatCtxt !(Pat GhcRn) -- | In a pattern synonym declaration. @@ -268,7 +271,10 @@ data HsCtxt -- | In a function call. | FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int -- | In the result of a function call. - | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int + + | FunResCtxt !(HsExpr GhcTc) !Int !TcType !ExpType + -- ExpType: see Note [ExpType in HsCtxt] + -- | In the declaration of a type constructor. | TyConDeclCtxt !Name !(TyConFlavour TyCon) -- | In a type or data family instance (or default instance). @@ -377,3 +383,14 @@ isHsCtxtLandmark (DerivBindCtxt{}) = True isHsCtxtLandmark (FunResCtxt{}) = True isHsCtxtLandmark (VDQWarningCtxt{}) = True isHsCtxtLandmark _ = False + +{- Note [ExpType in HsCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A couple of HsCtxt constructors have ExpTypes in them. When zonking the +Infer{} case we read the hole, which should be filled in by now, and zonk +that type. Now we want to put it back: we use (Check ty') for this, so that +clients of a zonked HsCtxt don't need to be monadic. + +Result: after zonking, these ExpTypes are always (Check ty). It woudl be nice +to guarantee this statically, but it's hard to do so. +-} ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Tc.Utils.TcType ( ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..), ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR, ExpRhoType, ExpRhoTypeFRR, - mkCheckExpType, + mkCheckExpType, getCheckExpType, checkingExpType_maybe, checkingExpType, ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType, @@ -440,11 +440,12 @@ data InferInstFlag -- Specifies whether the inference should return an uninstan | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top) -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole - -- Typically used when inferring the type of an expression + -- Used only for view patterns; see Note [View patterns and polymorphism] | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption) -- If DeepSubsumption is off, same as IIF_ShallowRho -- If DeepSubsumption is on, instantiate deeply before filling the hole + -- Typically used when inferring the type of an expression type ExpSigmaType = ExpType type ExpRhoType = ExpType @@ -490,6 +491,12 @@ instance Outputable InferResult where mkCheckExpType :: TcType -> ExpType mkCheckExpType = Check +getCheckExpType :: HasDebugCallStack => ExpType -> TcType +-- Expect a (Check ty). +-- See Note [ExpType in HsCtxt] in GHC.Tc.Types.ErrCtxt +getCheckExpType (Check ty) = ty +getCheckExpType (Infer ir) = pprPanic "getCheckExpType" (ppr ir) + -- | Returns the expected type when in checking mode. checkingExpType_maybe :: ExpType -> Maybe TcType checkingExpType_maybe (Check ty) = Just ty ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -818,19 +818,26 @@ zonkTidyHsCtxt env e@(FunAppCtxt{}) = return (env, e) zonkTidyHsCtxt env (FunTysCtxt ctxt ty i1 i2) = do (env', ty') <- zonkTidyTcType env ty return $ (env', FunTysCtxt ctxt ty' i1 i2) -zonkTidyHsCtxt env (FunResCtxt e i1 ty1 ty2 i2 i3) = do - (env', ty1') <- zonkTidyTcType env ty1 - (env', ty2') <- zonkTidyTcType env' ty2 - return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3) +zonkTidyHsCtxt env (FunResCtxt e n ty1 env_ty) = do + (env', ty1') <- zonkTidyTcType env ty1 + (env', env_ty') <- zonkExpType env' env_ty + return $ (env', FunResCtxt e n ty1' env_ty') zonkTidyHsCtxt env (PatSigErrCtxt sig_ty res_ty) = do (env', sig_ty') <- zonkTidyTcType env sig_ty - (env', res_ty') <- - case res_ty of - Check ty -> zonkTidyTcType env' ty - Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops - mb_ty <- liftIO $ readIORef ref - case mb_ty of - Nothing -> error "zonkTidyHsCtxt PatSigErrCtxt" - Just ty -> zonkTidyTcType env' ty - return (env', PatSigErrCtxt sig_ty' (Check res_ty')) + (env', res_ty') <- zonkExpType env' res_ty + return (env', PatSigErrCtxt sig_ty' res_ty') zonkTidyHsCtxt env p = return (env, p) + +zonkExpType :: TidyEnv -> ExpType -> ZonkM (TidyEnv, ExpType) +-- Zonk Infer{} to Check. The hole should have been filled in by now +zonkExpType env (Check ty) + = do { (env', ty') <- zonkTidyTcType env ty + ; return (env', Check ty') } +zonkExpType env (Infer ir@(IR { ir_ref = ref })) + = do { -- inlining readExpTyp_maybe to avoid module dep loops + ; mb_ty <- liftIO $ readIORef ref + ; case mb_ty of + Nothing -> pprPanic "zonkTidyHsCtxt PatSigErrCtxt" (ppr ir) + Just ty -> do { (env', ty') <- zonkTidyTcType env ty + ; return (env', Check ty') } } + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b21bd52e0b69c8108ef6477c34923ed… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b21bd52e0b69c8108ef6477c34923ed… You're receiving this email because of your account on gitlab.haskell.org.

1 0