September 2026 - ghc-commits

[Git][ghc/ghc][wip/mangoiv/ci-stages] fixup! ci: stop using ellipses in testsuite output and output env before invoking hadrian
by Magnus (＠MangoIV) 02 Sep '26

02 Sep '26

Magnus pushed to branch wip/mangoiv/ci-stages at Glasgow Haskell Compiler / GHC Commits: 83ea0fb6 by mangoiv at 2026-09-02T18:32:17+02:00 fixup! ci: stop using ellipses in testsuite output and output env before invoking hadrian - - - - - 1 changed file: - .gitlab/ci.sh Changes: ===================================== .gitlab/ci.sh ===================================== @@ -968,7 +968,7 @@ function run_hadrian() { if [ -n "${VERBOSE:-}" ]; then args+=("-V"); fi # Before running the compiler, unset variables gitlab env vars as these # can destabilise the performance test (see #20341) - (unset "$(compgen -v | grep CI_*)"; + (unset $(compgen -v | grep CI_*); # dump the env before running hdarian itself. start_section run_hadrian_env "env for runnning hadrian"; env; end_section run_hadrian_env run "${HADRIAN_PATH:-hadrian/build-cabal}" \ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83ea0fb65bded22f09e1421c39a3eb3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/83ea0fb65bded22f09e1421c39a3eb3… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/andrea/backport-reference
by Andrea Vezzosi (＠trac-Saizan) 02 Sep '26

02 Sep '26

Andrea Vezzosi pushed new branch wip/andrea/backport-reference at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andrea/backport-reference You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T26543b] 36 commits: Add Data.RealFloat and Infinity/NegInfinity/NaN pattern synonyms (#26961)
by Simon Peyton Jones (＠simonpj) 02 Sep '26

02 Sep '26

Simon Peyton Jones pushed to branch wip/T26543b at Glasgow Haskell Compiler / GHC Commits: b5d29ab8 by Brandon Chinn at 2026-08-25T18:42:08-04:00 Add Data.RealFloat and Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - e60eb3bc by Andreas Klebinger at 2026-08-25T18:42:59-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - e9bbe8f9 by Andreas Klebinger at 2026-08-26T15:09:23-04:00 cmm dumps: Add machop width info with -dppr-debug for infix ops. - - - - - 86e3a9d8 by Andreas Klebinger at 2026-08-26T15:09:24-04:00 CmmLint: Check for unsupported MachOp widths machOpArgReps now maps MachOp + Width to a list of supported argument widths or Nothing if the given operation is not supported at the given width. This allows us to check for nonsensical combinations like FloatToInt at Word16. Similarly we now check that every address is actually wordwidth. - - - - - 13781cca by Andreas Klebinger at 2026-08-26T15:09:24-04:00 arm64 ncg: The big subword truncation fix. A set of slightly related fixes to arm subword handling: Bitmask immediates: Don't produce overflowing assembly literals. There is still another bug here that causes us to miss some valid literals but we will fix that later. Improve subword truncation handling: We now use a small set of helpers to truncate `Register` values rather than truncating immediate `Reg` values which greatly simplifies the code structure. This fixes a great many bugs to do with sign/zero extending subwords or the lack thereof. We now establish the invariant that subword values are zero-extended at every site at which they come into "scope" of the ncg, and rely on the invariant throughout rather than pessimistically inserting redundant extensions in a hodgepodge manner at the use sites of these values. This fixes at least the bugs described in issues #27533, #27430 #27537, #27538, #27539, and #27550. But likely more bugs yet not found. Subword ffi results: Apply truncations when calling functions returning subword values. genCondJump: Don't sign extend signed values in the input register as it might map to a local variable, corrupting the value stored within. Fix subword store/load instructions.: We used to read those at 32bit width even for smaller values possibly resulting in invalid memory access. Now we construct the suffix for subword variants based on the instruction format for these. - - - - - d8fa5d7c by Andreas Klebinger at 2026-08-26T15:09:24-04:00 arm64 ncg: Fix MO_V_Broadcast for non-literals. We now use OpReg instead of OpScalarAsVec as required since we broadcast a gp register. Also adds a test. Fixes #27565. - - - - - 94822c95 by Andreas Klebinger at 2026-08-26T15:09:24-04:00 Add some test cases covering bugs in the arm ncg. * Test for #27430 (subword ffi results) * #27537 - subword conversions * #27538 - subwords used in conditional * #27533 - single byte read - - - - - dd1ba88a by Andreas Klebinger at 2026-08-26T15:09:24-04:00 cmmLint: Lint against MO_FS_Truncate subword use. - - - - - fd22f71e by Zubin Duggal at 2026-08-26T15:10:20-04:00 ghc-internal: annotateSTM should use catchSTM# rather than catch# A catch# frame inside a transaction breaks retry and async exception delivery. Fixes #27657 - - - - - bb324171 by Rodrigo Mesquita at 2026-08-26T15:10:59-04:00 rts: refactor to reduce THREADED_RTS in MSG_UPD_TSO_FLAGS - No behavior change in this commit (well, a small optimization here makes us do less work if the target TSO owned by the curr. capability) - Move all THREADED_RTS CPP needed into `updThreadFlag` - Merge MSG_SET_TSO_FLAGS and MSG_UNSET_TSO_FLAGS into MSG_UPD_TSO_FLAGS plus a `set` bool field in the MessageUpdTSOFlag struct Towards #27729 - - - - - ed99b7b7 by Rodrigo Mesquita at 2026-08-26T15:10:59-04:00 rts: Fix race condition in MSG_UPD_TSO_FLAGS execution The code for processing the MSG_UPD_TSO_FLAGS message was not taking into consideration that the TSO's owner might have moved in between that capability receiving the message (since it was its previous owner) and starting to process its inbox (a point at which it was no longer the owner) Added Note [TSO owner may change in between Msg being sent and received] to explain this race and the pattern used to fix this, where we just forward the message to the new owner. Fixes #27729 - - - - - cd653714 by Alan Zimmerman at 2026-08-26T15:11:49-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - d1d01fa5 by Wolfgang Jeltsch at 2026-08-27T13:17:59+03:00 Add `rethrowSTM` and improve STM-related documentation Adding `rethrowSTM` resolves #26758. The implementation of `rethrowSTM` is completely analogous to the one of `rethrowIO`. The following is established for the documentation of `throwSTM` and `catchSTM`: * Both operations are directly described as analogs of their `IO` counterparts. * There is no reference to `throw` in the documentation of `throwSTM`, because, although such a reference is great in the documentation of `throwIO`, it is somewhat out of place in the documentation of `throwSTM`. * Instead of repeating part of `throwIO`’s documentation, the documentation of `throwSTM` just recommends using `throwSTM` instead of `throw` and references the corresponding arguments in the documentation of `throwIO`. - - - - - 06fde293 by fendor at 2026-08-28T06:06:44-04:00 GHCi: Fix order of `PackageDBFlag`s for interactive home unit `PackageDBFlag`s are stored in reverse order of cli specification. When sorting the `PackageDBFlag`s by longest common prefix, we need thus to reverse the package db stacks before calculating the prefix. We make sure to reverse the package db stack for the interactive home unit to uphold that later specified package dbs overwrite earlier ones. Resolved and adds regression test for #27640 - - - - - 024c4d04 by fendor at 2026-08-28T06:07:23-04:00 Reuse the UnitIndexCache after initialising multiple home units - - - - - 55326fa0 by Alan Zimmerman at 2026-08-28T06:08:03-04:00 EPA: Some Haddock processing tweaks These changes to the Haddock postprocessing should not change behaviour, but just bring it more closely in line with the original, changed at 44309cd377f And add some haddock exactprint tests to show they work. - - - - - b3ddee95 by Andreas Klebinger at 2026-08-28T13:57:46-04:00 hadrian: Deprecate quickest flavour. It was more of a trap for new users than actually beneficial so we deprecate it and suggest quick+no_dynamic_libs to users instead. - - - - - a1d81390 by Andreas Klebinger at 2026-08-28T13:58:37-04:00 cmm: Always favour entry block during block deduplication. We now always keep the first block in the CmmGraph. This way we avoid the need to update the entry info table. Failing to do so caused #27722. Fixes #27722. - - - - - 5bd65f00 by Andreas Klebinger at 2026-08-28T13:59:16-04:00 test: FamAppCachePerf - Only collect bytes allocated. Fixes 27747 - - - - - ced53ce6 by mangoiv at 2026-08-29T07:15:24-04:00 nightlies: output yaml to file only Previously we would just output the metadata to stdout which risks that it's clobbered by incidental debugt output. We now output to file only. Fixes #27511 - - - - - 578bd185 by Andreas Klebinger at 2026-08-29T07:16:05-04:00 Specialise: Stop looping on recursive dictionaries in interestingDict interestingDict now doesn't look through loopbreaker unfoldings. Doing so would cause infinite loops on certain dictionaries. Fixes #27705. - - - - - 7bf546fc by Simon Peyton Jones at 2026-08-31T23:48:53-04:00 Never make an absent filler for a constraint type mkAbsentFiller used isTerminatingType to decide, but that is not enough. Consider class Eq a => UC a where {} let u :: UC Int -- UC Int is a "non-terminating type" u = error "Absent" let e :: Eq Int -- Eq Int is a "terminating type" e = $p1UC u We clearly must not make a filler for `e`, because we speculatively evaluate it. But speculatively evaluating `e` forces `u`, so we must not make one for `u` either. Asking isDictTy instead is not enough either, because it does not catch a constraint hidden behind an unreduced type family application: type family F a :: Constraint type instance F W = TC W a :: F W => Int -> Int -- (F W) argument is absent Oops! Entered absent arg Arg: irred Type: F W So play safe and use isPredTy: never make an absent filler for any constraint-kinded type. Fixes #27627 - - - - - 5f474953 by Zubin Duggal at 2026-08-31T23:48:53-04:00 Add tests for absent fillers at dictionary types T27627 a unary class whose superclass is a non-unary class T27627a ...whose superclass is a Constraint-kinded type family T27627b ...whose superclass is a quantified constraint T27627c a unary class applied to itself, (UC (UC (TC a))) T27627e a (forall b. P b) dictionary that loops - - - - - cd5c6bcc by Zubin Duggal at 2026-08-31T23:48:53-04:00 An abstract TyCon may hide a unary class A class declared in an hs-boot file is an AbstractTyCon inside the module loop, and compiling the real declaration may reveal it to be a UnaryClassTyCon. - isTerminatingType returned True for such AbstractTyCons - IfaceToCore set the unary flag to False in the DFunId So we could end up speculating bottom dictionaries because inside a module loop we see an UnaryClassTyCon as an AbstractTyCon Use isTerminatingTyCon, which returns False for an abstract TyCon. The Bool in DFunId is now a cache for isTerminatingTyCon, set in mkDFunIdDetails. Fixes #27704 - - - - - abfc224a by Zubin Duggal at 2026-08-31T23:48:53-04:00 Specialise: don't replace dead args with absent fillers specHeader decides an argument is dead by calling isDeadBinder on a binder of the /optimised RHS/, then applies the filler to the /stable unfolding/ template instead. The two may differ, so the argument can be dead in the RHS and not in the template. The specialised function's unfolding then has an absent filler, and any call site that inlines it evaluates the error thunk. Dropping dead args in the specialiser is rarely worth it, to quote Simon, "The later worker/wrapper pass will pick up the dead arg later if it is really dead. Keeps the specialiser simpler." So instead of trying to check if the arg really is dead in the stable unfolding, just drop the logic for dropping dead args in the specialiser altogeher. Fixes #27703 - - - - - 1557fd1c by Zubin Duggal at 2026-08-31T23:48:53-04:00 CorePrep: don't speculate a call across an hs-boot edge We take care not to evaluate things that might be bottom, like a looping dictionary group, but our analysis is defeated by boot files. We only track recursion within a module, so two dictionaries that depend on each other across a module loop each look non-recursive, and we might speculate them. Any recursion we cannot see must cross an hs-boot edge, so refuse to speculate calls that cross one. Fixes #27717 - - - - - 4117e5ae by Wolfgang Jeltsch at 2026-08-31T23:49:35-04:00 Incorporate the `rethrowSTM` reexport into the `stm` submodule - - - - - 4bfbf5c8 by ARATA Mizuki at 2026-09-01T18:55:08-04:00 testsuite: Fix out-of-bounds access in T3586 unsafeRead and unsafeWrite use 0-based index. Looking at #3586, the expected output seems to be 2.8e8. Addresses #27596 - - - - - 3f9db6d4 by ARATA Mizuki at 2026-09-01T18:55:08-04:00 testsuite: Fix out-of-bounds access in T21305 writeInt64Array# takes an index measured in units of Int64 elements. Fixes #27596 - - - - - 44d7788f by Simon Peyton Jones at 2026-09-01T18:55:53-04:00 Fix buglet in INLINE-arity calculation for pattern synonyms This fixes #27744. The buglet was accidentally introduced by commit 3a0f9a51c1dacc474c7fd128082edd8bf4081256 Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com> Date: Sat Aug 1 00:13:02 2026 +0100 Fix three bugs related to required type args and INLINE pragmas I failed to find all the calls to `addInlinePragArity`! - - - - - df058f1d by Simon Jakobi at 2026-09-02T07:18:06-04:00 testsuite: Migrate perf tests off collect_compiler_stats('all') The 'all' metric argument applies a single tolerance to bytes allocated, max_bytes_used and peak_megabytes_allocated, although their noise profiles are incompatible (#27653): allocations are nearly deterministic, residency needs 10-20%, and peak is quantized to 1 MB. Any single tolerance is too tight for one metric or too slack for another. This migrates the remaining users of 'all' (and of the 'all' default) to explicit per-metric collection, ahead of removing 'all' from the driver. peak_megabytes_allocated is dropped everywhere: its 1 MB granularity makes tight relative windows meaningless (#27613), and it is sensitive to GC timing. In #27489 it drifted by -5.3% while max_bytes_used moved by less than 0.1%. Where a test guards a memory property, max_bytes_used covers it at byte granularity. Where the motivating ticket was about compile-time memory (T11545, T15304, T26425), residency remains gated via max_bytes_used, now with a residency-appropriate tolerance. max_bytes_used is dropped where residency was only ever an accident of 'all': * T15630, T15630a, T20261: the underlying tickets (#15630, #20261) contain no memory data at all. One is a simplifier-ticks blowup and the other is stated entirely in allocation numbers, so the 20% window never had teeth. * T21839c: #21839's measurements show residency essentially flat (+0.16%) while allocations moved +7%, so allocations are the discriminating metric. They are already gated at 1% via collect_compiler_runtime. The ghc/max gate had previously broken CI spuriously (9fd11585eb widened it from 1% to 10% for that reason). Allocation tolerances are tightened to the testsuite's conventional 2% where 'all' previously left them at 10-20%. Assisted-by: Claude Fable 5 - - - - - 72dd2432 by Simon Jakobi at 2026-09-02T07:18:06-04:00 testsuite: Remove the 'all' metric argument of collect_stats 'all' gated bytes allocated, max_bytes_used and peak_megabytes_allocated at a single tolerance, although their noise profiles are incompatible, making such tests either flaky or toothless (#27653). Closes #27653. Assisted-by: Claude Fable 5 - - - - - 2228cb30 by Simon Jakobi at 2026-09-02T07:18:06-04:00 testsuite: Make the deviation argument of collect_stats mandatory Almost every caller passes an explicit tolerance matched to the metric's noise profile, and the silent 20% default is far slacker than 'bytes allocated' merits. Only two tests relied on it. They now state their tolerance explicitly: large-project gets 10%, in line with other large compile-time tests. T9848 gets 2%: its metric is byte-for-byte deterministic across CI jobs and platforms of a given test_env, has drifted only about 2.5% since 2015, and the fusion failure it guards against would show up as a roughly +30000% jump. Assisted-by: Claude Fable 5 - - - - - 56291fc5 by Cheng Shao at 2026-09-02T07:18:45-04:00 autoconf/ghc-toolchain: bump llvm upper bound to support llvm 23 This commit bumps llvm upper bound to support llvm 23. - - - - - 20eb3f41 by Cheng Shao at 2026-09-02T07:18:45-04:00 rts: fix compilation issues with clang 23 clang 23 has broadened `-Wall`/`-Wextra` ranges, exposing some minor issues in the rts when building with validate flavours: - Unused locals - `#pragma GCC diagnostic pop` mismatch This commit fixes those. - - - - - 18d57c95 by Simon Peyton Jones at 2026-09-02T17:06:38+01:00 Line up simpleUnifyCheck and check_ty_eq_rhs Even after #26543 was allegedly fixed, the original repo case in the Description continued to fail. The reason was that the QuickLook unifier, `qlUnify`, used `simpleUnifyCheck` for checking unification invariants; and `simpleUnifyCheck` conservatively rejected any RHS with a coercion hole in it. The upshot was that QuickLook was not as clever as it should be, wrongly failing to do an impredicative instantiation. Interestingly `check_ty_eq_rhs`, which does the same job, only during constraint solving, was more liberal: it just looked at the free vars of the coercion, and allowed coercion holes. This MR lines them up, adding some careful notes. See Note [simpleUnifyCheck] esp (SUC1) Note [Unification preconditions] esp (COERCIONS) Things are better than before, but I am still uncomfortable about the possibilty that a hole might be filled with a coercion that mentions the LHS type variable; for now I have left this discomfort documented in (SUC1). - - - - - 193 changed files: - .gitlab-ci.yml - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - + changelog.d/27627 - + changelog.d/27703 - + changelog.d/27704 - + changelog.d/27717 - + changelog.d/T26543 - changelog.d/T27202 - + changelog.d/T27657 - + changelog.d/T27705 - + changelog.d/T27722-cbe-entry-block.md - + changelog.d/T27744 - + changelog.d/arm_ncg_fixes_T27430 - + changelog.d/llvm-23 - + changelog.d/rethrow-stm - changelog.d/unit-index - compiler/GHC/Cmm/CommonBlockElim.hs - compiler/GHC/Cmm/Expr.hs - compiler/GHC/Cmm/Lint.hs - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/Core/Type.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Types/Demand.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Literal.hs - configure.ac - ghc/GHCi/UI.hs - hadrian/README.md - hadrian/doc/cross-compile.md - hadrian/doc/flavours.md - hadrian/doc/make.md - hadrian/doc/windows.md - hadrian/hadrian.cabal - hadrian/src/CommandLine.hs - hadrian/src/Flavour.hs - hadrian/src/Settings.hs - − hadrian/src/Settings/Flavours/Quickest.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/Data/RealFloat.hs - libraries/base/src/GHC/Conc.hs - libraries/base/tests/all.T - libraries/ghc-internal/src/GHC/Internal/STM.hs - libraries/stm - rts/CloneStack.c - rts/Interpreter.c - rts/Messages.c - rts/ProfHeap.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/eventlog/EventLog.c - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - rts/linker/elf_reloc_riscv64.c - rts/prim/atomic.c - testsuite/driver/README.md - testsuite/driver/testlib.py - testsuite/tests/cmm/should_compile/Makefile - + testsuite/tests/cmm/should_compile/T27368-ppr-debug.stderr - − testsuite/tests/cmm/should_compile/T27368-ppr-debug.stdout - testsuite/tests/cmm/should_compile/all.T - + testsuite/tests/codeGen/should_run/T27430.hs - + testsuite/tests/codeGen/should_run/T27430.stdout - + testsuite/tests/codeGen/should_run/T27430_c.c - + testsuite/tests/codeGen/should_run/T27533.hs - + testsuite/tests/codeGen/should_run/T27533.stdout - + testsuite/tests/codeGen/should_run/T27533_cmm.cmm - + testsuite/tests/codeGen/should_run/T27537.hs - + testsuite/tests/codeGen/should_run/T27537.stdout - + testsuite/tests/codeGen/should_run/T27538.hs - + testsuite/tests/codeGen/should_run/T27538.stdout - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/concurrent/should_run/T27657a.hs - + testsuite/tests/concurrent/should_run/T27657a.stdout - + testsuite/tests/concurrent/should_run/T27657b.hs - + testsuite/tests/concurrent/should_run/T27657b.stdout - testsuite/tests/concurrent/should_run/all.T - + testsuite/tests/core-to-stg/T27627/Callee.hs - + testsuite/tests/core-to-stg/T27627/Caller.hs - + testsuite/tests/core-to-stg/T27627/Main.hs - + testsuite/tests/core-to-stg/T27627/T27627.stdout - + testsuite/tests/core-to-stg/T27627/all.T - + testsuite/tests/core-to-stg/T27627a/Callee.hs - + testsuite/tests/core-to-stg/T27627a/Caller.hs - + testsuite/tests/core-to-stg/T27627a/Main.hs - + testsuite/tests/core-to-stg/T27627a/T27627a.stdout - + testsuite/tests/core-to-stg/T27627a/all.T - + testsuite/tests/core-to-stg/T27627b/Callee.hs - + testsuite/tests/core-to-stg/T27627b/Caller.hs - + testsuite/tests/core-to-stg/T27627b/Main.hs - + testsuite/tests/core-to-stg/T27627b/T27627b.stdout - + testsuite/tests/core-to-stg/T27627b/all.T - + testsuite/tests/core-to-stg/T27627c/Callee.hs - + testsuite/tests/core-to-stg/T27627c/Caller.hs - + testsuite/tests/core-to-stg/T27627c/Main.hs - + testsuite/tests/core-to-stg/T27627c/T27627c.stdout - + testsuite/tests/core-to-stg/T27627c/all.T - + testsuite/tests/core-to-stg/T27627e.hs - + testsuite/tests/core-to-stg/T27627e.stdout - + testsuite/tests/core-to-stg/T27627f/Callee.hs - + testsuite/tests/core-to-stg/T27627f/Caller.hs - + testsuite/tests/core-to-stg/T27627f/Inst.hs - + testsuite/tests/core-to-stg/T27627f/Main.hs - + testsuite/tests/core-to-stg/T27627f/T27627f.stdout - + testsuite/tests/core-to-stg/T27627f/all.T - + testsuite/tests/core-to-stg/T27704/Callee.hs - + testsuite/tests/core-to-stg/T27704/Callee.hs-boot - + testsuite/tests/core-to-stg/T27704/Main.hs - + testsuite/tests/core-to-stg/T27704/Mid.hs - + testsuite/tests/core-to-stg/T27704/T27704.stdout - + testsuite/tests/core-to-stg/T27704/all.T - + testsuite/tests/core-to-stg/T27704a/Callee.hs - + testsuite/tests/core-to-stg/T27704a/Callee.hs-boot - + testsuite/tests/core-to-stg/T27704a/Main.hs - + testsuite/tests/core-to-stg/T27704a/Mid.hs - + testsuite/tests/core-to-stg/T27704a/T27704a.stdout - + testsuite/tests/core-to-stg/T27704a/all.T - + testsuite/tests/core-to-stg/T27717/Callee.hs - + testsuite/tests/core-to-stg/T27717/Callee.hs-boot - + testsuite/tests/core-to-stg/T27717/Main.hs - + testsuite/tests/core-to-stg/T27717/Mid.hs - + testsuite/tests/core-to-stg/T27717/T27717.stdout - + testsuite/tests/core-to-stg/T27717/Ty.hs - + testsuite/tests/core-to-stg/T27717/all.T - testsuite/tests/core-to-stg/all.T - testsuite/tests/ffi/should_run/T21305.hs - + testsuite/tests/ghci/prog-mhu007/Makefile - + testsuite/tests/ghci/prog-mhu007/a/A.hs - + testsuite/tests/ghci/prog-mhu007/all.T - + testsuite/tests/ghci/prog-mhu007/b/B.hs - + testsuite/tests/ghci/prog-mhu007/prog-mhu007.script - + testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout - + testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs - + testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg - + testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs - + testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg - + testsuite/tests/ghci/prog-mhu007/unitA - + testsuite/tests/ghci/prog-mhu007/unitB - 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/patsyn/should_compile/T27744.hs - testsuite/tests/patsyn/should_compile/all.T - testsuite/tests/perf/compiler/all.T - testsuite/tests/perf/compiler/large-project/all.T - testsuite/tests/perf/should_run/T3586.hs - testsuite/tests/perf/should_run/T3586.stdout - testsuite/tests/perf/space_leaks/all.T - + testsuite/tests/printer/Haddock1.hs - testsuite/tests/printer/Makefile - testsuite/tests/printer/all.T - + testsuite/tests/simd/should_run/T27565.hs - + testsuite/tests/simd/should_run/T27565.stdout - testsuite/tests/simd/should_run/all.T - testsuite/tests/simplCore/should_compile/T17966.stderr - testsuite/tests/simplCore/should_compile/T7785.stderr - testsuite/tests/simplCore/should_compile/spec004.hs - testsuite/tests/simplCore/should_compile/spec004.stderr - + testsuite/tests/simplCore/should_run/T27703/Lib.hs - + testsuite/tests/simplCore/should_run/T27703/Main.hs - + testsuite/tests/simplCore/should_run/T27703/T27703.stdout - + testsuite/tests/simplCore/should_run/T27703/all.T - + testsuite/tests/simplCore/should_run/T27705.hs - + testsuite/tests/simplCore/should_run/T27705.stdout - + testsuite/tests/simplCore/should_run/T27705_Inst.hs - testsuite/tests/simplCore/should_run/all.T - + testsuite/tests/typecheck/should_compile/T26543_orig.hs - testsuite/tests/typecheck/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/ghc-toolchain/src/GHC/Toolchain/Program.hs - utils/ghc-toolchain/src/GHC/Toolchain/Target.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/defc3eae2fd24582516f77f4beab0a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/defc3eae2fd24582516f77f4beab0a… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/romes/27514] 8 commits: 2-phase Cache/Search Finder monad
by sheaf (＠sheaf) 02 Sep '26

02 Sep '26

sheaf pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC Commits: f6324171 by sheaf at 2026-09-02T16:13:05+02:00 2-phase Cache/Search Finder monad This commit restructures the finder abstraction by introducing the 'FinderM' monad, which splits module lookup operations into two phases: - a cache-only phase, performing no filesystem access, - from the first cache miss onwards, a search action which may access the filesystem. This allows consumers to distinguish between quick cached results versus more expensive filesystem search operations. - - - - - c3f5bc7f by sheaf at 2026-09-02T16:13:48+02:00 Separate Home/External finder caches The caches for home modules and modules from external units have different lifetimes, needing to be invalidated at different points. This commit moves the cache for modules from external units into the 'UnitState' type, which keeps the cache correct whenever package flags or package databases change (setSessionDynFlags, :set -package ..., Backpack's addUnit). This also makes it easier to clear the cache of home modules, as they are now stored separately (obviating the 'isUnitEnvInstalledModule' check we used to perform). - - - - - 6c5848fa by sheaf at 2026-09-02T16:13:52+02:00 Add known home modules to the finder cache The finder looks in the file system for the on-disk source that corresponds to a Haskell module name. There are two kinds of modules where we need to bypass this search: - a file passed directly in the command line, which may not be in any search path and whose module name may differ from the file name; - Backpack signatures and modules, which do not exist as files at all. This commit handles these two situations by adding an immutable 'KnownHomeModules' in the finder cache, which is always consulted first before doing any search. This removes the ad-hoc imperative logic which relied on mutating the finder cache at careful points. See Note [Known home modules] in GHC.Unit.Finder.Types. - - - - - 81831dae by sheaf at 2026-09-02T16:20:05+02:00 Make 'UnresolvedImport' into a suitable cache key The goal of this commit is to make 'UnresolvedImport' suitable for use as a cache key. Specifically, during downsweep we want to be able to cache module resolution queries. We want to do this using some kind of map, e.g. (roughly speaking): Map UnresolvedImport ResolvedImport For this to work, 'UnresolvedImport' must contain **precisely** the input data to each resolution computation. In other words: 1. If something changes that materially affects resolution, it must be stored in the cache key. 2. If changing some input does not materially affect the outcome, then it must not be stored in the cache key. To satisfy (1), we change 'UnitNode' to also keeps track of the home unit in whose unit state the unit's dependencies were looked up. For (2), 'ImportResolution' now stores a 'ModuleLookupScope' instead of an 'UnresolvedImportOrigin'. Plugin imports are expressed with a new 'LookupPlugin' scope. The source location of an import, which is immaterial to the resolution, is stored out of band outside 'UnresolvedImport', in 'ModSummary'. - - - - - bd5dac9e by sheaf at 2026-09-02T16:20:05+02:00 Add GHC.Data.Dependent This commit adds a minimal implementation of dependent sums ('Some', 'DSum') and dependent maps ('DMap'). The implementation is not entirely performance optimal, as there are a few extraneous allocations compared to the full-blown implementation in the 'dependent-map' package. For our use case (caching downsweep computations), this does not matter much. See GHC.Data.Dependent. - - - - - 336c2271 by sheaf at 2026-09-02T16:20:05+02:00 Driver: structured concurrent worker abstraction This commits introduces a structured concurrency framework in the style of the 'ki' library: a collection of threads within a scope. We implement two kind of concurrent workers on top of this framework: - Independent workers cannot wait for one another at all. The only scheduling operation is to wait for quiescence. - Coordinating workers declare an STM readiness condition (waiting on other workers to complete) which gates their start. See Note [Deterministic concurrent workers] in GHC.Driver.Concurrency. This commit ports upsweep to this new framework, with downsweep being left as subsequent work. Further changes along the way: - Refactoring of how concurrency is acquired to avoid the footgun of trying to use a no-op 'AbstractSem' as a lock in the serial case. - The "re-run with -j1" logic for semaphore opening errors no longer triggers on late semaphore failures (part-way through a lengthy computation). - Logger threads are properly cleaned up on exception, with each concurrent worker's log queue and local TmpFs properly bracketed. - The 'GhcMessage -> AnyGhcDiagnostic' and 'Maybe Messager' arguments of 'depanalE', 'depanalPartial' and 'downsweep', which were all dead in practice, have been dropped. - - - - - 976bd624 by sheaf at 2026-09-02T16:20:05+02:00 Rule-based deterministic concurrent downsweep This commit rewrites downsweep as a single query-answering rule (see 'DownsweepRule') that can be executed by concurrent worker threads. The design allows every expensive operation (preprocessing files with CPP, parsing headers, reading interfaces) to be performed concurrently according to the -j<N>/-jsem flags. See Note [Rules-based downsweep] in GHC.Driver.Downsweep. The rules are run by "GHC.Driver.Concurrency.runRules" in a demand-driven way: each worker can demand other workers to run, but never wait on another worker. Every piece of work is done at most once. Fixes #27514 ------------------------- Metric Increase: MultiComponentModulesRecomp MultiComponentModulesRecomp100 ------------------------- - - - - - aafa95c3 by sheaf at 2026-09-02T16:20:05+02:00 Acquire/release semaphore tokens more readily This commit reworks GHC.Driver.MakeSem to use the scoped worker abstraction of GHC.Utils.Concurrent.Scope. This allows us to get rid of a lot of the tricky logic in GHC.Driver.MakeSem involving manual exception handling, thread spawning and lifetime management, etc. The architecture of the jobserver is rethought: instead of a single acquire thread, there are as many acquirers as there is a demand for semaphore tokens. No rate limiting for acquisition. The release debounce period was shortened from 1s to 10ms. Fixes #27763 - - - - - 61 changed files: - + changelog.d/T27763 - + changelog.d/parallel-downsweep - compiler/GHC.hs - compiler/GHC/Builtin.hs - + compiler/GHC/Data/Dependent.hs - compiler/GHC/Driver/Backpack.hs - + compiler/GHC/Driver/Concurrency.hs - + compiler/GHC/Driver/Config/Concurrency.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeAction.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/MakeSem.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/LogQueue.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Parser/Header.hs - compiler/GHC/Runtime/Interpreter/JS.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Plugin.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/UnresolvedImport.hs - compiler/GHC/Unit/Finder.hs - + compiler/GHC/Unit/Finder/Cache.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/Types.hs - + compiler/GHC/Utils/Concurrent/Scope.hs - compiler/GHC/Utils/TmpFs.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - ghc/Main.hs - linters/lint-codes/LintCodes/Static.hs - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/diagnostic-codes/codes.stdout - testsuite/tests/driver/T27461/Makefile - + testsuite/tests/driver/T27461/T27461c.stderr - testsuite/tests/driver/T27461/all.T - + testsuite/tests/driver/T27461/src/Wrong.hs - testsuite/tests/ghc-api/downsweep/IncrementalDownsweep.hs - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs - testsuite/tests/splice-imports/SI35.hs - utils/check-ppr/Main.hs - utils/haddock/haddock-api/src/Haddock/Interface.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50993664e6fa6f5faed8a7dcc46081… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50993664e6fa6f5faed8a7dcc46081… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/has-field-hie] 3 commits: Give each getField in a projection section its field label's SrcSpan
by Hannes Siebenhandl (＠fendor) 02 Sep '26

02 Sep '26

Hannes Siebenhandl pushed to branch wip/fendor/has-field-hie at Glasgow Haskell Compiler / GHC Commits: 7514547d by Your Name at 2026-09-02T11:44:05+00:00 Give each getField in a projection section its field label's SrcSpan Co-Authored-By: Claude Opus 5 <noreply(a)anthropic.com> - - - - - 68ec7739 by Your Name at 2026-09-02T11:45:30+00:00 hie: report record selectors, not class dictionary constructors, as evidence Co-Authored-By: Claude Opus 5 <noreply(a)anthropic.com> - - - - - aec841af by fendor at 2026-09-02T14:47:06+02:00 Add regression test for record dot err ctx - - - - - 7 changed files: - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/Expr.hs - testsuite/tests/hiefile/should_run/HasFieldQueries.hs - testsuite/tests/hiefile/should_run/HasFieldQueries.stdout - + testsuite/tests/overloadedrecflds/should_fail/RecordDotErrCtxt.hs - + testsuite/tests/overloadedrecflds/should_fail/RecordDotErrCtxt.stderr - testsuite/tests/overloadedrecflds/should_fail/all.T Changes: ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -22,11 +22,11 @@ import GHC.Core.Utils (exprType) import GHC.Core.TyCo.Rep (Type(TyConApp)) import GHC.Core.TyCon (TyCon(..)) import GHC.Core.ConLike ( conLikeName ) -import GHC.Core.DataCon ( dataConWrapperType ) +import GHC.Core.DataCon ( dataConWrapperType, dataConTyCon ) import GHC.Core.Type ( Type, ForAllTyFlag(..) ) -import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) +import GHC.Core.TyCon ( TyCon, tyConClass_maybe, isClassTyCon ) import GHC.Core.InstEnv -import GHC.Core.Predicate ( isEvId ) +import GHC.Core.Predicate ( isEvId, getClassPredTys_maybe ) import GHC.Hs import GHC.Hs.Syn.Type @@ -36,12 +36,12 @@ import GHC.Types.Basic import GHC.Types.UnresolvedImport ( isGeneratedImport ) import GHC.Types.FieldLabel import GHC.Types.Avail ( Avails ) -import GHC.Types.Id ( isDataConId_maybe ) +import GHC.Types.Id ( isDataConId_maybe, isRecordSelector ) import GHC.Types.Name ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe, getName, hasKnownKey ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.Name.Reader ( RecFieldInfo(..), WithUserRdr(..) ) import GHC.Types.SrcLoc -import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) +import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique, isId ) import GHC.Types.Var.Env import GHC.Types.Var.FV @@ -684,9 +684,73 @@ instance ToHie (Context (Located Name)) where instance ToHie (Context (Located (WithUserRdr Name))) where toHie (C c (L l (WithUserRdr _ n))) = toHie $ C c (L l n) -hieEvIdsOfTerm :: EvTerm -> [EvId] --- Returns only EvIds satisfying relevantEvId -hieEvIdsOfTerm = runFVSelectiveList isEvId . evTermFVs +{- Note [Evidence dependencies in HIE files] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'EvBindDeps' of an 'EvLetBind' record what a dictionary was built out of, +so that a tool can answer "where does the evidence for this constraint come +from?" by walking 'getEvidenceTree' (in GHC.Iface.Ext.Utils). For that to be +useful, the dependencies have to /discriminate/ one solution from another. So +we make two adjustments to the plain free evidence variables of the right hand +side: + +(1) We drop the data constructor of a class dictionary, e.g. @C:HasField@. + These do satisfy 'isEvId', but they /construct/ a dictionary rather than + being evidence in their own right, and which one appears is already + determined by the constraint being solved. Reporting one tells a user + nothing they did not know from the constraint they hovered over, and is + actively misleading: it points into the module defining the /class/, + rather than at whatever provided the instance. + +(2) We keep record selectors, which are not evidence and so do not satisfy + 'isEvId'. When a constraint is solved by a built-in rule that builds the + dictionary out of a record selector instead of applying a dictionary + function, that selector plays exactly the role the dictionary function + would, and is the only thing recording /which/ instance was used. Such a + selector is additionally recorded as an 'EvInstBind' for the constraint's + own class, so that 'getEvidenceTree' describes it as providing the + instance instead of falling through to its "external evidence variable" + case (which is what it reports for a dependency it can find no evidence + binding for). + +@HasField@ is what motivates both rules: a constraint @HasField "fld" T Int@ +for a real record field is solved by building @MkHasField (fld |> co)@ -- see +Note [HasField instances] in GHC.Tc.Instance.Class -- so without (1) and (2) +the evidence for every record selection, however different, bottomed out at +@GHC.Internal.Records.C:HasField@. Neither rule names @HasField@, though, and +neither should: they say "a dictionary constructor explains nothing" and "a +selector used as evidence explains something", which holds for any class +solved this way. + +The 'EvInstBind' of (2) is deliberately recorded at the span of the /evidence +binding/, not at the selector's own 'nameSrcSpan'. Attaching an evidence +context to the field's declaration would merge it into the +'IdentifierDetails' of the declaration itself, and consumers reasonably skip +identifiers mentioning evidence when deciding what a source token refers to -- +Haddock's hyperlinked source would then stop linking the field declaration. +The 'Name' recorded is the selector either way, which is what an IDE needs in +order to navigate to it. +-} + +-- | Is this the data constructor of a class dictionary, e.g. @C:HasField@? +-- +-- See Note [Evidence dependencies in HIE files] +isClassDataConId :: Id -> Bool +isClassDataConId v + | Just dc <- isDataConId_maybe v = isClassTyCon (dataConTyCon dc) + | otherwise = False + +hieEvIdsOfTerm :: EvTerm -> [Var] +-- See Note [Evidence dependencies in HIE files] +hieEvIdsOfTerm = runFVSelectiveList relevant . evTermFVs + where + -- NB: this traversal offers us TyVars as well as Ids, and 'idDetails' + -- panics on a TyVar, so the Id-only predicates must be guarded by + -- 'isId'. 'isEvId' only looks at the type and is safe on either; it + -- deliberately admits coercion variables, which are TyVars. + relevant v + | not (isId v) = isEvId v + | otherwise = (isEvId v && not (isClassDataConId v)) + || isRecordSelector v instance ToHie (EvBindContext (LocatedA TcEvBinds)) where toHie (EvBindContext sc sp (L span (EvBinds bs))) @@ -699,6 +763,13 @@ instance ToHie (EvBindContext (LocatedA TcEvBinds)) where [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) (L span $ eb_lhs evbind)) , toHie $ map (C EvidenceVarUse . L span) $ evDeps + -- See Note [Evidence dependencies in HIE files] + , toHie [ C (EvidenceVarBind (EvInstBind False (className cls)) + ModuleScope Nothing) + (L span sel) + | Just (cls, _) <- [getClassPredTys_maybe (varType (eb_lhs evbind))] + , sel <- evDeps + , isId sel, isRecordSelector sel ] ] toHie _ = pure [] ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -431,7 +431,7 @@ rnExpr (HsProjection _ fs) ; let fs' = NE.map rnDotFieldOcc fs ; return ( mkExpandedExpr (HsProjection noExtField fs') - (mkProjection getField circ $ NE.map (unLoc . dfoLabel) fs') + (mkProjection getField circ $ NE.map dfoLabel fs') , unitFN circ `plusFN` fv_getField) } ------------------------------------------ @@ -2916,14 +2916,24 @@ mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc) -- mkProjection fields calculates a projection. -- e.g. .x = mkProjection [x] = getField @"x" -- .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x" -mkProjection :: Name -> Name -> NonEmpty FieldLabelString -> HsExpr GhcRn -mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields +mkProjection :: Name -> Name -> NonEmpty (XRec GhcRn FieldLabelString) + -> HsExpr GhcRn +mkProjection getFieldName circName (field :| fields) + = unLoc $ foldl' f (proj field) fields where - f :: HsExpr GhcRn -> FieldLabelString -> HsExpr GhcRn - f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] - - proj :: FieldLabelString -> HsExpr GhcRn - proj (FieldLabelString f) = genHsVar getFieldName `genAppType` genHsTyLit f + f :: LHsExpr GhcRn -> XRec GhcRn FieldLabelString -> LHsExpr GhcRn + f acc field = wrapGenSpan $ genHsApps circName [proj field, acc] + + -- Give each `getField` the SrcSpan of the label it projects, so that the + -- HasField evidence for that label can be found at the label itself. + -- Without this a multi-label section like (.x.y) has no usable span + -- anywhere inside it, and the whole section shows no type and no + -- evidence at all. + -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast + proj :: XRec GhcRn FieldLabelString -> LHsExpr GhcRn + proj lfield@(L _ (FieldLabelString f)) + = wrapGenSpan' (getHasLoc lfield) + $ genHsVar getFieldName `genAppType` genHsTyLit f -- mkProjUpdateSetField calculates functions representing dot notation record updates. -- e.g. Suppose an update like foo.bar = 1. ===================================== testsuite/tests/hiefile/should_run/HasFieldQueries.hs ===================================== @@ -29,6 +29,16 @@ nestedNoSig n = n.nested1.field2 :: Bool -- ^ this is the point +-- Multi-label projection sections: each getField gets the SrcSpan of its own +-- field label, so both HasField dictionaries are reachable. Before that, no +-- node inside the section had a usable span and hovering it found nothing at +-- all. The points below are on 'nested1' and 'field1' respectively. +projSection :: NestedThing -> Char +projSection = (.nested1.field1) + +projSectionApplied :: NestedThing -> Char +projSectionApplied n = (.nested1.field1) n + points = [ (13,17) @@ -38,6 +48,10 @@ points = , (23,25) , (27,20) , (27,28) + , (37,17) + , (37,25) + , (40,26) + , (40,34) ] main = do ===================================== testsuite/tests/hiefile/should_run/HasFieldQueries.stdout ===================================== @@ -3,16 +3,18 @@ At point (13,17), we found: ========================== ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char -│ is an evidence variable bound by a let, depending on: [C:HasField] +│ is an evidence variable bound by a let, depending on: [field1] │ with scope: ModuleScope │ │ Defined at <no location info> └ | `- ┌ - │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a - │ is a usage of an external evidence variable - │ Defined in `GHC.Internal.Records' + │ field1 at HasFieldQueries.hs:1:1, of type: Thing -> Char + │ is an evidence variable bound by an instance of class HasField + │ with scope: ModuleScope + │ + │ Defined at HasFieldQueries.hs:9:21 └ ========================== @@ -23,16 +25,18 @@ At point (16,27), we found: ========================== ┌ │ $dHasField at HasFieldQueries.hs:16:1-32, of type: HasField "field1" Thing Char -│ is an evidence variable bound by a let, depending on: [C:HasField] +│ is an evidence variable bound by a let, depending on: [field1] │ with scope: LocalScope HasFieldQueries.hs:16:1-32 │ bound at: HasFieldQueries.hs:16:1-32 │ Defined at <no location info> └ | `- ┌ - │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a - │ is a usage of an external evidence variable - │ Defined in `GHC.Internal.Records' + │ field1 at HasFieldQueries.hs:1:1, of type: Thing -> Char + │ is an evidence variable bound by an instance of class HasField + │ with scope: ModuleScope + │ + │ Defined at HasFieldQueries.hs:9:21 └ ========================== @@ -40,16 +44,18 @@ At point (23,17), we found: ========================== ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "nested1" NestedThing Thing -│ is an evidence variable bound by a let, depending on: [C:HasField] +│ is an evidence variable bound by a let, depending on: [nested1] │ with scope: ModuleScope │ │ Defined at <no location info> └ | `- ┌ - │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a - │ is a usage of an external evidence variable - │ Defined in `GHC.Internal.Records' + │ nested1 at HasFieldQueries.hs:1:1, of type: NestedThing -> Thing + │ is an evidence variable bound by an instance of class HasField + │ with scope: ModuleScope + │ + │ Defined at HasFieldQueries.hs:20:34 └ ========================== @@ -57,17 +63,27 @@ At point (23,25), we found: ========================== ┌ │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char -│ is an evidence variable bound by a let, depending on: [C:HasField] +│ is an evidence variable bound by a let, depending on: [$dHasField] │ with scope: ModuleScope │ │ Defined at <no location info> └ | `- ┌ - │ C:HasField at HasFieldQueries.hs:1:1, of type: forall {k} (x :: k) r a. (r -> a) -> HasField x r a - │ is a usage of an external evidence variable - │ Defined in `GHC.Internal.Records' + │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char + │ is an evidence variable bound by a let, depending on: [field1] + │ with scope: ModuleScope + │ + │ Defined at <no location info> └ + | + `- ┌ + │ field1 at HasFieldQueries.hs:1:1, of type: Thing -> Char + │ is an evidence variable bound by an instance of class HasField + │ with scope: ModuleScope + │ + │ Defined at HasFieldQueries.hs:9:21 + └ ========================== At point (27,20), we found: @@ -107,3 +123,87 @@ At point (27,28), we found: │ Defined at <no location info> └ +========================== +At point (37,17), we found: +========================== +┌ +│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "nested1" NestedThing Thing +│ is an evidence variable bound by a let, depending on: [nested1] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ +| +`- ┌ + │ nested1 at HasFieldQueries.hs:1:1, of type: NestedThing -> Thing + │ is an evidence variable bound by an instance of class HasField + │ with scope: ModuleScope + │ + │ Defined at HasFieldQueries.hs:20:34 + └ + +========================== +At point (37,25), we found: +========================== +┌ +│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char +│ is an evidence variable bound by a let, depending on: [$dHasField] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ +| +`- ┌ + │ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char + │ is an evidence variable bound by a let, depending on: [field1] + │ with scope: ModuleScope + │ + │ Defined at <no location info> + └ + | + `- ┌ + │ field1 at HasFieldQueries.hs:1:1, of type: Thing -> Char + │ is an evidence variable bound by an instance of class HasField + │ with scope: ModuleScope + │ + │ Defined at HasFieldQueries.hs:9:21 + └ + +========================== +At point (40,26), we found: +========================== +┌ +│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "nested1" NestedThing Thing +│ is an evidence variable bound by a let, depending on: [nested1] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ +| +`- ┌ + │ nested1 at HasFieldQueries.hs:1:1, of type: NestedThing -> Thing + │ is an evidence variable bound by an instance of class HasField + │ with scope: ModuleScope + │ + │ Defined at HasFieldQueries.hs:20:34 + └ + +========================== +At point (40,34), we found: +========================== +┌ +│ $dHasField at HasFieldQueries.hs:1:1, of type: HasField "field1" Thing Char +│ is an evidence variable bound by a let, depending on: [field1] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ +| +`- ┌ + │ field1 at HasFieldQueries.hs:1:1, of type: Thing -> Char + │ is an evidence variable bound by an instance of class HasField + │ with scope: ModuleScope + │ + │ Defined at HasFieldQueries.hs:9:21 + └ + ===================================== testsuite/tests/overloadedrecflds/should_fail/RecordDotErrCtxt.hs ===================================== @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +-- The renamer expands @e.fld@ to @getField \@"fld" e@ (mkGetField in +-- GHC.Rename.Expr). For the sake of .hie files the application head of that +-- expansion carries the SrcSpan of the field label, but it must be a +-- *generated* span (@GeneratedSrcSpan (OrigSpan ...)@, built by wrapGenSpan') +-- rather than a plain RealSrcSpan, or else isGeneratedSrcSpan is False and +-- GHC.Tc.Gen.App starts reporting the internal 'getField' to the user. +-- +-- The CtOrigin site (mk_origin) is already covered by T26480b, which contrasts +-- an explicit 'getField' ("arising from a use of `getField'") with record dot +-- syntax ("arising from selecting the field `x'"); see also T19843h and +-- RecordDotSyntaxFail8. The result-type site is covered by +-- RecordDotSyntaxFail9. +-- +-- What is *not* covered anywhere else is addArgCtxt (GHC.Tc.Gen.App), which +-- needs an ill-typed argument underneath the selection. With a real head span +-- the second error below would gain a +-- "In the first argument of `getField', namely `('c' + 1)'" +-- context line. +module RecordDotErrCtxt where + +data T = MkT { fld :: Int } + +argCtxt :: Int +argCtxt = ('c' + 1).fld ===================================== testsuite/tests/overloadedrecflds/should_fail/RecordDotErrCtxt.stderr ===================================== @@ -0,0 +1,13 @@ +RecordDotErrCtxt.hs:26:11: error: [GHC-39999] + • No instance for ‘GHC.Internal.Records.HasField "fld" Char Int’ + arising from selecting the field ‘fld’ + NB: ‘Char’ is not a record type. + • In the expression: ('c' + 1).fld + In an equation for ‘argCtxt’: argCtxt = ('c' + 1).fld + +RecordDotErrCtxt.hs:26:16: error: [GHC-39999] + • No instance for ‘Num Char’ arising from a use of ‘+’ + • In the expression: 'c' + 1 + In the expression: ('c' + 1).fld + In an equation for ‘argCtxt’: argCtxt = ('c' + 1).fld + ===================================== testsuite/tests/overloadedrecflds/should_fail/all.T ===================================== @@ -63,3 +63,4 @@ test('T23010_fail', [extra_files(['T23010_fail.hs-boot', 'T23010_fail_aux.hs'])] , multimod_compile_fail , ['T23010_fail T23010_fail_aux', '-v0']) test('T23063', extra_files(['T23063_aux.hs']), multimod_compile_fail, ['T23063', '-v0']) +test('RecordDotErrCtxt', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c64437518c798a293e4189acc0fd7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0c64437518c798a293e4189acc0fd7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/mangoiv/27556] simplifier: remove a bogus `assert` in `rebuild_app'` in `GHC.CoreToStg.Prep.cpeApp`.
by Magnus (＠MangoIV) 02 Sep '26

02 Sep '26

Magnus pushed to branch wip/mangoiv/27556 at Glasgow Haskell Compiler / GHC Commits: b4a6c9df by mangoiv at 2026-09-02T14:27:21+02:00 simplifier: remove a bogus `assert` in `rebuild_app'` in `GHC.CoreToStg.Prep.cpeApp`. Prior to this commit commit 08bc245be70d95801bc1138804ed1de9474fbdc0 Author: sheaf <sam.derbyshire(a)gmail.com> Date: Sat Feb 28 16:30:43 2026 +0100 Clean up join points, casts & ticks This commit shores up the logic dealing with casts and ticks occurring in between a join point binding and a jump any `PlaceRuntime` ticks we observed were profiling ticks, even though that isn't necessary. The more liberal rules in the above commit allow e.g. breakpoint ticks (which are valid PlaceRuntime ticks) to legitimately appear in an argument position. Fixes #27556 - - - - - 6 changed files: - + changelog.d/27556 - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Types/Tickish.hs - + testsuite/tests/simplCore/should_compile/T27556.hs - + testsuite/tests/simplCore/should_compile/T27556.script - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/27556 ===================================== @@ -0,0 +1,5 @@ +section: compiler +synopsis: Remove a too strict assert in coreprep; fixes a bug where debug builds + of GHC would fail to compile correctly optimized programs. +mrs: !16558 +issues: #27556 ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1260,10 +1260,9 @@ cpeApp top_env expr -- See Note [Ticks and mandatory eta expansion] AITick tickish - | tickishPlace tickish == PlaceRuntime + | PlaceRuntime <- tickishPlace tickish , req_depth > 0 - -> assert (isProfTick tickish) $ - rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth + -> rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth | otherwise -- See [Floating Ticks in CorePrep] -> rebuild_app' env as fun' (snocFloat floats (FloatTick tickish)) ss rt_ticks req_depth ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -13,7 +13,6 @@ module GHC.Types.Tickish ( mkNoCount, mkNoScope, tickishIsCode, - isProfTick, TickishPlacement(..), tickishPlace, tickishContains, @@ -545,10 +544,6 @@ tickishIsCode ProfNote{} = True tickishIsCode Breakpoint{} = True tickishIsCode HpcTick{} = True -isProfTick :: GenTickish pass -> Bool -isProfTick ProfNote{} = True -isProfTick _ = False - -- | Governs the kind of expression that the tick gets placed on when -- annotating for example using @mkTick@. If we find that we want to -- put a tickish on an expression ruled out here, we try to float it ===================================== testsuite/tests/simplCore/should_compile/T27556.hs ===================================== @@ -0,0 +1,4 @@ +import Control.Exception + +main = mask $ \restore -> restore (pure ()) + ===================================== testsuite/tests/simplCore/should_compile/T27556.script ===================================== @@ -0,0 +1 @@ +:l T27556 ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -611,3 +611,4 @@ test('T27296', [], makefile_test, ['T27296']) test('T27296b', [], makefile_test, ['T27296b']) test('T27589', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) test('T27590', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) +test('T27556', [only_ways('ghci'), extra_hc_opts('-O -fno-unoptimized-core-for-interpreter')], ghci_script, ['T27556.script']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4a6c9dfc295ee7f64d3a5eb918809b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b4a6c9dfc295ee7f64d3a5eb918809b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T25233] X86 NCG: use btr/bts/btc for single-bit operations
by Simon Jakobi (＠sjakobi) 02 Sep '26

02 Sep '26

Simon Jakobi pushed to branch wip/sjakobi/T25233 at Glasgow Haskell Compiler / GHC Commits: 05c9684d by Simon Jakobi at 2026-09-02T14:09:29+02:00 X86 NCG: use btr/bts/btc for single-bit operations Previously the Cmm patterns x & ~(1 << i) x | (1 << i) x ^ (1 << i) compiled to mov/shl/not/and-style sequences of 3-4 instructions. Now they compile to a single btr, bts or btc, matching what C compilers produce. When the bit index is a literal, constant folding has already collapsed these patterns into ones with a literal mask, such as x & 0xfffffeffffffffff for x & ~(1 << 40). Such masks are now also compiled to a bit-test instruction when they don't fit in an imm32 and would otherwise have to be loaded into a register first. For a variable bit index, this applies only when the shift is unchecked (uncheckedShiftL#, Data.Bits.unsafeShiftL): the bounds-checked shiftL used by e.g. the default clearBit/setBit/complementBit implementations wraps the shift in a bounds mask that this optimisation does not see through. With a literal index, the bounds mask is constant-folded away, so the checked operations benefit too. See Note [Bit-test instructions] in GHC.CmmToAsm.X86.CodeGen. Fixes #25233. Assisted-by: Claude Fable 5 - - - - - 9 changed files: - + changelog.d/ncg-x86-bit-test-instructions - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - + testsuite/tests/codeGen/should_gen_asm/T25233.asm - + testsuite/tests/codeGen/should_gen_asm/T25233.hs - + testsuite/tests/codeGen/should_gen_asm/T25233b.asm - + testsuite/tests/codeGen/should_gen_asm/T25233b.cmm - testsuite/tests/codeGen/should_gen_asm/all.T Changes: ===================================== changelog.d/ncg-x86-bit-test-instructions ===================================== @@ -0,0 +1,20 @@ +section: compiler +synopsis: The x86 native code generator now uses the bit-test instructions + ``btr``/``bts``/``btc`` to clear, set or complement a single bit +description: + Cmm patterns such as ``x & ~(1 << i)``, ``x | (1 << i)`` and + ``x ^ (1 << i)`` now compile to a single ``btr``/``bts``/``btc`` + instruction instead of a mov/shl/not/and-style sequence, matching what C + compilers produce. The same applies to the literal masks that constant + folding produces from these patterns when ``i`` is constant, in the cases + where the mask doesn't fit in an imm32 operand. + + For a variable bit index this applies only when the shift is unchecked, + as with ``uncheckedShiftL#`` or ``Data.Bits.unsafeShiftL``. The + bounds-checked ``shiftL`` — used, for example, by the default + implementations of ``clearBit``, ``setBit`` and ``complementBit`` — + wraps the shift in a bounds mask that this optimisation does not see + through. With a literal index, the bounds mask is constant-folded away, + so the checked operations benefit too. +mrs: !16311 +issues: #25233 ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -1442,6 +1442,22 @@ getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps (PUNPCKLQDQ fmt (OpReg dst) dst) ) +-- Use the bit-test instructions btr/bts/btc for clearing, setting and +-- complementing a single bit: e.g. x .&. complement (1 `shiftL` i) is btr. +-- See Note [Bit-test instructions]. +getRegister' platform is32Bit (CmmMachOp (MO_And w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- clearBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTR opnd ix +getRegister' platform is32Bit (CmmMachOp (MO_Or w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- setBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTS opnd ix +getRegister' platform is32Bit (CmmMachOp (MO_Xor w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- setBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTC opnd ix + getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps sse4_1 <- sse4_1Enabled sse4_2 <- sse4_2Enabled @@ -5883,6 +5899,140 @@ genTrivialCode rep instr a b = do instr b_op dst return (Any rep code) +{- Note [Bit-test instructions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +x86 has dedicated instructions for clearing (btr), setting (bts) and +complementing (btc) a single bit whose index is given in a register. We use +them for Cmm patterns such as + + x & ~(1 << i) ==> btr i, x (#25233) + +replacing a mov/shl/not/and sequence with a single instruction. The +shift-count register operand of shl is masked modulo the operand width, and +the bit-offset register operand of btr/bts/btc is masked the same way, so +the replacement is faithful even for out-of-range i (where the Cmm shift is +in any case undefined). + +The bit-offset operand of these instructions must be an immediate or a +register. When the bit index is a literal, no shift reaches the NCG: +constant folding has already turned the whole mask into a literal. If that +mask fits in an imm32, we keep the ordinary and/or/xor with an immediate: +it has the same latency and better throughput (more execution ports) than +the bit-test instructions, and at worst two bytes of extra code size for bit +indices 7..30. +But a W64 mask touching the upper bits, e.g. ~(1 << 40), would have to be moved +into a register first. For such masks we recognise the folded literal itself +(exactly one bit clear resp. set) and emit btr/bts/btc with an immediate +bit offset. + +We restrict the pattern to W32 and native-width W64: the instructions do not +exist at width 8, and sub-word Cmm operations at W8/W16 are rare enough that +they are not worth the extra care. +-} + +-- | Match @1 << i@, returning @i@. +-- +-- The returned expression is always at word width ('machOpArgReps' fixes +-- shift amounts at 'wordWidth'). See Note [Bit-test instructions]. +singleBit_maybe :: CmmExpr -> Maybe CmmExpr +singleBit_maybe (CmmMachOp (MO_Shl _) [CmmLit (CmmInt 1 _), i]) = Just i +singleBit_maybe _ = Nothing + +-- | If exactly one bit of @m@, taken at width @w@, is set, return its index. +-- +-- See Note [Bit-test instructions]. +setBitLit_maybe :: Width -> Integer -> Maybe Int +setBitLit_maybe w m + | popCount m' == 1 = Just (countTrailingZeros m') + | otherwise = Nothing + where + -- w <= W64 in this X86-specific code, so a Word64 suffices. + m' = fromInteger (narrowU w m) :: Word64 + +-- | If exactly one bit of @m@, taken at width @w@, is clear, return its +-- index. +-- +-- See Note [Bit-test instructions]. +clearBitLit_maybe :: Width -> Integer -> Maybe Int +clearBitLit_maybe w m = setBitLit_maybe w (complement m) + +bitTestOpWidthOK :: Bool -> Width -> Bool +bitTestOpWidthOK is32Bit w = w == W32 || (w == W64 && not is32Bit) + +-- | The bit-offset operand of a bit-test instruction (btr/bts/btc). +data BitIndex + = BitIndexReg CmmExpr -- ^ variable index, computed into a register + | BitIndexImm Int -- ^ literal index, emitted as an immediate + +-- | Match the operands of a single-bit set or complement operation: one +-- operand is a mask @1 << i@, or a literal with exactly one bit set that +-- does not fit in an imm32. Returns the other operand and the bit index. +-- +-- Both operand orders are matched: constant folding canonicalizes literals +-- to the right (see 'GHC.Cmm.Opt.cmmMachOpFoldM'), but e.g. hand-written +-- .cmm code reaches the NCG unfolded. +-- +-- See Note [Bit-test instructions]. +setBitArgs_maybe :: Platform -> Width -> CmmExpr -> CmmExpr + -> Maybe (CmmExpr, BitIndex) +setBitArgs_maybe platform w x y = go x y `mplus` go y x + where + go opnd mask + | Just i <- singleBit_maybe mask + = Just (opnd, BitIndexReg i) + | CmmLit lit@(CmmInt m _) <- mask + , Just i <- setBitLit_maybe w m + , not (is32BitLit platform lit) + = Just (opnd, BitIndexImm i) + | otherwise + = Nothing + +-- | As 'setBitArgs_maybe', for a single-bit clear operation: the mask is +-- @~(1 << i)@, or a literal with exactly one bit clear. +clearBitArgs_maybe :: Platform -> Width -> CmmExpr -> CmmExpr + -> Maybe (CmmExpr, BitIndex) +clearBitArgs_maybe platform w x y = go x y `mplus` go y x + where + go opnd mask + | CmmMachOp (MO_Not _) [b] <- mask + , Just i <- singleBit_maybe b + = Just (opnd, BitIndexReg i) + | CmmLit lit@(CmmInt m _) <- mask + , Just i <- clearBitLit_maybe w m + , not (is32BitLit platform lit) + = Just (opnd, BitIndexImm i) + | otherwise + = Nothing + +-- | Generate code for @dst := x@ followed by a bit-test instruction +-- (btr/bts/btc). +-- +-- See Note [Bit-test instructions]. +genBitTestCode :: Format -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr -> BitIndex -> NatM Register +genBitTestCode rep instr x (BitIndexImm i) = do + x_code <- getAnyReg x + let code dst = x_code dst `snocOL` instr rep (OpImm (ImmInt i)) (OpReg dst) + return (Any rep code) +genBitTestCode rep instr x (BitIndexReg i) = do + (i_reg, i_code) <- getNonClobberedReg i + x_code <- getAnyReg x + tmp <- getNewRegNat rep + let + -- As in genTrivialCode, 'i' must stay alive across the computation of + -- 'x' into dst, so save it in a temporary if dst holds 'i'. + code dst + | dst == i_reg = + i_code `appOL` + unitOL (MOV rep (OpReg i_reg) (OpReg tmp)) `appOL` + x_code dst `snocOL` + instr rep (OpReg tmp) (OpReg dst) + | otherwise = + i_code `appOL` + x_code dst `snocOL` + instr rep (OpReg i_reg) (OpReg dst) + return (Any rep code) + regClashesWithOp :: Reg -> Operand -> Bool reg `regClashesWithOp` OpReg reg2 = reg == reg2 reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) ===================================== compiler/GHC/CmmToAsm/X86/Instr.hs ===================================== @@ -193,6 +193,12 @@ data Instr | SHLD Format Operand{-amount-} Operand Operand | BT Format Imm Operand + -- | Bit test-and-reset + | BTR Format Operand{- ^ bit offset (imm/reg) -} Operand + -- | Bit set + | BTS Format Operand{- ^ bit offset (imm/reg) -} Operand + -- | Bit complement + | BTC Format Operand{- ^ bit offset (imm/reg) -} Operand | NOP @@ -496,6 +502,9 @@ regUsageOfInstr platform instr SHLD fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2 SHRD fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2 BT fmt _ src -> mkRUR (use_R fmt src []) + BTR fmt off dst -> usageRM fmt off dst + BTS fmt off dst -> usageRM fmt off dst + BTC fmt off dst -> usageRM fmt off dst PUSH fmt op -> mkRUR (use_R fmt op []) POP fmt op -> mkRU [] (def_W fmt op) @@ -830,6 +839,9 @@ patchRegsOfInstr platform instr env SHLD fmt imm dst1 dst2 -> patch2 (SHLD fmt imm) dst1 dst2 SHRD fmt imm dst1 dst2 -> patch2 (SHRD fmt imm) dst1 dst2 BT fmt imm src -> patch1 (BT fmt imm) src + BTR fmt off dst -> patch2 (BTR fmt) off dst + BTS fmt off dst -> patch2 (BTS fmt) off dst + BTC fmt off dst -> patch2 (BTC fmt) off dst TEST fmt src dst -> patch2 (TEST fmt) src dst CMP fmt src dst -> patch2 (CMP fmt) src dst PUSH fmt op -> patch1 (PUSH fmt) op ===================================== compiler/GHC/CmmToAsm/X86/Ppr.hs ===================================== @@ -862,6 +862,15 @@ pprInstr platform i = case i of BT format imm src -> pprFormatImmOp (text "bt") format imm src + BTR format off dst + -> pprFormatOpOp (text "btr") format off dst + + BTS format off dst + -> pprFormatOpOp (text "bts") format off dst + + BTC format off dst + -> pprFormatOpOp (text "btc") format off dst + CMP format src dst | isFloatFormat format -> pprFormatOpOp (text "ucomi") format src dst -- SSE2 | otherwise -> pprFormatOpOp (text "cmp") format src dst ===================================== testsuite/tests/codeGen/should_gen_asm/T25233.asm ===================================== @@ -0,0 +1,9 @@ +btrq +btsq +btcq +btrl +btsl +btcl +btrq $40, +btsq $40, +btcq $40, ===================================== testsuite/tests/codeGen/should_gen_asm/T25233.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE MagicHash #-} + +-- Check that clearing/setting/complementing a single, variable bit +-- uses the btr/bts/btc instructions (#25233). +module T25233 where + +import GHC.Exts + +myClearBit :: Word# -> Int# -> Word# +myClearBit x i = x `and#` not# (1## `uncheckedShiftL#` i) + +mySetBit :: Word# -> Int# -> Word# +mySetBit x i = x `or#` (1## `uncheckedShiftL#` i) + +myComplementBit :: Word# -> Int# -> Word# +myComplementBit x i = x `xor#` (1## `uncheckedShiftL#` i) + +myClearBit32 :: Word32# -> Int# -> Word32# +myClearBit32 x i = + x `andWord32#` notWord32# (wordToWord32# 1## `uncheckedShiftLWord32#` i) + +mySetBit32 :: Word32# -> Int# -> Word32# +mySetBit32 x i = x `orWord32#` (wordToWord32# 1## `uncheckedShiftLWord32#` i) + +myComplementBit32 :: Word32# -> Int# -> Word32# +myComplementBit32 x i = + x `xorWord32#` (wordToWord32# 1## `uncheckedShiftLWord32#` i) + +-- With a constant bit index >= 32, the mask constant-folds to a literal +-- that does not fit in an imm32, so a bit-test instruction with an +-- immediate offset is used. +myClearBit40 :: Word# -> Word# +myClearBit40 x = x `and#` not# (1## `uncheckedShiftL#` 40#) + +mySetBit40 :: Word# -> Word# +mySetBit40 x = x `or#` (1## `uncheckedShiftL#` 40#) + +myComplementBit40 :: Word# -> Word# +myComplementBit40 x = x `xor#` (1## `uncheckedShiftL#` 40#) ===================================== testsuite/tests/codeGen/should_gen_asm/T25233b.asm ===================================== @@ -0,0 +1,3 @@ +btrq $40, +btsq $40, +btcq $40, ===================================== testsuite/tests/codeGen/should_gen_asm/T25233b.cmm ===================================== @@ -0,0 +1,17 @@ +#include "Cmm.h" + +// Single-bit literal masks written on the left of the operator. Constant +// folding canonicalizes literals to the right, so these shapes only reach +// the NCG from hand-written Cmm like this (#25233). + +clearBit40 (W_ x) { + return ((0xFFFFFEFFFFFFFFFF :: bits64) & x); +} + +setBit40 (W_ x) { + return ((0x10000000000 :: bits64) | x); +} + +complementBit40 (W_ x) { + return ((0x10000000000 :: bits64) ^ x); +} ===================================== testsuite/tests/codeGen/should_gen_asm/all.T ===================================== @@ -23,6 +23,10 @@ test('avx512-int64-minmax', [unless(arch('x86_64'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512vl']) test('avx512-word64-minmax', [unless(arch('x86_64'), skip), when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-mavx512vl']) +test('T25233', [unless(arch('x86_64'), skip), + when(unregisterised(), skip)], compile_grep_asm, ['hs', True, '-O']) +test('T25233b', [unless(arch('x86_64'), skip), + when(unregisterised(), skip)], compile_grep_asm, ['cmm', True, '']) is_aarch64_codegen = [ unless(arch('aarch64'), skip), when(unregisterised(), skip), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05c9684dd907f81aaff6e42e5e16e45… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/05c9684dd907f81aaff6e42e5e16e45… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sand-witch/27423-gadt-parens] Parentheses in prefix GADT constructors (#27423)
by Andrei Borzenkov (＠sand-witch) 02 Sep '26

02 Sep '26

Andrei Borzenkov pushed to branch wip/sand-witch/27423-gadt-parens at Glasgow Haskell Compiler / GHC Commits: da47c8e0 by Andrei Borzenkov at 2026-09-02T16:14:17+04:00 Parentheses in prefix GADT constructors (#27423) Updated `splitLHsGadtTy` to allow looking through the parentheses for inner binders. General example of a code pattern that's allowed now: data S a where MkS :: (forall a. S a) That should work now with any combination of nested foralls and parentheses. We don't perform parenthesis unwrapping for record GADT constructors in accordance with GHC Proposal #402. To this end `con_inner_bndrs` no longer stores plain forall telescopes: `[HsForAllTelescope pass]` is replaced with `[LHsGadtArg pass]`, a new `HsArg`-style type whose `HsGadtForAll` holds an inner telescope and whose `HsGadtPar` holds a pair of parentheses. The parentheses carry no meaning for renaming or type checking; the only reason to record them is exact-printing. Updated `pprConDecl` to improve the `parse == parse . ppr . parse` property of GADT pretty-printing. The pretty printer can now output code that's similar to this: data T a where MkT1 :: (forall a. T a) MkT2 :: forall . forall a. T a These are special cases of inner forall binders for prefix GADT constructors, when we have either implicit or zero explicit outer binders. - - - - - 29 changed files: - + changelog.d/allow-gadt-prefix-con-parens - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/TyCl.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Type.hs - docs/users_guide/exts/gadt_syntax.rst - − testsuite/tests/gadt/T14320.stderr - testsuite/tests/gadt/T18191.hs - testsuite/tests/gadt/T18191.stderr - + testsuite/tests/gadt/T27423a.hs - + testsuite/tests/gadt/T27423b.hs - + testsuite/tests/gadt/T27423b.stderr - testsuite/tests/gadt/all.T - testsuite/tests/printer/Makefile - + testsuite/tests/printer/T27423c.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== changelog.d/allow-gadt-prefix-con-parens ===================================== @@ -0,0 +1,15 @@ +section: language +synopsis: Allow parentheses in prefix GADT constructor declarations, as specified + by GHC Proposal #402 "Stable GADT constructor syntax". +issues: #27423 +mrs: !16321 + +description: + Parenthesized types are now accepted in prefix GADT constructor declarations, + even when they contain explicit ``forall`` quantifiers. For example: + + data T where + MkT :: (forall a. a -> b -> T) + + This is equivalent to ``MkT :: forall {b}. (forall a. a -> b -> T)``, so the + forall-or-nothing rule continues to be respected. ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -974,14 +974,37 @@ pprConDecl (ConDeclGADT { con_names = cons , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_modifiers = mods, con_doc = doc }) = pprMaybeWithDoc doc $ pprLHsModifiers mods <+> ppr_con_names (toList cons) <+> dcolon - <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs - <+> hsep (map pprHsForAllTelescope inner_bndrs) - <+> pprLHsContext mcxt, - sep (ppr_args args ++ [ppr res_ty]) ]) + <+> sep [ppr_outer_bndrs, ppr_inner_bndrs ( + sep [ pprLHsContext mcxt, + sep (ppr_args args ++ [ppr res_ty])])] where ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> pprHsModifiedFunArr arr)) args ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow] + -- pprint all parentheses and foralls, so parse == parse . ppr . parse + ppr_inner_bndrs :: SDoc -> SDoc + ppr_inner_bndrs tyDoc = foldr ppr_inner_bndr (tyDoc <> close_parens) inner_bndrs + + ppr_inner_bndr (L _ HsGadtPar{}) rest = lparen <> rest + ppr_inner_bndr (L _ (HsGadtForAll _ tele)) rest + | HsForAllInvis {hsf_invis_bndrs=[]} <- tele = empty_forall <+> rest + | otherwise = pprHsForAllTelescope tele <+> rest + + -- for each open paren generate a closed one + close_parens = hcat [ rparen | L _ HsGadtPar{} <- inner_bndrs ] + + -- pprint empty explicit outer forall as `forall.` if there are inner binders, because otherwise + -- `forall. forall a. ...` would become `forall a. ...` and that would parse into + -- different AST, thus breaking parse == parse . ppr . parse property + ppr_outer_bndrs + | HsOuterExplicit{hso_bndrs = []} <- outer_bndrs + , not (null inner_bndrs) + = empty_forall + | otherwise + = pprHsOuterSigTyVarBndrs outer_bndrs + + empty_forall = forAllLit <> dot + ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -623,6 +623,11 @@ deriving instance Data (HsForAllTelescope GhcPs) deriving instance Data (HsForAllTelescope GhcRn) deriving instance Data (HsForAllTelescope GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsGadtTelescope p) +deriving instance Data (HsGadtTelescope GhcPs) +deriving instance Data (HsGadtTelescope GhcRn) +deriving instance Data (HsGadtTelescope GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs) deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn) ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -39,6 +39,7 @@ module GHC.Hs.Type ( HsLit(..), HsIPName(..), hsIPNameFS, HsArg(..), numVisibleArgs, pprHsArgsApp, + HsGadtTelescope(..), LHsTypeArg, lhsTypeArgSrcSpan, OutputableBndrFlag, @@ -71,6 +72,7 @@ module GHC.Hs.Type ( hsLTyVarName, hsLTyVarNames, hsForAllTelescopeBndrs, hsForAllTelescopeNames, + gadtArgTelescopes, gadtTelescopeBndrs, mkHsGadtForAlls, hsLTyVarLocName, hsExplicitLTyVarNames, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, @@ -621,6 +623,15 @@ hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)] hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs +gadtArgTelescopes :: [LHsGadtTelescope (GhcPass p)] -> [HsForAllTelescope (GhcPass p)] +gadtArgTelescopes args = [ tele | L _ (HsGadtForAll _ tele) <- args ] + +gadtTelescopeBndrs :: [LHsGadtTelescope (GhcPass p)] -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)] +gadtTelescopeBndrs = concatMap hsForAllTelescopeBndrs . gadtArgTelescopes + +mkHsGadtForAlls :: [HsForAllTelescope (GhcPass p)] -> [HsGadtTelescope (GhcPass p)] +mkHsGadtForAlls = map (HsGadtForAll noExtField) + hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] -- Explicit variables only hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs) @@ -750,6 +761,14 @@ type instance XArgPar (GhcPass _) = SrcSpan type instance XXArg (GhcPass _) = DataConCantHappen +type instance XGadtForAll (GhcPass _) = NoExtField + +type instance XGadtPar GhcPs = (EpToken "(", EpToken ")") +type instance XGadtPar GhcRn = NoExtField +type instance XGadtPar GhcTc = NoExtField + +type instance XXGadtArg (GhcPass _) = DataConCantHappen + type instance XPrefixCon (GhcPass p) = NoExtField type instance XInfixCon (GhcPass p) = NoExtField type instance XRecCon (GhcPass p) = (EpToken "{", EpToken "}") @@ -877,44 +896,55 @@ splitLHsSigmaTyInvis ty = (tvs, ctxt, ty2) -- | Decompose a GADT type into its constituent parts. --- Returns @(outer_bndrs, mb_ctxt, body)@, where: +-- Returns @(outer_bndrs, inner_bndrs, mb_ctxt, body)@, where: -- -- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost -- type variable binders. Otherwise, they are 'HsOuterImplicit'. -- +-- * @inner_bndrs@ are the remaining @forall@ telescopes, interleaved with the +-- parentheses that enclose them. +-- -- * @mb_ctxt@ is @Just@ the context, if it is provided. -- Otherwise, it is @Nothing@. -- -- * @body@ is the body of the type after the optional @forall@s and context. -- --- This function is careful not to look through parentheses. +-- This function does look through parentheses, but it does not discard them: +-- they are syntactically significant, so they are recorded in @inner_bndrs@. -- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@ --- "GHC.Hs.Decls" for why this is important. +-- in "GHC.Hs.Decls" for why this is important. splitLHsGadtTy :: LHsSigType GhcPs - -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) + -> (HsOuterSigTyVarBndrs GhcPs, [LHsGadtTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) splitLHsGadtTy (L _ sig_ty) | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty , (inner_bndrs, phi_ty) <- split_inner_bndrs sigma_ty , (mb_ctxt, rho_ty) <- splitLHsQualTy_KP phi_ty - = case rho_ty of - L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs) + = if is_gadt_rec_ty rho_ty && not (null inner_bndrs) -- Bad! Record GADTs are not allowed to have inner_bndrs, -- undo the split to get a proper error message later - -> (outer_bndrs, [], Nothing, sigma_ty) - _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) + then (outer_bndrs, [], Nothing, sigma_ty) + else (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) where split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) = (outer_bndrs, body_ty) - split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs) - split_inner_bndrs (L _ HsForAllTy { hst_tele = tele + split_inner_bndrs :: + LHsType GhcPs -> ([LHsGadtTelescope GhcPs], LHsType GhcPs) + split_inner_bndrs (L l HsForAllTy { hst_tele = tele , hst_body = body }) - = let ~(teles, t) = split_inner_bndrs body - in (tele:teles, t) + = let ~(args, t) = split_inner_bndrs body + in (L l (HsGadtForAll noExtField tele) : args, t) + split_inner_bndrs (L l (HsParTy toks ty)) + = let ~(args, t) = split_inner_bndrs ty + in (L l (HsGadtPar toks) : args, t) split_inner_bndrs t = ([], t) + -- type of form {fld :: ty, ...} -> ResTy + is_gadt_rec_ty (L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _)) = True + is_gadt_rec_ty _ = False + -- | Decompose a type of the form @forall <tvs>. body@ into its constituent -- parts. Only splits type variable binders that -- were quantified invisibly (e.g., @forall a.@, with a dot). @@ -1283,6 +1313,11 @@ instance OutputableBndrId p ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) = text "HsForAllInvis:" <+> ppr bndrs +instance OutputableBndrId p + => Outputable (HsGadtTelescope (GhcPass p)) where + ppr (HsGadtForAll _ tele) = text "HsGadtForAll" <+> ppr tele + ppr (HsGadtPar _) = text "HsGadtPar" + instance (OutputableBndrId p, OutputableBndrFlag flag p) => Outputable (HsTyVarBndr flag (GhcPass p)) where ppr = pprTyVarBndr @@ -1611,3 +1646,5 @@ type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA type instance Anno (HsModifierOf ty (GhcPass p)) = SrcSpanAnnA + +type instance Anno (HsGadtTelescope (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -924,11 +924,13 @@ repC (L l (ConDeclGADT { con_names = cons = notHandledL (locA l) ThDataConVisibleForall where - no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_bndrs + inner_teles = gadtArgTelescopes inner_bndrs + + no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_teles no_context = isNothing mcxt m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]] - m_invis_inner_bndrs = traverse get_invis_bndrs inner_bndrs + m_invis_inner_bndrs = traverse get_invis_bndrs inner_teles get_invis_bndrs :: HsForAllTelescope GhcRn -> Maybe [LHsTyVarBndr Specificity GhcRn] get_invis_bndrs HsForAllVis{} = Nothing ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1789,7 +1789,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where HsOuterExplicit{} -> [] exp_bndrs = [ L l (updateHsTyVarBndrFlag Invisible b) | L l b <- hsOuterExplicitBndrs outer_bndrs ] - ++ concatMap hsForAllTelescopeBndrs inner_bndrs + ++ concatMap hsForAllTelescopeBndrs (gadtArgTelescopes inner_bndrs) ConDeclH98 { con_name = name, con_ex_tvs = qvars , con_mb_cxt = ctx, con_args = dets , con_doc = doc} -> ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -28,8 +28,7 @@ module GHC.Rename.HsType ( checkPrecMatch, checkSectionPrec, -- Binding related stuff - bindHsOuterTyVarBndrs, bindHsForAllTelescope, - bindHsForAllTelescopes, + bindHsOuterTyVarBndrs, bindHsForAllTelescope, bindHsGadtTelescopes, bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..), rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars, FreeKiTyVars, filterInScopeM, @@ -37,7 +36,7 @@ module GHC.Rename.HsType ( extractHsTysRdrTyVars, extractRdrKindSigVars, extractConDeclGADTDetailsTyVars, extractDataDefnKindVars, extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars, - extractHsForAllTelescopes, + extractHsGadtTelescopes, nubL, nubN, -- Error helpers @@ -1249,16 +1248,19 @@ bindHsForAllTelescope doc tele thing_inside = checkForAllTelescopeWildcardBndrs doc bndrs' thing_inside $ mkHsForAllInvisTele noAnn bndrs' -bindHsForAllTelescopes :: HsDocContext - -> [HsForAllTelescope GhcPs] - -> ([HsForAllTelescope GhcRn] -> RnM (a, FreeNames)) - -> RnM (a, FreeNames) -bindHsForAllTelescopes _ [] thing_inside = +bindHsGadtTelescopes :: HsDocContext + -> [LHsGadtTelescope GhcPs] + -> ([LHsGadtTelescope GhcRn] -> RnM (a, FreeNames)) + -> RnM (a, FreeNames) +bindHsGadtTelescopes _ [] thing_inside = thing_inside [] -bindHsForAllTelescopes doc (tele:teles) thing_inside = - bindHsForAllTelescope doc tele $ \tele' -> - bindHsForAllTelescopes doc teles $ \teles' -> - thing_inside (tele':teles') +bindHsGadtTelescopes doc (L l HsGadtPar{} : args) thing_inside = + bindHsGadtTelescopes doc args $ \args' -> + thing_inside (L l (HsGadtPar noExtField) : args') +bindHsGadtTelescopes doc (L l (HsGadtForAll _ tele) : args) thing_inside = + bindHsForAllTelescope doc tele $ \tele' -> + bindHsGadtTelescopes doc args $ \args' -> + thing_inside (L l (HsGadtForAll noExtField tele') : args') -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type checkForAllTelescopeWildcardBndrs :: HsDocContext @@ -2286,13 +2288,15 @@ extractHsOuterTvBndrs outer_bndrs body_fvs = HsOuterImplicit{} -> body_fvs HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs -extractHsForAllTelescopes :: [HsForAllTelescope GhcPs] - -> FreeKiTyVars -- Free in body - -> FreeKiTyVars -- Free in result -extractHsForAllTelescopes [] body_fvs = body_fvs -extractHsForAllTelescopes (tele:teles) body_fvs = +extractHsGadtTelescopes :: [LHsGadtTelescope GhcPs] + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars -- Free in result +extractHsGadtTelescopes [] body_fvs = body_fvs +extractHsGadtTelescopes (L _ HsGadtPar{} : args) body_fvs = + extractHsGadtTelescopes args body_fvs +extractHsGadtTelescopes (L _ (HsGadtForAll _ tele) : args) body_fvs = extract_hs_for_all_telescope tele [] $ - extractHsForAllTelescopes teles body_fvs + extractHsGadtTelescopes args body_fvs extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -- Accumulator ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -2644,7 +2644,7 @@ rnConDecl (ConDeclGADT { con_names = names -- See #14808. implicit_bndrs = extractHsOuterTvBndrs outer_bndrs $ - extractHsForAllTelescopes inner_bndrs $ + extractHsGadtTelescopes inner_bndrs $ extractHsTysRdrTyVars (hsConDeclTheta mcxt) $ extractConDeclGADTDetailsTyVars args $ extractHsTysRdrTyVars [res_ty] [] @@ -2652,7 +2652,7 @@ rnConDecl (ConDeclGADT { con_names = names ; let ctxt = ConDeclCtx (toList new_names) ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' -> - bindHsForAllTelescopes ctxt inner_bndrs $ \inner_bndrs' -> + bindHsGadtTelescopes ctxt inner_bndrs $ \inner_bndrs' -> do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -3549,12 +3549,12 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside --------------- tcGadtConTyVarBndrs :: SkolemInfo -> HsOuterSigTyVarBndrs GhcRn - -> [HsForAllTelescope GhcRn] + -> [LHsGadtTelescope GhcRn] -> TcM a -> TcM ([TcTyVarBinder], a) tcGadtConTyVarBndrs skol_info outer inner thing_inside = do { (outer_bndrs, (inner_tvbs, a)) <- tcOuterTKBndrs skol_info outer $ - tcExplicitTKBndrs skol_info (concatMap hsForAllTelescopeBndrs inner) $ + tcExplicitTKBndrs skol_info (gadtTelescopeBndrs inner) $ thing_inside ; outer_bndrs <- scopedSortOuter outer_bndrs ; let outer_tvbs = tyVarSpecToBinders (outerTyVarBndrs outer_bndrs) ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -2287,7 +2287,7 @@ kcConDecl new_or_data _tc_res_kind bind_con_tvbs outer_bndrs inner_bndrs thing_inside -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] = discardResult $ bindOuterSigTKBndrs_Tv outer_bndrs $ - bindExplicitTKBndrs_Tv (concatMap hsForAllTelescopeBndrs inner_bndrs) $ + bindExplicitTKBndrs_Tv (gadtTelescopeBndrs inner_bndrs) $ thing_inside {- Note [kcConDecls: kind-checking data type decls] ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -961,8 +961,9 @@ data ConDecl pass -- cf. HsSigType that also stores the outermost sig_bndrs separately -- from the forall telescopes in sig_body. -- See Note [Representing type signatures] in Language.Haskell.Syntax.Type - , con_inner_bndrs :: [HsForAllTelescope pass] - -- ^ The forall telescopes other than the outermost invisible forall. + , con_inner_bndrs :: [LHsGadtTelescope pass] + -- ^ The forall telescopes other than the outermost invisible forall, + -- interleaved with the parentheses that enclose them. , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix , con_res_ty :: LHsType pass -- ^ Result type @@ -1074,22 +1075,21 @@ the GADT type, in precisely that order. For instance: MkT5 :: forall a. Int -> Eq a => a -> T -- Rejected, `Eq a` is nested MkT6 :: (forall a. a -> T) - -- Rejected, `forall a` is nested due to the surrounding parentheses - MkT7 :: (Eq a => a -> t) - -- Rejected, `Eq a` is nested due to the surrounding parentheses + -- OK, the parentheses are recorded in con_inner_bndrs. + MkT7 :: (Eq a => a -> T) + -- OK, ditto For the full details, see the "Formal syntax for GADTs" section of the GHC User's Guide. GHC enforces that GADT constructors do not have nested `forall`s -or contexts in two parts: +or contexts in a single place: -1. GHC, in the process of splitting apart a GADT's type, - extracts out the leading `forall` and context (if they are provided). To - accomplish this splitting, the renamer uses the - GHC.Hs.Type.splitLHsGADTPrefixTy function, which is careful not to remove - parentheses surrounding the leading `forall` or context (as these - parentheses can be syntactically significant). If the third result returned - by splitLHsGADTPrefixTy contains any `forall`s or contexts, then they must - be nested, so they will be rejected. + GHC, in the process of splitting apart a GADT's type, + extracts out the leading `forall`s and context (if they are provided). To + accomplish this splitting, the parser uses the GHC.Hs.Type.splitLHsGadtTy + function, which records the parentheses that surround the leading `forall`s + in con_inner_bndrs (as these parentheses are syntactically significant). + If the body returned by splitLHsGadtTy still contains any `forall`s or + contexts, then they must be nested, so they will be rejected. Note that this step applies to both prefix and record GADTs alike, as they both have syntax which permits `forall`s and contexts. The difference is @@ -1098,11 +1098,6 @@ or contexts in two parts: * For prefix GADTs, this happens in the renamer (in rnConDecl), as we cannot split until after the type operator fixities have been resolved. * For record GADTs, this happens in the parser (in mkGadtDecl). -2. If the GADT type is prefix, the renamer (in the ConDeclGADTPrefixPs case of - rnConDecl) will then check for nested `forall`s/contexts in the body of a - prefix GADT type, after it has determined what all of the argument types are. - This step is necessary to catch examples like MkT4 above, where the nested - quantification occurs after a visible argument type. -} -- | The arguments in a Haskell98-style data constructor. ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -21,6 +21,7 @@ module Language.Haskell.Syntax.Type ( isHsBndrInvisible, isHsBndrWildCard, HsForAllTelescope(..), + HsGadtTelescope(..), LHsGadtTelescope, XGadtForAll, XGadtPar, XXGadtArg, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, @@ -392,6 +393,42 @@ data HsForAllTelescope pass } | XHsForAllTelescope !(XXHsForAllTelescope pass) +-- | A type for interleaved GADT foralls and parentheses, inspired by HsArg. +-- +-- Here's an example: +-- +-- data D where +-- MkD :: forall x y. -- these go to the `con_outer_bndrs` field +-- forall a b. ( forall c. forall d. ( forall. ... +-- ↑ ↑ ↑ ↑ ↑ ↑ +-- 1 2 3 4 5 6 +-- +-- That would correspond to a list +-- +-- 1 → [ HsGadtForAll +-- 2 → , HsGadtPar +-- 3 → , HsGadtForAll +-- 4 → , HsGadtForAll +-- 5 → , HsGadtPar +-- 6 → , HsGadtForAll +-- , ...] +data HsGadtTelescope pass + = HsGadtForAll !(XGadtForAll pass) (HsForAllTelescope pass) + | HsGadtPar !(XGadtPar pass) + -- ^ `HsGadtPar` is only usefull for pretty-printing/exact-printing for recovering + -- parenthisis interleaved with foralls. + -- + -- This approach differs from `HsPar`, which wraps the inner expression as if + -- surrounding it with parentheses. We can ditch the `HsPar` approach because + -- we know that all parentheses will be closed after the return type. + | XHsGadtTelescope !(XXGadtArg pass) + +type LHsGadtTelescope pass = XRec pass (HsGadtTelescope pass) + +type family XGadtForAll pass +type family XGadtPar pass +type family XXGadtArg pass + -- | Located Haskell Type Variable Binder type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass) -- See Note [HsType binders] ===================================== docs/users_guide/exts/gadt_syntax.rst ===================================== @@ -201,12 +201,12 @@ syntactically allowed. Some further various observations about this grammar: something like ``MkS :: Int -> (forall a. a) -> S`` is allowed, since parentheses separate the ``forall`` from the ``->``.) -- Furthermore, GADT constructors do not permit outermost parentheses that - surround the ``foralls`` or ``opt_ctxt``, if at least one of them are - used. For example, ``MkU :: (forall a. a -> U)`` would be rejected, since - it would treat the ``forall`` as being nested. +- GADT constructors permit outermost parentheses that surround the ``foralls`` + or ``opt_ctxt``, as well as interleaved parentheses between multiple + ``foralls``. For example, ``MkU :: (forall a. a -> U)`` is accepted, as is + ``MkW :: forall a. (forall b. a -> b -> W)``. - Note that it is acceptable to use parentheses in a ``prefix_gadt_body``. + Note that it is also acceptable to use parentheses in a ``prefix_gadt_body``. For instance, ``MkV1 :: forall a. (a) -> (V1)`` is acceptable, as is ``MkV2 :: forall a. (a -> V2)``. ===================================== testsuite/tests/gadt/T14320.stderr deleted ===================================== @@ -1,4 +0,0 @@ - -T14320.hs:17:14: error: [GHC-71492] - GADT constructor type signature cannot contain nested ‘forall’s or contexts - In the definition of data constructor ‘TEBad’ ===================================== testsuite/tests/gadt/T18191.hs ===================================== @@ -2,15 +2,6 @@ {-# LANGUAGE RankNTypes #-} module T18191 where -data T where - MkT :: (forall a. a -> b -> T) - -data S a where - MkS :: (forall a. S a) - -data U a where - MkU :: (Show a => U a) - data Z a where MkZ1 :: forall a. forall b. { unZ1 :: (a, b) } -> Z (a, b) MkZ2 :: Eq a => Eq b => { unZ1 :: (a, b) } -> Z (a, b) ===================================== testsuite/tests/gadt/T18191.stderr ===================================== @@ -1,28 +1,16 @@ - -T18191.hs:6:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkT’ - -T18191.hs:9:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkS’ - -T18191.hs:12:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkU’ - -T18191.hs:15:21: error: [GHC-71492] +T18191.hs:6:21: error: [GHC-71492] • GADT constructor type signature cannot contain nested ‘forall’s or contexts • In the definition of data constructor ‘MkZ1’ -T18191.hs:15:31: error: [GHC-89246] +T18191.hs:6:31: error: [GHC-89246] • Record syntax is illegal here: {unZ1 :: (a, b)} • In the definition of data constructor ‘MkZ1’ -T18191.hs:16:19: error: [GHC-71492] +T18191.hs:7:19: error: [GHC-71492] • GADT constructor type signature cannot contain nested ‘forall’s or contexts • In the definition of data constructor ‘MkZ2’ -T18191.hs:16:27: error: [GHC-89246] +T18191.hs:7:27: error: [GHC-89246] • Record syntax is illegal here: {unZ1 :: (a, b)} • In the definition of data constructor ‘MkZ2’ + ===================================== testsuite/tests/gadt/T27423a.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RequiredTypeArguments #-} +module T27423a where + +data G a where + MkG1 :: a -> G a + MkG2 :: (a -> G a) + MkG3 :: forall a. a -> G a + MkG4 :: forall a. (a -> G a) + +-- this is equivalent to `forall {b}. (forall a. a -> b -> T)`. +data T where + MkT2 :: (forall a. a -> b -> T) + +-- this is equivalent to `forall. (forall a. S a)`. +data S a where + MkS :: (forall a. S a) + +-- An explicit, empty outer forall combined with a parenthesised inner one. +data W a where + MkW :: forall. (forall a. W a) + +-- A forall and a context combined inside the same parentheses, with no +-- outer forall at all. +data Y a where + MkY :: (forall a. Show a => a -> Y a) + +-- Multiple, redundant nested parentheses around the whole type should +-- be accepted. +data H a where + MkH :: ((a -> H a)) + +-- An unparenthesised outer forall together with an independent, +-- parenthesised inner forall. +data I a where + MkI :: forall a. (forall b. I (b, a)) + +-- Visible foralls, parenthesised and not. +data V a b where + MkV1 :: forall a -> forall b. (Int -> V a b) + MkV2 :: forall a. (forall b -> (Bool -> V a b)) + +data P a where + MkP1 :: Show a => (a -> P a) + MkP2 :: forall a. Int -> (a -> P a) + MkP3 :: (forall a. Show a => (Int -> (a -> P a))) ===================================== testsuite/tests/gadt/T27423b.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs #-} +module T27423b where + +-- Record-style GADT constructors must remain unparenthesisable, per +-- GHC Proposal #402: this is out of scope for #27423 and should +-- continue to be rejected. +data T1 a where + MkT1 :: ({ fld :: a } -> T1 a) + +data T2 a where + MkT2 :: (forall a. { fld :: a } -> T2 a) + +-- Without parentheses, forall-or-nothing applies to the whole type, so +-- `b` is not implicitly quantified and this must be rejected. +data T3 where + MkT3 :: forall a. a -> b -> T3 + +-- That should gone soon, but let's check that we didn't implement it +-- earlier than we need to +data T4 a where + MkT4 :: Show a => (forall b. a -> b -> T4 a) ===================================== testsuite/tests/gadt/T27423b.stderr ===================================== @@ -0,0 +1,19 @@ +T27423b.hs:8:12: error: [GHC-89246] + • Record syntax is illegal here: {fld :: a} + • In the definition of data constructor ‘MkT1’ + +T27423b.hs:11:12: error: [GHC-71492] + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkT2’ + +T27423b.hs:11:22: error: [GHC-89246] + • Record syntax is illegal here: {fld :: a} + • In the definition of data constructor ‘MkT2’ + +T27423b.hs:16:26: error: [GHC-76037] + Not in scope: type variable ‘b’ + +T27423b.hs:21:22: error: [GHC-71492] + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkT4’ + ===================================== testsuite/tests/gadt/all.T ===================================== @@ -114,7 +114,7 @@ test('T7558', normal, compile, ['']) test('T9380', normal, compile_and_run, ['']) test('T12087', normal, compile_fail, ['']) test('T12468', normal, compile_fail, ['']) -test('T14320', normal, compile_fail, ['']) +test('T14320', normal, compile, ['']) test('T14719', normal, compile_fail, ['-fdiagnostics-show-caret']) test('T14808', normal, compile, ['']) test('T15009', normal, compile, ['']) @@ -132,3 +132,6 @@ test('T19847b', normal, compile, ['']) test('T23022', normal, compile, ['-dcore-lint']) test('T23023', normal, compile_fail, ['-O -dcore-lint']) # todo: move this test? test('T23298', normal, compile_fail, ['']) + +test('T27423a', normal, compile, ['']) +test('T27423b', normal, compile_fail, ['']) ===================================== testsuite/tests/printer/Makefile ===================================== @@ -937,3 +937,8 @@ PprQualifiedStrings: Haddock1: # $(CHECK_PPR) $(LIBDIR) Haddock1.hs $(CHECK_EXACT) $(LIBDIR) Haddock1.hs + +.PHONY: T27423c +T27423c: + $(CHECK_PPR) $(LIBDIR) T27423c.hs + $(CHECK_EXACT) $(LIBDIR) T27423c.hs ===================================== testsuite/tests/printer/T27423c.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RequiredTypeArguments #-} +module T27423c where + +-- Exact-printing regression test +-- Not every declaration there would pass renamer without errors +data G a where + MkG1 :: a -> G a + MkG2 :: (a -> G a) + MkG3 :: forall a. a -> G a + MkG4 :: forall a. (a -> G a) + +data T where + MkT1 :: forall a. a -> b -> T + MkT2 :: (forall a. a -> b -> T) + +data S a where + MkS :: (forall a. S a) + MkS2 :: forall. (forall a. S a) + MkS3 :: forall. forall a. S a + MkS4 :: forall a. forall. forall b. forall. forall. forall c. S a + +data U a where + MkU :: (Show a => U a) + +data V a where + MkV1 :: ((a -> V a)) + MkV2 :: forall a. (forall b. V (b, a)) + MkV3 :: (forall a. Show a => a -> V a) + MkV4 :: forall a. ((forall b. (Show a => a -> (b -> V a)))) + +data W a b where + MkW1 :: forall a -> forall b. (Int -> W a b) + MkW2 :: forall a. (forall b -> (Bool -> W a b)) + +data P a where + MkP1 :: Show a => (a -> P a) + MkP2 :: forall a. Int -> (a -> P a) + +-- Comments in and around the parentheses +data C a where + MkC1 :: -- comment before the parenthesis + (forall a. C a) + MkC2 :: ( -- comment after the parenthesis + forall a. C a) + MkC3 :: (forall a. {- inline comment -} C a) ===================================== testsuite/tests/printer/all.T ===================================== @@ -224,3 +224,4 @@ test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNa test('PprModifiers', [ignore_stderr,req_ppr_deps], makefile_test, ['PprModifiers']) test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings']) test('Haddock1', [ignore_stderr,req_ppr_deps], makefile_test, ['Haddock1']) +test('T27423c', [ignore_stderr,req_ppr_deps], makefile_test, ['T27423c']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -370,6 +370,10 @@ cua CanUpdateAnchor f = f cua CanUpdateAnchorOnly _ = return [] cua NoCanUpdateAnchor _ = return [] +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a +enterAnn = enterAnnWith exact setAnnotationAnchor + +{-# INLINE enterAnnWith #-} -- | "Enter" an annotation, by using the associated 'anchor' field as -- the new reference point for calculating all DeltaPos positions. -- This is the heart of the exact printing process. @@ -377,14 +381,17 @@ cua NoCanUpdateAnchor _ = return [] -- This is combination of the ghc=exactprint Delta.withAST and -- Print.exactPC functions and effectively does the delta processing -- immediately followed by the print processing. JIT ghc-exactprint. -enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a -enterAnn NoEntryVal a = do +enterAnnWith :: (Monad m, Monoid w, Typeable a, Typeable b) => + (a -> EP w m b) -> -- exact + (b -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> b) -> -- setAnnotationAnchor + Entry -> a -> EP w m b +enterAnnWith exactVia _ NoEntryVal a = do p <- getPosP debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) - r <- exact a + r <- exactVia a debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) return r -enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do +enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do acceptSpan <- getAcceptSpan setAcceptSpan False case anchor' of @@ -495,7 +502,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do advance edp debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor') - a' <- exact a + a' <- exactVia a debugM $ "enterAnn:exact a done:" ++ show (showAst anchor') -- Core recursive exactprint done, start end of Entry processing @@ -549,8 +556,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do EpaSpan s -> EpaDelta s edp [] _ -> EpaDelta noSrcSpan edp [] let r = case canUpdateAnchor of - CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) - CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments + CanUpdateAnchor -> setAnnAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) + CanUpdateAnchorOnly -> setAnnAnchor a' newAnchor [] emptyComments NoCanUpdateAnchor -> a' return r @@ -4262,21 +4269,22 @@ instance ExactPrint (ConDecl GhcPs) where L _ (HsOuterImplicit _) -> return outer_bndrs _ -> markAnnotated outer_bndrs - inner_bndrs' <- mapM markAnnotated inner_bndrs + (inner_bndrs', (mcxt', args', res_ty')) <- markGadtArgs inner_bndrs $ do + mcxt' <- markAnnotated mcxt + args' <- + case args of + (PrefixConGADT x args0) -> do + args0' <- mapM markAnnotated args0 + return (PrefixConGADT x args0') + (RecConGADT (oc,cc,rarr) fields) -> do + oc' <- markEpToken oc + fields' <- markAnnotated fields + cc' <- markEpToken cc + rarr' <- markEpUniToken rarr + return (RecConGADT (oc',cc',rarr') fields') + res_ty' <- markAnnotated res_ty + return (mcxt', args', res_ty') - mcxt' <- markAnnotated mcxt - args' <- - case args of - (PrefixConGADT x args0) -> do - args0' <- mapM markAnnotated args0 - return (PrefixConGADT x args0') - (RecConGADT (oc,cc,rarr) fields) -> do - oc' <- markEpToken oc - fields' <- markAnnotated fields - cc' <- markEpToken cc - rarr' <- markEpUniToken rarr - return (RecConGADT (oc',cc',rarr') fields') - res_ty' <- markAnnotated res_ty return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' , con_names = cons' , con_outer_bndrs = outer_bndrs' @@ -4285,6 +4293,44 @@ instance ExactPrint (ConDecl GhcPs) where , con_modifiers = mods' , con_res_ty = res_ty', con_doc = doc }) +-- | Exact print the inner binders of a GADT signature. +-- +-- It's that complicated because we need to mark comments/trailing anns +-- stored inside `L` and mark closing parenthesis _after_ we mark inner +-- type: +-- +-- data T a b where +-- MkT :: +-- forall a. ( -- mark inside `markGadtArgs` +-- forall b. some type -> T a b -- mark everything there +-- ) -- mark inside `markGadtArgs` +-- +-- We don't have the same problem for `HsArgPar` because we ignore it +-- during exact-print, "Does not appear in original source" +markGadtArgs :: (Monad m, Monoid w, Typeable a) + => [LHsGadtTelescope GhcPs] -> EP w m a + -> EP w m ([LHsGadtTelescope GhcPs], a) +markGadtArgs args inner_action = go args + where + go [] = do + r <- inner_action + return ([], r) + go (arg:xs) = enterAnnWith (exact_arg xs) setAnchor (entryFromLocatedA arg) arg + + exact_arg xs (L l (HsGadtForAll _ tele)) = do + tele' <- markAnnotated tele + (xs', r) <- go xs + return (L l (HsGadtForAll noExtField tele') : xs', r) + exact_arg xs (L l (HsGadtPar (lp, rp))) = do + lp' <- markEpToken lp + (xs', r) <- go xs + rp' <- markEpToken rp + return (L l (HsGadtPar (lp',rp')) : xs', r) + + -- The binder just entered is the head of the returned list + setAnchor (arg':xs', r) anc ts cs = (setAnchorAn arg' anc ts cs : xs', r) + setAnchor ([], r) _ _ _ = ([], r) + -- --------------------------------------------------------------------- instance ExactPrint Void where ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -350,7 +350,7 @@ ppCtor typeSig = operator name ++ " :: " ++ outHsSigType sDocContext con_sig_ty name = out sDocContext $ unL <$> names con_sig_ty = HsSig noExtField outer_bndrs $ - mkForallTys inner_bndrs phi_ty + mkGadtArgTys inner_bndrs phi_ty where phi_ty = case mcxt of Just theta -> mkQualTy theta tau_ty @@ -367,13 +367,14 @@ ppCtor noLocA (HsQualTy{ hst_xqual = noExtField , hst_ctxt = ctxt, hst_body = body}) - mkForallTy :: HsForAllTelescope GhcRn -> LHsType GhcRn -> LHsType GhcRn - mkForallTy tele body = - noLocA (HsForAllTy { hst_xforall = noExtField + mkGadtArgTy :: LHsGadtTelescope GhcRn -> LHsType GhcRn -> LHsType GhcRn + mkGadtArgTy (L l (HsGadtForAll _ tele)) body = + L l (HsForAllTy { hst_xforall = noExtField , hst_tele = tele, hst_body = body }) + mkGadtArgTy (L l HsGadtPar{}) body = L l (HsParTy noAnn body) - mkForallTys :: [HsForAllTelescope GhcRn] -> LHsType GhcRn -> LHsType GhcRn - mkForallTys = flip (foldr mkForallTy) + mkGadtArgTys :: [LHsGadtTelescope GhcRn] -> LHsType GhcRn -> LHsType GhcRn + mkGadtArgTys = flip (foldr mkGadtArgTy) ppFixity :: SDocContext -> (Name, Fixity) -> [String] ppFixity sDocContext (name, fixity) = [out sDocContext ((FixitySig noExtField (NoNamespaceSpecifier noExtField) [noLocA name] fixity) :: FixitySig GhcRn)] ===================================== utils/haddock/haddock-api/src/Haddock/Convert.hs ===================================== @@ -567,7 +567,7 @@ synifyDataCon use_gadt_syntax dc = , hso_bndrs = map synifyTyVarBndr outer_tvbs } - inner_bndrs = mk_telescopes inner_tvbs + inner_bndrs = map noLocA $ mkHsGadtForAlls (mk_telescopes inner_tvbs) mk_telescopes bs | (invis, other) <- split_invis_tvbs bs, not (null invis) ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -229,7 +229,7 @@ getGADTConType ( HsSig { sig_ext = noExtField , sig_bndrs = unLoc outer_bndrs - , sig_body = mkForallTys inner_bndrs phi_ty + , sig_body = mkGadtArgTys inner_bndrs phi_ty } ) where @@ -251,13 +251,14 @@ getGADTConType noLocA (HsQualTy{ hst_xqual = noAnn , hst_ctxt = ctxt, hst_body = body}) - mkForallTy :: HsForAllTelescope DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkForallTy tele body = - noLocA (HsForAllTy { hst_xforall = noAnn + mkGadtArgTy :: LHsGadtTelescope DocNameI -> LHsType DocNameI -> LHsType DocNameI + mkGadtArgTy (L l (HsGadtForAll _ tele)) body = + L l (HsForAllTy { hst_xforall = noAnn , hst_tele = tele, hst_body = body }) + mkGadtArgTy (L l HsGadtPar{}) body = L l (HsParTy noAnn body) - mkForallTys :: [HsForAllTelescope DocNameI] -> LHsType DocNameI -> LHsType DocNameI - mkForallTys = flip (foldr mkForallTy) + mkGadtArgTys :: [LHsGadtTelescope DocNameI] -> LHsType DocNameI -> LHsType DocNameI + mkGadtArgTys = flip (foldr mkGadtArgTy) getGADTConType (ConDeclH98{}) = panic "getGADTConType" ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -476,6 +476,11 @@ renameHsBndrVis :: HsBndrVis GhcRn -> RnM (HsBndrVis DocNameI) renameHsBndrVis (HsBndrRequired _) = return (HsBndrRequired noExtField) renameHsBndrVis (HsBndrInvisible at) = return (HsBndrInvisible at) +renameHsGadtTelescope :: LHsGadtTelescope GhcRn -> RnM (LHsGadtTelescope DocNameI) +renameHsGadtTelescope (L l HsGadtPar{}) = pure $ L l $ HsGadtPar noExtField +renameHsGadtTelescope (L l (HsGadtForAll _ tele)) = + L l . HsGadtForAll noExtField <$> renameHsForAllTelescope tele + renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) renameHsForAllTelescope tele = case tele of HsForAllVis _ bndrs -> do @@ -761,7 +766,7 @@ renameCon } = do lnames' <- mapM renameNameL lnames outer_bndrs' <- mapM renameOuterTyVarBndrs outer_bndrs - inner_bndrs' <- mapM renameHsForAllTelescope inner_bndrs + inner_bndrs' <- mapM renameHsGadtTelescope inner_bndrs lcontext' <- traverse renameLContext lcontext details' <- renameGADTDetails details res_ty' <- renameLType res_ty ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -840,6 +840,7 @@ type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = SrcSpanAnnA type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA +type instance Anno (HsGadtTelescope DocNameI) = SrcSpanAnnA type XRecCond a = ( XParTy a ~ (EpToken "(", EpToken ")") @@ -904,6 +905,10 @@ type instance XHsForAllVis DocNameI = NoExtField type instance XHsForAllInvis DocNameI = NoExtField type instance XXHsForAllTelescope DocNameI = DataConCantHappen +type instance XGadtForAll DocNameI = NoExtField +type instance XGadtPar DocNameI = NoExtField +type instance XXGadtArg DocNameI = DataConCantHappen + type instance XTyVarBndr DocNameI = NoExtField type instance XXTyVarBndr DocNameI = DataConCantHappen View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da47c8e09b6ae1f9e2d742505ecdcd2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/da47c8e09b6ae1f9e2d742505ecdcd2… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sand-witch/27423-gadt-parens] Parentheses in prefix GADT constructors (#27423)
by Andrei Borzenkov (＠sand-witch) 02 Sep '26

02 Sep '26

Andrei Borzenkov pushed to branch wip/sand-witch/27423-gadt-parens at Glasgow Haskell Compiler / GHC Commits: f0590079 by Andrei Borzenkov at 2026-09-02T15:56:30+04:00 Parentheses in prefix GADT constructors (#27423) Updated `splitLHsGadtTy` to allow looking through the parentheses for inner binders. General example of a code pattern that's allowed now: data S a where MkS :: (forall a. S a) That should work now with any combination of nested foralls and parentheses. We don't perform parenthesis unwrapping for record GADT constructors in accordance with GHC Proposal #402. To this end `con_inner_bndrs` no longer stores plain forall telescopes: `[HsForAllTelescope pass]` is replaced with `[LHsGadtArg pass]`, a new `HsArg`-style type whose `HsGadtForAll` holds an inner telescope and whose `HsGadtPar` holds a pair of parentheses. The parentheses carry no meaning for renaming or type checking; the only reason to record them is exact-printing. Updated `pprConDecl` to improve the `parse == parse . ppr . parse` property of GADT pretty-printing. The pretty printer can now output code that's similar to this: data T a where MkT1 :: (forall a. T a) MkT2 :: forall . forall a. T a These are special cases of inner forall binders for prefix GADT constructors, when we have either implicit or zero explicit outer binders. - - - - - 29 changed files: - + changelog.d/allow-gadt-prefix-con-parens - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/TyCl.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Type.hs - docs/users_guide/exts/gadt_syntax.rst - − testsuite/tests/gadt/T14320.stderr - testsuite/tests/gadt/T18191.hs - testsuite/tests/gadt/T18191.stderr - + testsuite/tests/gadt/T27423a.hs - + testsuite/tests/gadt/T27423b.hs - + testsuite/tests/gadt/T27423b.stderr - testsuite/tests/gadt/all.T - testsuite/tests/printer/Makefile - + testsuite/tests/printer/T27423c.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== changelog.d/allow-gadt-prefix-con-parens ===================================== @@ -0,0 +1,15 @@ +section: language +synopsis: Allow parentheses in prefix GADT constructor declarations, as specified + by GHC Proposal #402 "Stable GADT constructor syntax". +issues: #27423 +mrs: !16321 + +description: + Parenthesized types are now accepted in prefix GADT constructor declarations, + even when they contain explicit ``forall`` quantifiers. For example: + + data T where + MkT :: (forall a. a -> b -> T) + + This is equivalent to ``MkT :: forall {b}. (forall a. a -> b -> T)``, so the + forall-or-nothing rule continues to be respected. ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -974,14 +974,37 @@ pprConDecl (ConDeclGADT { con_names = cons , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_modifiers = mods, con_doc = doc }) = pprMaybeWithDoc doc $ pprLHsModifiers mods <+> ppr_con_names (toList cons) <+> dcolon - <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs - <+> hsep (map pprHsForAllTelescope inner_bndrs) - <+> pprLHsContext mcxt, - sep (ppr_args args ++ [ppr res_ty]) ]) + <+> sep [ppr_outer_bndrs, ppr_inner_bndrs ( + sep [ pprLHsContext mcxt, + sep (ppr_args args ++ [ppr res_ty])])] where ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> pprHsModifiedFunArr arr)) args ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow] + -- pprint all parentheses and foralls, so parse == parse . ppr . parse + ppr_inner_bndrs :: SDoc -> SDoc + ppr_inner_bndrs tyDoc = foldr ppr_inner_bndr (tyDoc <> close_parens) inner_bndrs + + ppr_inner_bndr (L _ HsGadtPar{}) rest = lparen <> rest + ppr_inner_bndr (L _ (HsGadtForAll _ tele)) rest + | HsForAllInvis {hsf_invis_bndrs=[]} <- tele = empty_forall <+> rest + | otherwise = pprHsForAllTelescope tele <+> rest + + -- for each open paren generate a closed one + close_parens = hcat [ rparen | L _ HsGadtPar{} <- inner_bndrs ] + + -- pprint empty explicit outer forall as `forall.` if there are inner binders, because otherwise + -- `forall. forall a. ...` would become `forall a. ...` and that would parse into + -- different AST, thus breaking parse == parse . ppr . parse property + ppr_outer_bndrs + | HsOuterExplicit{hso_bndrs = []} <- outer_bndrs + , not (null inner_bndrs) + = empty_forall + | otherwise + = pprHsOuterSigTyVarBndrs outer_bndrs + + empty_forall = forAllLit <> dot + ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -623,6 +623,11 @@ deriving instance Data (HsForAllTelescope GhcPs) deriving instance Data (HsForAllTelescope GhcRn) deriving instance Data (HsForAllTelescope GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsGadtTelescope p) +deriving instance Data (HsGadtTelescope GhcPs) +deriving instance Data (HsGadtTelescope GhcRn) +deriving instance Data (HsGadtTelescope GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs) deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn) ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -39,6 +39,7 @@ module GHC.Hs.Type ( HsLit(..), HsIPName(..), hsIPNameFS, HsArg(..), numVisibleArgs, pprHsArgsApp, + HsGadtTelescope(..), LHsTypeArg, lhsTypeArgSrcSpan, OutputableBndrFlag, @@ -71,6 +72,7 @@ module GHC.Hs.Type ( hsLTyVarName, hsLTyVarNames, hsForAllTelescopeBndrs, hsForAllTelescopeNames, + gadtArgTelescopes, gadtArgBndrs, mkHsGadtForAlls, hsLTyVarLocName, hsExplicitLTyVarNames, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, @@ -621,6 +623,15 @@ hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)] hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs +gadtArgTelescopes :: [LHsGadtTelescope (GhcPass p)] -> [HsForAllTelescope (GhcPass p)] +gadtArgTelescopes args = [ tele | L _ (HsGadtForAll _ tele) <- args ] + +gadtArgBndrs :: [LHsGadtTelescope (GhcPass p)] -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)] +gadtArgBndrs = concatMap hsForAllTelescopeBndrs . gadtArgTelescopes + +mkHsGadtForAlls :: [HsForAllTelescope (GhcPass p)] -> [HsGadtTelescope (GhcPass p)] +mkHsGadtForAlls = map (HsGadtForAll noExtField) + hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] -- Explicit variables only hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs) @@ -750,6 +761,14 @@ type instance XArgPar (GhcPass _) = SrcSpan type instance XXArg (GhcPass _) = DataConCantHappen +type instance XGadtForAll (GhcPass _) = NoExtField + +type instance XGadtPar GhcPs = (EpToken "(", EpToken ")") +type instance XGadtPar GhcRn = NoExtField +type instance XGadtPar GhcTc = NoExtField + +type instance XXGadtArg (GhcPass _) = DataConCantHappen + type instance XPrefixCon (GhcPass p) = NoExtField type instance XInfixCon (GhcPass p) = NoExtField type instance XRecCon (GhcPass p) = (EpToken "{", EpToken "}") @@ -877,44 +896,55 @@ splitLHsSigmaTyInvis ty = (tvs, ctxt, ty2) -- | Decompose a GADT type into its constituent parts. --- Returns @(outer_bndrs, mb_ctxt, body)@, where: +-- Returns @(outer_bndrs, inner_bndrs, mb_ctxt, body)@, where: -- -- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost -- type variable binders. Otherwise, they are 'HsOuterImplicit'. -- +-- * @inner_bndrs@ are the remaining @forall@ telescopes, interleaved with the +-- parentheses that enclose them. +-- -- * @mb_ctxt@ is @Just@ the context, if it is provided. -- Otherwise, it is @Nothing@. -- -- * @body@ is the body of the type after the optional @forall@s and context. -- --- This function is careful not to look through parentheses. +-- This function does look through parentheses, but it does not discard them: +-- they are syntactically significant, so they are recorded in @inner_bndrs@. -- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@ --- "GHC.Hs.Decls" for why this is important. +-- in "GHC.Hs.Decls" for why this is important. splitLHsGadtTy :: LHsSigType GhcPs - -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) + -> (HsOuterSigTyVarBndrs GhcPs, [LHsGadtTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) splitLHsGadtTy (L _ sig_ty) | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty , (inner_bndrs, phi_ty) <- split_inner_bndrs sigma_ty , (mb_ctxt, rho_ty) <- splitLHsQualTy_KP phi_ty - = case rho_ty of - L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs) + = if is_gadt_rec_ty rho_ty && not (null inner_bndrs) -- Bad! Record GADTs are not allowed to have inner_bndrs, -- undo the split to get a proper error message later - -> (outer_bndrs, [], Nothing, sigma_ty) - _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) + then (outer_bndrs, [], Nothing, sigma_ty) + else (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) where split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) = (outer_bndrs, body_ty) - split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs) - split_inner_bndrs (L _ HsForAllTy { hst_tele = tele + split_inner_bndrs :: + LHsType GhcPs -> ([LHsGadtTelescope GhcPs], LHsType GhcPs) + split_inner_bndrs (L l HsForAllTy { hst_tele = tele , hst_body = body }) - = let ~(teles, t) = split_inner_bndrs body - in (tele:teles, t) + = let ~(args, t) = split_inner_bndrs body + in (L l (HsGadtForAll noExtField tele) : args, t) + split_inner_bndrs (L l (HsParTy toks ty)) + = let ~(args, t) = split_inner_bndrs ty + in (L l (HsGadtPar toks) : args, t) split_inner_bndrs t = ([], t) + -- type of form {fld :: ty, ...} -> ResTy + is_gadt_rec_ty (L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _)) = True + is_gadt_rec_ty _ = False + -- | Decompose a type of the form @forall <tvs>. body@ into its constituent -- parts. Only splits type variable binders that -- were quantified invisibly (e.g., @forall a.@, with a dot). @@ -1283,6 +1313,11 @@ instance OutputableBndrId p ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) = text "HsForAllInvis:" <+> ppr bndrs +instance OutputableBndrId p + => Outputable (HsGadtTelescope (GhcPass p)) where + ppr (HsGadtForAll _ tele) = text "HsGadtForAll" <+> ppr tele + ppr (HsGadtPar _) = text "HsGadtPar" + instance (OutputableBndrId p, OutputableBndrFlag flag p) => Outputable (HsTyVarBndr flag (GhcPass p)) where ppr = pprTyVarBndr @@ -1611,3 +1646,5 @@ type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA type instance Anno (HsModifierOf ty (GhcPass p)) = SrcSpanAnnA + +type instance Anno (HsGadtTelescope (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -924,11 +924,13 @@ repC (L l (ConDeclGADT { con_names = cons = notHandledL (locA l) ThDataConVisibleForall where - no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_bndrs + inner_teles = gadtArgTelescopes inner_bndrs + + no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_teles no_context = isNothing mcxt m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]] - m_invis_inner_bndrs = traverse get_invis_bndrs inner_bndrs + m_invis_inner_bndrs = traverse get_invis_bndrs inner_teles get_invis_bndrs :: HsForAllTelescope GhcRn -> Maybe [LHsTyVarBndr Specificity GhcRn] get_invis_bndrs HsForAllVis{} = Nothing ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1789,7 +1789,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where HsOuterExplicit{} -> [] exp_bndrs = [ L l (updateHsTyVarBndrFlag Invisible b) | L l b <- hsOuterExplicitBndrs outer_bndrs ] - ++ concatMap hsForAllTelescopeBndrs inner_bndrs + ++ concatMap hsForAllTelescopeBndrs (gadtArgTelescopes inner_bndrs) ConDeclH98 { con_name = name, con_ex_tvs = qvars , con_mb_cxt = ctx, con_args = dets , con_doc = doc} -> ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -28,8 +28,7 @@ module GHC.Rename.HsType ( checkPrecMatch, checkSectionPrec, -- Binding related stuff - bindHsOuterTyVarBndrs, bindHsForAllTelescope, - bindHsForAllTelescopes, + bindHsOuterTyVarBndrs, bindHsForAllTelescope, bindHsGadtTelescopes, bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..), rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars, FreeKiTyVars, filterInScopeM, @@ -37,7 +36,7 @@ module GHC.Rename.HsType ( extractHsTysRdrTyVars, extractRdrKindSigVars, extractConDeclGADTDetailsTyVars, extractDataDefnKindVars, extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars, - extractHsForAllTelescopes, + extractHsGadtTelescopes, nubL, nubN, -- Error helpers @@ -1249,16 +1248,19 @@ bindHsForAllTelescope doc tele thing_inside = checkForAllTelescopeWildcardBndrs doc bndrs' thing_inside $ mkHsForAllInvisTele noAnn bndrs' -bindHsForAllTelescopes :: HsDocContext - -> [HsForAllTelescope GhcPs] - -> ([HsForAllTelescope GhcRn] -> RnM (a, FreeNames)) - -> RnM (a, FreeNames) -bindHsForAllTelescopes _ [] thing_inside = +bindHsGadtTelescopes :: HsDocContext + -> [LHsGadtTelescope GhcPs] + -> ([LHsGadtTelescope GhcRn] -> RnM (a, FreeNames)) + -> RnM (a, FreeNames) +bindHsGadtTelescopes _ [] thing_inside = thing_inside [] -bindHsForAllTelescopes doc (tele:teles) thing_inside = - bindHsForAllTelescope doc tele $ \tele' -> - bindHsForAllTelescopes doc teles $ \teles' -> - thing_inside (tele':teles') +bindHsGadtTelescopes doc (L l HsGadtPar{} : args) thing_inside = + bindHsGadtTelescopes doc args $ \args' -> + thing_inside (L l (HsGadtPar noExtField) : args') +bindHsGadtTelescopes doc (L l (HsGadtForAll _ tele) : args) thing_inside = + bindHsForAllTelescope doc tele $ \tele' -> + bindHsGadtTelescopes doc args $ \args' -> + thing_inside (L l (HsGadtForAll noExtField tele') : args') -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type checkForAllTelescopeWildcardBndrs :: HsDocContext @@ -2286,13 +2288,15 @@ extractHsOuterTvBndrs outer_bndrs body_fvs = HsOuterImplicit{} -> body_fvs HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs -extractHsForAllTelescopes :: [HsForAllTelescope GhcPs] - -> FreeKiTyVars -- Free in body - -> FreeKiTyVars -- Free in result -extractHsForAllTelescopes [] body_fvs = body_fvs -extractHsForAllTelescopes (tele:teles) body_fvs = +extractHsGadtTelescopes :: [LHsGadtTelescope GhcPs] + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars -- Free in result +extractHsGadtTelescopes [] body_fvs = body_fvs +extractHsGadtTelescopes (L _ HsGadtPar{} : args) body_fvs = + extractHsGadtTelescopes args body_fvs +extractHsGadtTelescopes (L _ (HsGadtForAll _ tele) : args) body_fvs = extract_hs_for_all_telescope tele [] $ - extractHsForAllTelescopes teles body_fvs + extractHsGadtTelescopes args body_fvs extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -- Accumulator ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -2644,7 +2644,7 @@ rnConDecl (ConDeclGADT { con_names = names -- See #14808. implicit_bndrs = extractHsOuterTvBndrs outer_bndrs $ - extractHsForAllTelescopes inner_bndrs $ + extractHsGadtTelescopes inner_bndrs $ extractHsTysRdrTyVars (hsConDeclTheta mcxt) $ extractConDeclGADTDetailsTyVars args $ extractHsTysRdrTyVars [res_ty] [] @@ -2652,7 +2652,7 @@ rnConDecl (ConDeclGADT { con_names = names ; let ctxt = ConDeclCtx (toList new_names) ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' -> - bindHsForAllTelescopes ctxt inner_bndrs $ \inner_bndrs' -> + bindHsGadtTelescopes ctxt inner_bndrs $ \inner_bndrs' -> do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -3549,12 +3549,12 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside --------------- tcGadtConTyVarBndrs :: SkolemInfo -> HsOuterSigTyVarBndrs GhcRn - -> [HsForAllTelescope GhcRn] + -> [LHsGadtTelescope GhcRn] -> TcM a -> TcM ([TcTyVarBinder], a) tcGadtConTyVarBndrs skol_info outer inner thing_inside = do { (outer_bndrs, (inner_tvbs, a)) <- tcOuterTKBndrs skol_info outer $ - tcExplicitTKBndrs skol_info (concatMap hsForAllTelescopeBndrs inner) $ + tcExplicitTKBndrs skol_info (gadtArgBndrs inner) $ thing_inside ; outer_bndrs <- scopedSortOuter outer_bndrs ; let outer_tvbs = tyVarSpecToBinders (outerTyVarBndrs outer_bndrs) ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -2287,7 +2287,7 @@ kcConDecl new_or_data _tc_res_kind bind_con_tvbs outer_bndrs inner_bndrs thing_inside -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] = discardResult $ bindOuterSigTKBndrs_Tv outer_bndrs $ - bindExplicitTKBndrs_Tv (concatMap hsForAllTelescopeBndrs inner_bndrs) $ + bindExplicitTKBndrs_Tv (gadtArgBndrs inner_bndrs) $ thing_inside {- Note [kcConDecls: kind-checking data type decls] ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -961,8 +961,9 @@ data ConDecl pass -- cf. HsSigType that also stores the outermost sig_bndrs separately -- from the forall telescopes in sig_body. -- See Note [Representing type signatures] in Language.Haskell.Syntax.Type - , con_inner_bndrs :: [HsForAllTelescope pass] - -- ^ The forall telescopes other than the outermost invisible forall. + , con_inner_bndrs :: [LHsGadtTelescope pass] + -- ^ The forall telescopes other than the outermost invisible forall, + -- interleaved with the parentheses that enclose them. , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix , con_res_ty :: LHsType pass -- ^ Result type @@ -1074,22 +1075,21 @@ the GADT type, in precisely that order. For instance: MkT5 :: forall a. Int -> Eq a => a -> T -- Rejected, `Eq a` is nested MkT6 :: (forall a. a -> T) - -- Rejected, `forall a` is nested due to the surrounding parentheses - MkT7 :: (Eq a => a -> t) - -- Rejected, `Eq a` is nested due to the surrounding parentheses + -- OK, the parentheses are recorded in con_inner_bndrs. + MkT7 :: (Eq a => a -> T) + -- OK, ditto For the full details, see the "Formal syntax for GADTs" section of the GHC User's Guide. GHC enforces that GADT constructors do not have nested `forall`s -or contexts in two parts: +or contexts in a single place: -1. GHC, in the process of splitting apart a GADT's type, - extracts out the leading `forall` and context (if they are provided). To - accomplish this splitting, the renamer uses the - GHC.Hs.Type.splitLHsGADTPrefixTy function, which is careful not to remove - parentheses surrounding the leading `forall` or context (as these - parentheses can be syntactically significant). If the third result returned - by splitLHsGADTPrefixTy contains any `forall`s or contexts, then they must - be nested, so they will be rejected. + GHC, in the process of splitting apart a GADT's type, + extracts out the leading `forall`s and context (if they are provided). To + accomplish this splitting, the parser uses the GHC.Hs.Type.splitLHsGadtTy + function, which records the parentheses that surround the leading `forall`s + in con_inner_bndrs (as these parentheses are syntactically significant). + If the body returned by splitLHsGadtTy still contains any `forall`s or + contexts, then they must be nested, so they will be rejected. Note that this step applies to both prefix and record GADTs alike, as they both have syntax which permits `forall`s and contexts. The difference is @@ -1098,11 +1098,6 @@ or contexts in two parts: * For prefix GADTs, this happens in the renamer (in rnConDecl), as we cannot split until after the type operator fixities have been resolved. * For record GADTs, this happens in the parser (in mkGadtDecl). -2. If the GADT type is prefix, the renamer (in the ConDeclGADTPrefixPs case of - rnConDecl) will then check for nested `forall`s/contexts in the body of a - prefix GADT type, after it has determined what all of the argument types are. - This step is necessary to catch examples like MkT4 above, where the nested - quantification occurs after a visible argument type. -} -- | The arguments in a Haskell98-style data constructor. ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -21,6 +21,7 @@ module Language.Haskell.Syntax.Type ( isHsBndrInvisible, isHsBndrWildCard, HsForAllTelescope(..), + HsGadtTelescope(..), LHsGadtTelescope, XGadtForAll, XGadtPar, XXGadtArg, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, @@ -392,6 +393,42 @@ data HsForAllTelescope pass } | XHsForAllTelescope !(XXHsForAllTelescope pass) +-- | A type for interleaved GADT foralls and parentheses, inspired by HsArg. +-- +-- Here's an example: +-- +-- data D where +-- MkD :: forall x y. -- these go to the `con_outer_bndrs` field +-- forall a b. ( forall c. forall d. ( forall. ... +-- ↑ ↑ ↑ ↑ ↑ ↑ +-- 1 2 3 4 5 6 +-- +-- That would correspond to a list +-- +-- 1 → [ HsGadtForAll +-- 2 → , HsGadtPar +-- 3 → , HsGadtForAll +-- 4 → , HsGadtForAll +-- 5 → , HsGadtPar +-- 6 → , HsGadtForAll +-- , ...] +data HsGadtTelescope pass + = HsGadtForAll !(XGadtForAll pass) (HsForAllTelescope pass) + | HsGadtPar !(XGadtPar pass) + -- ^ `HsGadtPar` is only usefull for pretty-printing/exact-printing for recovering + -- parenthisis interleaved with foralls. + -- + -- This approach differs from `HsPar`, which wraps the inner expression as if + -- surrounding it with parentheses. We can ditch the `HsPar` approach because + -- we know that all parentheses will be closed after the return type. + | XHsGadtTelescope !(XXGadtArg pass) + +type LHsGadtTelescope pass = XRec pass (HsGadtTelescope pass) + +type family XGadtForAll pass +type family XGadtPar pass +type family XXGadtArg pass + -- | Located Haskell Type Variable Binder type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass) -- See Note [HsType binders] ===================================== docs/users_guide/exts/gadt_syntax.rst ===================================== @@ -201,12 +201,12 @@ syntactically allowed. Some further various observations about this grammar: something like ``MkS :: Int -> (forall a. a) -> S`` is allowed, since parentheses separate the ``forall`` from the ``->``.) -- Furthermore, GADT constructors do not permit outermost parentheses that - surround the ``foralls`` or ``opt_ctxt``, if at least one of them are - used. For example, ``MkU :: (forall a. a -> U)`` would be rejected, since - it would treat the ``forall`` as being nested. +- GADT constructors permit outermost parentheses that surround the ``foralls`` + or ``opt_ctxt``, as well as interleaved parentheses between multiple + ``foralls``. For example, ``MkU :: (forall a. a -> U)`` is accepted, as is + ``MkW :: forall a. (forall b. a -> b -> W)``. - Note that it is acceptable to use parentheses in a ``prefix_gadt_body``. + Note that it is also acceptable to use parentheses in a ``prefix_gadt_body``. For instance, ``MkV1 :: forall a. (a) -> (V1)`` is acceptable, as is ``MkV2 :: forall a. (a -> V2)``. ===================================== testsuite/tests/gadt/T14320.stderr deleted ===================================== @@ -1,4 +0,0 @@ - -T14320.hs:17:14: error: [GHC-71492] - GADT constructor type signature cannot contain nested ‘forall’s or contexts - In the definition of data constructor ‘TEBad’ ===================================== testsuite/tests/gadt/T18191.hs ===================================== @@ -2,15 +2,6 @@ {-# LANGUAGE RankNTypes #-} module T18191 where -data T where - MkT :: (forall a. a -> b -> T) - -data S a where - MkS :: (forall a. S a) - -data U a where - MkU :: (Show a => U a) - data Z a where MkZ1 :: forall a. forall b. { unZ1 :: (a, b) } -> Z (a, b) MkZ2 :: Eq a => Eq b => { unZ1 :: (a, b) } -> Z (a, b) ===================================== testsuite/tests/gadt/T18191.stderr ===================================== @@ -1,28 +1,16 @@ - -T18191.hs:6:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkT’ - -T18191.hs:9:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkS’ - -T18191.hs:12:11: error: [GHC-71492] - • GADT constructor type signature cannot contain nested ‘forall’s or contexts - • In the definition of data constructor ‘MkU’ - -T18191.hs:15:21: error: [GHC-71492] +T18191.hs:6:21: error: [GHC-71492] • GADT constructor type signature cannot contain nested ‘forall’s or contexts • In the definition of data constructor ‘MkZ1’ -T18191.hs:15:31: error: [GHC-89246] +T18191.hs:6:31: error: [GHC-89246] • Record syntax is illegal here: {unZ1 :: (a, b)} • In the definition of data constructor ‘MkZ1’ -T18191.hs:16:19: error: [GHC-71492] +T18191.hs:7:19: error: [GHC-71492] • GADT constructor type signature cannot contain nested ‘forall’s or contexts • In the definition of data constructor ‘MkZ2’ -T18191.hs:16:27: error: [GHC-89246] +T18191.hs:7:27: error: [GHC-89246] • Record syntax is illegal here: {unZ1 :: (a, b)} • In the definition of data constructor ‘MkZ2’ + ===================================== testsuite/tests/gadt/T27423a.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RequiredTypeArguments #-} +module T27423a where + +data G a where + MkG1 :: a -> G a + MkG2 :: (a -> G a) + MkG3 :: forall a. a -> G a + MkG4 :: forall a. (a -> G a) + +-- this is equivalent to `forall {b}. (forall a. a -> b -> T)`. +data T where + MkT2 :: (forall a. a -> b -> T) + +-- this is equivalent to `forall. (forall a. S a)`. +data S a where + MkS :: (forall a. S a) + +-- An explicit, empty outer forall combined with a parenthesised inner one. +data W a where + MkW :: forall. (forall a. W a) + +-- A forall and a context combined inside the same parentheses, with no +-- outer forall at all. +data Y a where + MkY :: (forall a. Show a => a -> Y a) + +-- Multiple, redundant nested parentheses around the whole type should +-- be accepted. +data H a where + MkH :: ((a -> H a)) + +-- An unparenthesised outer forall together with an independent, +-- parenthesised inner forall. +data I a where + MkI :: forall a. (forall b. I (b, a)) + +-- Visible foralls, parenthesised and not. +data V a b where + MkV1 :: forall a -> forall b. (Int -> V a b) + MkV2 :: forall a. (forall b -> (Bool -> V a b)) + +data P a where + MkP1 :: Show a => (a -> P a) + MkP2 :: forall a. Int -> (a -> P a) + MkP3 :: (forall a. Show a => (Int -> (a -> P a))) ===================================== testsuite/tests/gadt/T27423b.hs ===================================== @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs #-} +module T27423b where + +-- Record-style GADT constructors must remain unparenthesisable, per +-- GHC Proposal #402: this is out of scope for #27423 and should +-- continue to be rejected. +data T1 a where + MkT1 :: ({ fld :: a } -> T1 a) + +data T2 a where + MkT2 :: (forall a. { fld :: a } -> T2 a) + +-- Without parentheses, forall-or-nothing applies to the whole type, so +-- `b` is not implicitly quantified and this must be rejected. +data T3 where + MkT3 :: forall a. a -> b -> T3 + +-- That should gone soon, but let's check that we didn't implement it +-- earlier than we need to +data T4 a where + MkT4 :: Show a => (forall b. a -> b -> T4 a) ===================================== testsuite/tests/gadt/T27423b.stderr ===================================== @@ -0,0 +1,19 @@ +T27423b.hs:8:12: error: [GHC-89246] + • Record syntax is illegal here: {fld :: a} + • In the definition of data constructor ‘MkT1’ + +T27423b.hs:11:12: error: [GHC-71492] + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkT2’ + +T27423b.hs:11:22: error: [GHC-89246] + • Record syntax is illegal here: {fld :: a} + • In the definition of data constructor ‘MkT2’ + +T27423b.hs:16:26: error: [GHC-76037] + Not in scope: type variable ‘b’ + +T27423b.hs:21:22: error: [GHC-71492] + • GADT constructor type signature cannot contain nested ‘forall’s or contexts + • In the definition of data constructor ‘MkT4’ + ===================================== testsuite/tests/gadt/all.T ===================================== @@ -114,7 +114,7 @@ test('T7558', normal, compile, ['']) test('T9380', normal, compile_and_run, ['']) test('T12087', normal, compile_fail, ['']) test('T12468', normal, compile_fail, ['']) -test('T14320', normal, compile_fail, ['']) +test('T14320', normal, compile, ['']) test('T14719', normal, compile_fail, ['-fdiagnostics-show-caret']) test('T14808', normal, compile, ['']) test('T15009', normal, compile, ['']) @@ -132,3 +132,6 @@ test('T19847b', normal, compile, ['']) test('T23022', normal, compile, ['-dcore-lint']) test('T23023', normal, compile_fail, ['-O -dcore-lint']) # todo: move this test? test('T23298', normal, compile_fail, ['']) + +test('T27423a', normal, compile, ['']) +test('T27423b', normal, compile_fail, ['']) ===================================== testsuite/tests/printer/Makefile ===================================== @@ -937,3 +937,8 @@ PprQualifiedStrings: Haddock1: # $(CHECK_PPR) $(LIBDIR) Haddock1.hs $(CHECK_EXACT) $(LIBDIR) Haddock1.hs + +.PHONY: T27423c +T27423c: + $(CHECK_PPR) $(LIBDIR) T27423c.hs + $(CHECK_EXACT) $(LIBDIR) T27423c.hs ===================================== testsuite/tests/printer/T27423c.hs ===================================== @@ -0,0 +1,46 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RequiredTypeArguments #-} +module T27423c where + +-- Exact-printing regression test +-- Not every declaration there would pass renamer without errors +data G a where + MkG1 :: a -> G a + MkG2 :: (a -> G a) + MkG3 :: forall a. a -> G a + MkG4 :: forall a. (a -> G a) + +data T where + MkT1 :: forall a. a -> b -> T + MkT2 :: (forall a. a -> b -> T) + +data S a where + MkS :: (forall a. S a) + MkS2 :: forall. (forall a. S a) + MkS3 :: forall. forall a. S a + MkS4 :: forall a. forall. forall b. forall. forall. forall c. S a + +data U a where + MkU :: (Show a => U a) + +data V a where + MkV1 :: ((a -> V a)) + MkV2 :: forall a. (forall b. V (b, a)) + MkV3 :: (forall a. Show a => a -> V a) + MkV4 :: forall a. ((forall b. (Show a => a -> (b -> V a)))) + +data W a b where + MkW1 :: forall a -> forall b. (Int -> W a b) + MkW2 :: forall a. (forall b -> (Bool -> W a b)) + +data P a where + MkP1 :: Show a => (a -> P a) + MkP2 :: forall a. Int -> (a -> P a) + +-- Comments in and around the parentheses +data C a where + MkC1 :: -- comment before the parenthesis + (forall a. C a) + MkC2 :: ( -- comment after the parenthesis + forall a. C a) + MkC3 :: (forall a. {- inline comment -} C a) ===================================== testsuite/tests/printer/all.T ===================================== @@ -224,3 +224,4 @@ test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNa test('PprModifiers', [ignore_stderr,req_ppr_deps], makefile_test, ['PprModifiers']) test('PprQualifiedStrings', [ignore_stderr,req_ppr_deps], makefile_test, ['PprQualifiedStrings']) test('Haddock1', [ignore_stderr,req_ppr_deps], makefile_test, ['Haddock1']) +test('T27423c', [ignore_stderr,req_ppr_deps], makefile_test, ['T27423c']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -370,6 +370,10 @@ cua CanUpdateAnchor f = f cua CanUpdateAnchorOnly _ = return [] cua NoCanUpdateAnchor _ = return [] +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a +enterAnn = enterAnnWith exact setAnnotationAnchor + +{-# INLINE enterAnnWith #-} -- | "Enter" an annotation, by using the associated 'anchor' field as -- the new reference point for calculating all DeltaPos positions. -- This is the heart of the exact printing process. @@ -377,14 +381,17 @@ cua NoCanUpdateAnchor _ = return [] -- This is combination of the ghc=exactprint Delta.withAST and -- Print.exactPC functions and effectively does the delta processing -- immediately followed by the print processing. JIT ghc-exactprint. -enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a -enterAnn NoEntryVal a = do +enterAnnWith :: (Monad m, Monoid w, Typeable a, Typeable b) => + (a -> EP w m b) -> -- exact + (b -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> b) -> -- setAnnotationAnchor + Entry -> a -> EP w m b +enterAnnWith exactVia _ NoEntryVal a = do p <- getPosP debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) - r <- exact a + r <- exactVia a debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) return r -enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do +enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do acceptSpan <- getAcceptSpan setAcceptSpan False case anchor' of @@ -495,7 +502,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do advance edp debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor') - a' <- exact a + a' <- exactVia a debugM $ "enterAnn:exact a done:" ++ show (showAst anchor') -- Core recursive exactprint done, start end of Entry processing @@ -549,8 +556,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do EpaSpan s -> EpaDelta s edp [] _ -> EpaDelta noSrcSpan edp [] let r = case canUpdateAnchor of - CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) - CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments + CanUpdateAnchor -> setAnnAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) + CanUpdateAnchorOnly -> setAnnAnchor a' newAnchor [] emptyComments NoCanUpdateAnchor -> a' return r @@ -4262,21 +4269,22 @@ instance ExactPrint (ConDecl GhcPs) where L _ (HsOuterImplicit _) -> return outer_bndrs _ -> markAnnotated outer_bndrs - inner_bndrs' <- mapM markAnnotated inner_bndrs + (inner_bndrs', (mcxt', args', res_ty')) <- markGadtArgs inner_bndrs $ do + mcxt' <- markAnnotated mcxt + args' <- + case args of + (PrefixConGADT x args0) -> do + args0' <- mapM markAnnotated args0 + return (PrefixConGADT x args0') + (RecConGADT (oc,cc,rarr) fields) -> do + oc' <- markEpToken oc + fields' <- markAnnotated fields + cc' <- markEpToken cc + rarr' <- markEpUniToken rarr + return (RecConGADT (oc',cc',rarr') fields') + res_ty' <- markAnnotated res_ty + return (mcxt', args', res_ty') - mcxt' <- markAnnotated mcxt - args' <- - case args of - (PrefixConGADT x args0) -> do - args0' <- mapM markAnnotated args0 - return (PrefixConGADT x args0') - (RecConGADT (oc,cc,rarr) fields) -> do - oc' <- markEpToken oc - fields' <- markAnnotated fields - cc' <- markEpToken cc - rarr' <- markEpUniToken rarr - return (RecConGADT (oc',cc',rarr') fields') - res_ty' <- markAnnotated res_ty return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' , con_names = cons' , con_outer_bndrs = outer_bndrs' @@ -4285,6 +4293,44 @@ instance ExactPrint (ConDecl GhcPs) where , con_modifiers = mods' , con_res_ty = res_ty', con_doc = doc }) +-- | Exact print the inner binders of a GADT signature. +-- +-- It's that complicated because we need to mark comments/trailing anns +-- stored inside `L` and mark closing parenthesis _after_ we mark inner +-- type: +-- +-- data T a b where +-- MkT :: +-- forall a. ( -- mark inside `markGadtArgs` +-- forall b. some type -> T a b -- mark everything there +-- ) -- mark inside `markGadtArgs` +-- +-- We don't have the same problem for `HsArgPar` because we ignore it +-- during exact-print, "Does not appear in original source" +markGadtArgs :: (Monad m, Monoid w, Typeable a) + => [LHsGadtTelescope GhcPs] -> EP w m a + -> EP w m ([LHsGadtTelescope GhcPs], a) +markGadtArgs args inner_action = go args + where + go [] = do + r <- inner_action + return ([], r) + go (arg:xs) = enterAnnWith (exact_arg xs) setAnchor (entryFromLocatedA arg) arg + + exact_arg xs (L l (HsGadtForAll _ tele)) = do + tele' <- markAnnotated tele + (xs', r) <- go xs + return (L l (HsGadtForAll noExtField tele') : xs', r) + exact_arg xs (L l (HsGadtPar (lp, rp))) = do + lp' <- markEpToken lp + (xs', r) <- go xs + rp' <- markEpToken rp + return (L l (HsGadtPar (lp',rp')) : xs', r) + + -- The binder just entered is the head of the returned list + setAnchor (arg':xs', r) anc ts cs = (setAnchorAn arg' anc ts cs : xs', r) + setAnchor ([], r) _ _ _ = ([], r) + -- --------------------------------------------------------------------- instance ExactPrint Void where ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -350,7 +350,7 @@ ppCtor typeSig = operator name ++ " :: " ++ outHsSigType sDocContext con_sig_ty name = out sDocContext $ unL <$> names con_sig_ty = HsSig noExtField outer_bndrs $ - mkForallTys inner_bndrs phi_ty + mkGadtArgTys inner_bndrs phi_ty where phi_ty = case mcxt of Just theta -> mkQualTy theta tau_ty @@ -367,13 +367,14 @@ ppCtor noLocA (HsQualTy{ hst_xqual = noExtField , hst_ctxt = ctxt, hst_body = body}) - mkForallTy :: HsForAllTelescope GhcRn -> LHsType GhcRn -> LHsType GhcRn - mkForallTy tele body = - noLocA (HsForAllTy { hst_xforall = noExtField + mkGadtArgTy :: LHsGadtTelescope GhcRn -> LHsType GhcRn -> LHsType GhcRn + mkGadtArgTy (L l (HsGadtForAll _ tele)) body = + L l (HsForAllTy { hst_xforall = noExtField , hst_tele = tele, hst_body = body }) + mkGadtArgTy (L l HsGadtPar{}) body = L l (HsParTy noAnn body) - mkForallTys :: [HsForAllTelescope GhcRn] -> LHsType GhcRn -> LHsType GhcRn - mkForallTys = flip (foldr mkForallTy) + mkGadtArgTys :: [LHsGadtTelescope GhcRn] -> LHsType GhcRn -> LHsType GhcRn + mkGadtArgTys = flip (foldr mkGadtArgTy) ppFixity :: SDocContext -> (Name, Fixity) -> [String] ppFixity sDocContext (name, fixity) = [out sDocContext ((FixitySig noExtField (NoNamespaceSpecifier noExtField) [noLocA name] fixity) :: FixitySig GhcRn)] ===================================== utils/haddock/haddock-api/src/Haddock/Convert.hs ===================================== @@ -567,7 +567,7 @@ synifyDataCon use_gadt_syntax dc = , hso_bndrs = map synifyTyVarBndr outer_tvbs } - inner_bndrs = mk_telescopes inner_tvbs + inner_bndrs = map noLocA $ mkHsGadtForAlls (mk_telescopes inner_tvbs) mk_telescopes bs | (invis, other) <- split_invis_tvbs bs, not (null invis) ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -229,7 +229,7 @@ getGADTConType ( HsSig { sig_ext = noExtField , sig_bndrs = unLoc outer_bndrs - , sig_body = mkForallTys inner_bndrs phi_ty + , sig_body = mkGadtArgTys inner_bndrs phi_ty } ) where @@ -251,13 +251,14 @@ getGADTConType noLocA (HsQualTy{ hst_xqual = noAnn , hst_ctxt = ctxt, hst_body = body}) - mkForallTy :: HsForAllTelescope DocNameI -> LHsType DocNameI -> LHsType DocNameI - mkForallTy tele body = - noLocA (HsForAllTy { hst_xforall = noAnn + mkGadtArgTy :: LHsGadtTelescope DocNameI -> LHsType DocNameI -> LHsType DocNameI + mkGadtArgTy (L l (HsGadtForAll _ tele)) body = + L l (HsForAllTy { hst_xforall = noAnn , hst_tele = tele, hst_body = body }) + mkGadtArgTy (L l HsGadtPar{}) body = L l (HsParTy noAnn body) - mkForallTys :: [HsForAllTelescope DocNameI] -> LHsType DocNameI -> LHsType DocNameI - mkForallTys = flip (foldr mkForallTy) + mkGadtArgTys :: [LHsGadtTelescope DocNameI] -> LHsType DocNameI -> LHsType DocNameI + mkGadtArgTys = flip (foldr mkGadtArgTy) getGADTConType (ConDeclH98{}) = panic "getGADTConType" ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -476,6 +476,11 @@ renameHsBndrVis :: HsBndrVis GhcRn -> RnM (HsBndrVis DocNameI) renameHsBndrVis (HsBndrRequired _) = return (HsBndrRequired noExtField) renameHsBndrVis (HsBndrInvisible at) = return (HsBndrInvisible at) +renameHsGadtTelescope :: LHsGadtTelescope GhcRn -> RnM (LHsGadtTelescope DocNameI) +renameHsGadtTelescope (L l HsGadtPar{}) = pure $ L l $ HsGadtPar noExtField +renameHsGadtTelescope (L l (HsGadtForAll _ tele)) = + L l . HsGadtForAll noExtField <$> renameHsForAllTelescope tele + renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI) renameHsForAllTelescope tele = case tele of HsForAllVis _ bndrs -> do @@ -761,7 +766,7 @@ renameCon } = do lnames' <- mapM renameNameL lnames outer_bndrs' <- mapM renameOuterTyVarBndrs outer_bndrs - inner_bndrs' <- mapM renameHsForAllTelescope inner_bndrs + inner_bndrs' <- mapM renameHsGadtTelescope inner_bndrs lcontext' <- traverse renameLContext lcontext details' <- renameGADTDetails details res_ty' <- renameLType res_ty ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -840,6 +840,7 @@ type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = SrcSpanAnnA type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA +type instance Anno (HsGadtTelescope DocNameI) = SrcSpanAnnA type XRecCond a = ( XParTy a ~ (EpToken "(", EpToken ")") @@ -904,6 +905,10 @@ type instance XHsForAllVis DocNameI = NoExtField type instance XHsForAllInvis DocNameI = NoExtField type instance XXHsForAllTelescope DocNameI = DataConCantHappen +type instance XGadtForAll DocNameI = NoExtField +type instance XGadtPar DocNameI = NoExtField +type instance XXGadtArg DocNameI = DataConCantHappen + type instance XTyVarBndr DocNameI = NoExtField type instance XXTyVarBndr DocNameI = DataConCantHappen View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0590079d2acacb326212e5a0d3ea60… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0590079d2acacb326212e5a0d3ea60… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T25233] X86 NCG: consolidate the bit-test equations in getRegister'
by Simon Jakobi (＠sjakobi) 02 Sep '26

02 Sep '26

Simon Jakobi pushed to branch wip/sjakobi/T25233 at Glasgow Haskell Compiler / GHC Commits: 0a963358 by Simon Jakobi at 2026-09-02T13:17:59+02:00 X86 NCG: consolidate the bit-test equations in getRegister' Following review feedback on !16311, replace the twelve equations matching single-bit clear/set/complement patterns with one per MachOp, so that BTR, BTS and BTC each appear in a single equation. New helpers clearBitArgs_maybe/setBitArgs_maybe recognise the mask operand in either position — variable index or out-of-imm32-range literal — and genBitTestImmCode is folded into genBitTestCode via the new BitIndex type. Assisted-by: Claude Fable 5 - - - - - 1 changed file: - compiler/GHC/CmmToAsm/X86/CodeGen.hs Changes: ===================================== compiler/GHC/CmmToAsm/X86/CodeGen.hs ===================================== @@ -1443,59 +1443,20 @@ getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps ) -- Use the bit-test instructions btr/bts/btc for clearing, setting and --- complementing a single, variable bit: e.g. x .&. complement (1 `shiftL` i) --- is btr. See Note [Bit-test instructions]. -getRegister' _ is32Bit (CmmMachOp (MO_And w) [x, CmmMachOp (MO_Not _) [y]]) - | Just i <- singleBit_maybe y, bitTestOpWidthOK is32Bit w - = genBitTestCode (intFormat w) BTR x i -getRegister' _ is32Bit (CmmMachOp (MO_And w) [CmmMachOp (MO_Not _) [y], x]) - | Just i <- singleBit_maybe y, bitTestOpWidthOK is32Bit w - = genBitTestCode (intFormat w) BTR x i -getRegister' _ is32Bit (CmmMachOp (MO_Or w) [x, y]) - | Just i <- singleBit_maybe y, bitTestOpWidthOK is32Bit w - = genBitTestCode (intFormat w) BTS x i -getRegister' _ is32Bit (CmmMachOp (MO_Or w) [y, x]) - | Just i <- singleBit_maybe y, bitTestOpWidthOK is32Bit w - = genBitTestCode (intFormat w) BTS x i -getRegister' _ is32Bit (CmmMachOp (MO_Xor w) [x, y]) - | Just i <- singleBit_maybe y, bitTestOpWidthOK is32Bit w - = genBitTestCode (intFormat w) BTC x i -getRegister' _ is32Bit (CmmMachOp (MO_Xor w) [y, x]) - | Just i <- singleBit_maybe y, bitTestOpWidthOK is32Bit w - = genBitTestCode (intFormat w) BTC x i - --- The same operations with a literal bit index: constant folding has turned --- the mask itself into a literal, so use a bit-test instruction whenever the --- mask does not fit in an imm32. See Note [Bit-test instructions]. -getRegister' platform is32Bit (CmmMachOp (MO_And w) [x, CmmLit lit@(CmmInt m _)]) - | Just i <- clearBitLit_maybe w m, bitTestOpWidthOK is32Bit w - , not (is32BitLit platform lit) - = genBitTestImmCode (intFormat w) BTR x i -getRegister' platform is32Bit (CmmMachOp (MO_Or w) [x, CmmLit lit@(CmmInt m _)]) - | Just i <- setBitLit_maybe w m, bitTestOpWidthOK is32Bit w - , not (is32BitLit platform lit) - = genBitTestImmCode (intFormat w) BTS x i -getRegister' platform is32Bit (CmmMachOp (MO_Xor w) [x, CmmLit lit@(CmmInt m _)]) - | Just i <- setBitLit_maybe w m, bitTestOpWidthOK is32Bit w - , not (is32BitLit platform lit) - = genBitTestImmCode (intFormat w) BTC x i - --- Mirrored versions with the literal mask on the left. Constant folding --- canonicalizes constants to the right (see GHC.Cmm.Opt.cmmMachOpFoldM), so --- these only fire on Cmm that reaches the NCG unfolded, e.g. hand-written --- .cmm code. -getRegister' platform is32Bit (CmmMachOp (MO_And w) [CmmLit lit@(CmmInt m _), x]) - | Just i <- clearBitLit_maybe w m, bitTestOpWidthOK is32Bit w - , not (is32BitLit platform lit) - = genBitTestImmCode (intFormat w) BTR x i -getRegister' platform is32Bit (CmmMachOp (MO_Or w) [CmmLit lit@(CmmInt m _), x]) - | Just i <- setBitLit_maybe w m, bitTestOpWidthOK is32Bit w - , not (is32BitLit platform lit) - = genBitTestImmCode (intFormat w) BTS x i -getRegister' platform is32Bit (CmmMachOp (MO_Xor w) [CmmLit lit@(CmmInt m _), x]) - | Just i <- setBitLit_maybe w m, bitTestOpWidthOK is32Bit w - , not (is32BitLit platform lit) - = genBitTestImmCode (intFormat w) BTC x i +-- complementing a single bit: e.g. x .&. complement (1 `shiftL` i) is btr. +-- See Note [Bit-test instructions]. +getRegister' platform is32Bit (CmmMachOp (MO_And w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- clearBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTR opnd ix +getRegister' platform is32Bit (CmmMachOp (MO_Or w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- setBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTS opnd ix +getRegister' platform is32Bit (CmmMachOp (MO_Xor w) [x, y]) + | bitTestOpWidthOK is32Bit w + , Just (opnd, ix) <- setBitArgs_maybe platform w x y + = genBitTestCode (intFormat w) BTC opnd ix getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps sse4_1 <- sse4_1Enabled @@ -5998,14 +5959,62 @@ clearBitLit_maybe w m = setBitLit_maybe w (complement m) bitTestOpWidthOK :: Bool -> Width -> Bool bitTestOpWidthOK is32Bit w = w == W32 || (w == W64 && not is32Bit) +-- | The bit-offset operand of a bit-test instruction (btr/bts/btc). +data BitIndex + = BitIndexReg CmmExpr -- ^ variable index, computed into a register + | BitIndexImm Int -- ^ literal index, emitted as an immediate + +-- | Match the operands of a single-bit set or complement operation: one +-- operand is a mask @1 << i@, or a literal with exactly one bit set that +-- does not fit in an imm32. Returns the other operand and the bit index. +-- +-- Both operand orders are matched: constant folding canonicalizes literals +-- to the right (see 'GHC.Cmm.Opt.cmmMachOpFoldM'), but e.g. hand-written +-- .cmm code reaches the NCG unfolded. +-- +-- See Note [Bit-test instructions]. +setBitArgs_maybe :: Platform -> Width -> CmmExpr -> CmmExpr + -> Maybe (CmmExpr, BitIndex) +setBitArgs_maybe platform w x y = go x y `mplus` go y x + where + go opnd mask + | Just i <- singleBit_maybe mask + = Just (opnd, BitIndexReg i) + | CmmLit lit@(CmmInt m _) <- mask + , Just i <- setBitLit_maybe w m + , not (is32BitLit platform lit) + = Just (opnd, BitIndexImm i) + | otherwise + = Nothing + +-- | As 'setBitArgs_maybe', for a single-bit clear operation: the mask is +-- @~(1 << i)@, or a literal with exactly one bit clear. +clearBitArgs_maybe :: Platform -> Width -> CmmExpr -> CmmExpr + -> Maybe (CmmExpr, BitIndex) +clearBitArgs_maybe platform w x y = go x y `mplus` go y x + where + go opnd mask + | CmmMachOp (MO_Not _) [b] <- mask + , Just i <- singleBit_maybe b + = Just (opnd, BitIndexReg i) + | CmmLit lit@(CmmInt m _) <- mask + , Just i <- clearBitLit_maybe w m + , not (is32BitLit platform lit) + = Just (opnd, BitIndexImm i) + | otherwise + = Nothing + -- | Generate code for @dst := x@ followed by a bit-test instruction --- (btr/bts/btc) with bit offset @i@. +-- (btr/bts/btc). -- --- Analogous to 'genTrivialCode', but the offset operand must be a register, --- not memory. See Note [Bit-test instructions]. +-- See Note [Bit-test instructions]. genBitTestCode :: Format -> (Format -> Operand -> Operand -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register -genBitTestCode rep instr x i = do + -> CmmExpr -> BitIndex -> NatM Register +genBitTestCode rep instr x (BitIndexImm i) = do + x_code <- getAnyReg x + let code dst = x_code dst `snocOL` instr rep (OpImm (ImmInt i)) (OpReg dst) + return (Any rep code) +genBitTestCode rep instr x (BitIndexReg i) = do (i_reg, i_code) <- getNonClobberedReg i x_code <- getAnyReg x tmp <- getNewRegNat rep @@ -6024,17 +6033,6 @@ genBitTestCode rep instr x i = do instr rep (OpReg i_reg) (OpReg dst) return (Any rep code) --- | Generate code for @dst := x@ followed by a bit-test instruction --- (btr/bts/btc) with an immediate bit offset. --- --- See Note [Bit-test instructions]. -genBitTestImmCode :: Format -> (Format -> Operand -> Operand -> Instr) - -> CmmExpr -> Int -> NatM Register -genBitTestImmCode rep instr x i = do - x_code <- getAnyReg x - let code dst = x_code dst `snocOL` instr rep (OpImm (ImmInt i)) (OpReg dst) - return (Any rep code) - regClashesWithOp :: Reg -> Operand -> Bool reg `regClashesWithOp` OpReg reg2 = reg == reg2 reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a963358ee96088a9a41da373d7371c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a963358ee96088a9a41da373d7371c… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0