June 2026 - ghc-commits

[Git][ghc/ghc][wip/sjakobi/T26964] 10 commits: fix typo : compete with performance, not complete
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T26964 at Glasgow Haskell Compiler / GHC Commits: f2f5c6ba by Nikita Efremov at 2026-06-02T16:04:54+00:00 fix typo : compete with performance, not complete - - - - - 5524ea0e by Wolfgang Jeltsch at 2026-06-03T08:01:26-04:00 Make the current `base` buildable with GHC 9.14 This comprises the following changes: * Disable some imports into `GHC.Base` for GHC 9.14 * Disable some imports into `Prelude` for GHC 9.14 * Disable separate `ArrowLoop` import for GHC 9.14 * Disable `GHC.Internal.STM` import for GHC 9.14 * Disable `GHC.Internal.Unicode.Version` import for GHC 9.14 * Disable `GHC.Internal.TH.Monad` import for GHC 9.14 * Add alternative `fixIO` import for GHC 9.14 * Add alternative `unsafeCodeCoerce` import for GHC 9.14 * Disable hiding of imported SIMD operations for GHC 9.14 * Disable use of GHC 9.14’s `printToHandleFinalizerExceptionHandler` * Enable use of `getFileHash` from `ghc-internal` for GHC 9.14 * Make `thenA` available for GHC 9.14 * Make `thenM` available for GHC 9.14 * Disable translation of `IoManagerFlagPoll` for GHC 9.14 * Add `hGetNewlineMode` for GHC 9.14 - - - - - d3438055 by Enrico Maria De Angelis at 2026-06-03T08:02:17-04:00 Fix #27067 - Clarify haddocks on `minusNaturalMaybe` - - - - - f9bcfac2 by sheaf at 2026-06-03T14:47:19-04:00 Avoid mkTick in Core Prep breaking ANF As discovered in #27182, mkTick can break ANF. This patch introduces a variant of mkTick that skips the single optimisation that could break ANF. This is preferrable over switching to the raw Tick constructor, as the latter may introduce spurious cost centres in profiling reports. This is a temporary measure until we more thoroughly refactor how mkTick works (see #27141). See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep. Fixes #27182 - - - - - cf1fd661 by Artem Pelenitsyn at 2026-06-03T14:48:09-04:00 clarify comment for getSizeofMutableByteArray#: we get the size in bytes, not "elements" - - - - - a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00 Hadrian: convert env variable ACLOCAL_PATH to unix paths. Convert ACLOCAL_PATH to a unix style path when invoking autoreconf. Autoreconf doesn't handle windows paths. See Note [Autoreconf unix paths from ACLOCAL_PATH]. Fixes #27311 - - - - - 18f6138a by Simon Jakobi at 2026-06-04T20:20:31-04:00 testsuite: Deduplicate --only test names config.only is assumed to be a set, but supplying --only overwrote it with the (list) argparse result, which can contain duplicates. When a test ran, config.only.remove(name) dropped only the first occurrence, so a duplicated name lingered and was later misreported as a "test not found" framework failure. Store it as a set instead. Fixes #27322 Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00 testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which fails with "cannot find package ghc-bignum". That error went to stderr and leaked into the captured stderr of every makefile_test, causing spurious [bad stderr] failures across the suite. The probe also silently returned empty, so config.have_fast_bignum was wrongly False even on GMP builds. Probe ghc-internal's extra-libraries for the gmp library instead: the GMP backend module is an other-module (not exposed), but GMP_LIBS adds gmp to extra-libraries only on a GMP build, so this distinguishes the backends. Redirect stderr to keep any future missing-package error off the harness's stderr. This also removes a stale comment as per suggestion from hsyl20. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - a9bbd128 by Simon Jakobi at 2026-06-09T11:11:31+02:00 Improve -fcheck-prim-bounds error messages When an array access instrumented by -fcheck-prim-bounds fails at runtime, report the failing primop, the offending index, the array size, and the module being compiled, then exit with a normal failure status, e.g. readSmallArray#: array access out of bounds in module Main: index -1 is not within [0, 5). Previously the program aborted via barf with an "internal error" framed as a GHC bug, even though such failures are almost always caused by incorrect use of unsafe primops in user or library code. The primop and module names are threaded to the RTS failure handlers (rtsOutOfBoundsAccess, rtsMemcpyRangeOverlap) from StgToCmm. The primop name is stashed once in cmmPrimOpApp via a new fcs_prim_op field in FCodeState, so the bounds-check sites are unchanged; the module is stgToCmmThisModule. Fixes #26964, #24617. Co-Authored-By: Claude Opus 4.8 <noreply(a)anthropic.com> - - - - - 48 changed files: - boot - + changelog.d/T27182.md - + changelog.d/improve-check-prim-bounds-messages - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/StgToCmm/Monad.hs - compiler/GHC/StgToCmm/Prim.hs - docs/users_guide/debugging.rst - docs/users_guide/javascript.rst - hadrian/src/Hadrian/Oracles/Path.hs - hadrian/src/Rules/BinaryDist.hs - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Arrow.hs - libraries/base/src/Control/Monad.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Conc.hs - libraries/base/src/GHC/Conc/Sync.hs - libraries/base/src/GHC/Exts.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/IO/Handle.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/Unicode.hs - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/IO.hs - libraries/base/src/System/Mem/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Natural.hs - rts/PrimOps.cmm - rts/RtsMessages.c - rts/include/rts/Messages.h - testsuite/driver/runtests.py - testsuite/mk/test.mk - + testsuite/tests/codeGen/should_fail/T26964.hs - + testsuite/tests/codeGen/should_fail/T26964.stderr - + testsuite/tests/codeGen/should_fail/T26964Module.hs - + testsuite/tests/codeGen/should_fail/T26964Module.stderr - + testsuite/tests/codeGen/should_fail/T26964ModuleA.hs - + testsuite/tests/codeGen/should_fail/T26964b.hs - + testsuite/tests/codeGen/should_fail/T26964b.stderr - testsuite/tests/codeGen/should_fail/all.T - + testsuite/tests/profiling/should_compile/T27182.hs - testsuite/tests/profiling/should_compile/all.T - utils/check-exact/Main.hs - utils/check-exact/Transform.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d841fc919f30a35859cc37b212d216… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d841fc919f30a35859cc37b212d216… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T27296-stable-simpl] 6 commits: Hadrian: convert env variable ACLOCAL_PATH to unix paths.
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T27296-stable-simpl at Glasgow Haskell Compiler / GHC Commits: a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00 Hadrian: convert env variable ACLOCAL_PATH to unix paths. Convert ACLOCAL_PATH to a unix style path when invoking autoreconf. Autoreconf doesn't handle windows paths. See Note [Autoreconf unix paths from ACLOCAL_PATH]. Fixes #27311 - - - - - 18f6138a by Simon Jakobi at 2026-06-04T20:20:31-04:00 testsuite: Deduplicate --only test names config.only is assumed to be a set, but supplying --only overwrote it with the (list) argparse result, which can contain duplicates. When a test ran, config.only.remove(name) dropped only the first occurrence, so a duplicated name lingered and was later misreported as a "test not found" framework failure. Store it as a set instead. Fixes #27322 Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00 testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which fails with "cannot find package ghc-bignum". That error went to stderr and leaked into the captured stderr of every makefile_test, causing spurious [bad stderr] failures across the suite. The probe also silently returned empty, so config.have_fast_bignum was wrongly False even on GMP builds. Probe ghc-internal's extra-libraries for the gmp library instead: the GMP backend module is an other-module (not exposed), but GMP_LIBS adds gmp to extra-libraries only on a GMP build, so this distinguishes the backends. Redirect stderr to keep any future missing-package error off the harness's stderr. This also removes a stale comment as per suggestion from hsyl20. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - 7153ddec by Simon Jakobi at 2026-06-09T10:17:11+02:00 Add -dstable-core-dump-order for stable Core dump ordering (#27296) The order of top-level bindings in Core dumps (-ddump-simpl etc.) is the compiler's internal processing order, which is sensitive to Uniques. Uniques can shift whenever an unrelated upstream module changes, so the bindings get re-ordered and a textual diff of two dumps fails to line up the real changes. This adds an opt-in flag -dstable-core-dump-order that reorders the top-level bindings of Core dumps routed through dumpPassResult into a stable, unique-independent order: by source location, then a $-rank so a derived $w/$s binder sorts before its origin (mirroring GHC's default dependency order, where the wrapper calls the worker), then the OccName. Workers and specialisations inherit their origin's source span, so they cluster next to the binding they come from; anonymous floats (noSrcSpan) sort to the end; Rec groups are kept intact. Only top-level bindings are reordered; nested bindings are left as-is. The default order is retained as it is useful when debugging the compiler itself. The ordering is unique-independent, so two dumps line up across rebuilds. See Note [Stable Core dump order] in GHC.Core.Ppr. Adds test T27296, a small Data.Map-style module whose binders GHC emits in a non-source order by default, asserting they come out stably ordered under the flag. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 6e9658ab by Simon Jakobi at 2026-06-09T10:30:20+02:00 Stabilise anonymous float ordering in untidied Core dumps Anonymous floats are all built with OccName "lvl" and noSrcSpan (newLvlVar), so the source-span/name sort key is identical for every one of them; sortOn then falls back to the unique-driven input order -- the very churn -dstable-core-dump-order is meant to remove. (Tidied dumps like -ddump-simpl are unaffected, as tidy gives the floats distinct names lvl, lvl1, ...) Add a content-based, unique-independent tie-break (rhsKey): the floated literal, if any, then the RHS size statistics. Add test T27296b pinning the float ordering in an untidied -ddump-float-out dump. It is a makefile_test that seds the dump down to just the bindings (collapsing each pass header to a bare "Float out" separator and dropping the FOS config / size lines), so the six lvl floats are asserted to come out ordered by literal value. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 21 changed files: - boot - + changelog.d/stable-core-dump-order-27296 - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Utils/Outputable.hs - docs/users_guide/debugging.rst - hadrian/src/Hadrian/Oracles/Path.hs - hadrian/src/Rules/BinaryDist.hs - testsuite/driver/runtests.py - testsuite/mk/test.mk - testsuite/tests/simplCore/should_compile/Makefile - + testsuite/tests/simplCore/should_compile/T27296.hs - + testsuite/tests/simplCore/should_compile/T27296.stdout - + testsuite/tests/simplCore/should_compile/T27296b.hs - + testsuite/tests/simplCore/should_compile/T27296b.stdout - testsuite/tests/simplCore/should_compile/all.T - utils/check-exact/Main.hs - utils/check-exact/Transform.hs Changes: ===================================== boot ===================================== @@ -52,9 +52,8 @@ def autoreconf(): # Run autoreconf on everything that needs it. processes = {} if os.name == 'nt': - # Get the normalized ACLOCAL_PATH for Windows - # This is necessary since on Windows this will be a Windows - # path, which autoreconf doesn't know doesn't know how to handle. + # Convert ACLOCAL_PATH env variable to unix style paths on Windows + # See Note [Autoreconf unix paths from ACLOCAL_PATH] ac_local = os.getenv('ACLOCAL_PATH', '') ac_local_arg = re.sub(r';', r':', ac_local) ac_local_arg = re.sub(r'\\', r'/', ac_local_arg) ===================================== changelog.d/stable-core-dump-order-27296 ===================================== @@ -0,0 +1,4 @@ +section: compiler +synopsis: Add :ghc-flag:`-dstable-core-dump-order`, a debugging flag that prints top-level Core bindings in a stable, source-location-based order that does not depend on uniques, making intermediate-compiler dumps (e.g. with :ghc-flag:`-ddump-simpl` or :ghc-flag:`-dverbose-core2core`) easier to diff. This affects only the compiler's intermediate output; it does not change generated code. +issues: #27296 +mrs: !16143 ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -327,12 +327,17 @@ dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds where size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + -- See Note [Stable Core dump order] in GHC.Core.Ppr + binds' | sdocStableCoreDumpOrder (log_default_dump_context (logFlags logger)) + = sortCoreBindingsForDump binds + | otherwise = binds + dump_doc = vcat [ nest 2 extra_info , size_doc , blankLine , if dump_core_sizes - then pprCoreBindingsWithSize binds - else pprCoreBindings binds + then pprCoreBindingsWithSize binds' + else pprCoreBindings binds' , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine , text "------ Local rules for imported ids --------" ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -19,6 +19,7 @@ module GHC.Core.Ppr ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, pprCoreBindingWithSize, pprCoreBindingsWithSize, + sortCoreBindingsForDump, pprCoreBinder, pprCoreBinders, pprId, pprIds, pprRule, pprRules, pprOptCo, pprOcc, pprOccWithTick @@ -27,10 +28,10 @@ module GHC.Core.Ppr ( import GHC.Prelude import GHC.Core -import GHC.Core.Stats (exprStats) +import GHC.Core.Stats (CoreStats(..), exprStats) import GHC.Types.Fixity (LexicalFixity(..)) -import GHC.Types.Literal( pprLiteral ) -import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Literal( Literal, pprLiteral ) +import GHC.Types.Name( getOccString, getSrcSpan, pprInfixName, pprPrefixName ) import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info @@ -44,9 +45,13 @@ import GHC.Core.Coercion import GHC.Types.Basic import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Types.SrcLoc ( pprUserRealSpan ) +import GHC.Utils.Panic (panic) +import GHC.Types.SrcLoc ( SrcSpan(..), pprUserRealSpan, srcSpanStartCol + , srcSpanStartLine ) import GHC.Types.Tickish +import Data.List ( sortOn ) + {- ************************************************************************ * * @@ -71,6 +76,115 @@ pprCoreBindingWithSize :: CoreBind -> SDoc pprCoreBindingsWithSize = pprTopBinds sizeAnn pprCoreBindingWithSize = pprTopBind sizeAnn +{- Note [Stable Core dump order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The order of top-level bindings in a Core dump (-ddump-simpl etc.) is the +compiler's internal processing order, which is sensitive to Uniques. Uniques +can shift whenever an unrelated upstream module changes, so the bindings get +re-ordered and a textual diff of two dumps fails to line up the real changes +(#27296). + +With -dstable-core-dump-order we reorder the top-level bindings at dump time into +a stable order. 'sortCoreBindingsForDump' sorts by a key that is *independent of +Uniques*, so two dumps line up across rebuilds. The sort key is: + + 1. the binder's source span (real spans in source order; noSrcSpan last). + Workers and specialisations inherit their origin's source span (see + 'mkWorkerId' and 'newSpecIdSM'), so they cluster next to the binding they + come from. + 2. a "$-rank" so that within one source span the compiler-derived binders sort + *before* the origin they come from (e.g. @$wfoo@ before @foo@), mirroring + GHC's default dependency order (the wrapper calls the worker, so the worker + comes first; specialisations likewise precede their origin). We rank by + whether the OccName *contains* a '$', which marks a derived binder: a worker + is @$wfoo@, but a call-site specialisation is tidied to @bar_$sfoo@ (no + leading '$'), so a leading-'$' test would miss it. + 3. the OccName string, as a lexical, deterministic tie-break. + 4. a content-based tie-break on the right-hand side ('rhsKey'): the floated + literal, if any, then the RHS size statistics. This matters for the + anonymous floats: 'newLvlVar' builds them all with OccName "lvl" and + noSrcSpan, so keys 1-3 are identical and without it their order would fall + back to the Unique-driven input order -- the churn we set out to remove. + (Tidied dumps like -ddump-simpl give the floats distinct names lvl, + lvl1, ...; this additionally stabilises untidied dumps such as + -ddump-simpl-iterations.) It is only a best-effort tie-break -- RHSs + agreeing on both components keep their input order -- and Unique-independent + for the numeric CAFs we target (a rubbish literal is the exception: its + 'cmpLit' falls back to the Unique-dependent 'nonDetCmpType'). + +Recursive groups are never split: a 'Rec' is one 'CoreBind', placed as a unit by +its earliest-source member, with its members sorted by the same key. + +Only *top-level* bindings (and the members of a top-level 'Rec') are reordered. +Bindings nested inside a right-hand side (a 'let'/'letrec' within an expression) +are left in their original order: their position in the dump is fixed by the +surrounding expression rather than chosen by a Unique-keyed sort, so they don't +suffer the cross-module churn this flag addresses. + +-dstable-core-dump-order is opt-in; the default order is retained because it is +useful for debugging the compiler itself. +-} + +-- | The sort key for one top-level binder. The trailing 'RhsKey' is a +-- content-based tiebreak, used only when two binders agree on everything +-- before it. See Note [Stable Core dump order]. +type DumpSortKey = + ( Int -- source-span bucket: 0 = real span, 1 = noSrcSpan (sorts last) + , Int -- source-span start line + , Int -- source-span start column + , Int -- dollar-rank: 0 = derived ($w/$s) binder, 1 = its origin + , String -- the OccName string, a lexical tiebreak + , RhsKey -- content-based tiebreak (see 'rhsKey') + ) + +-- | Reorder a 'CoreProgram' into a stable, source-location-driven order for +-- dumping. See Note [Stable Core dump order]. Used by 'dumpPassResult' when +-- -dstable-core-dump-order is enabled. +sortCoreBindingsForDump :: CoreProgram -> CoreProgram +sortCoreBindingsForDump = sortOn bindKey . map sortRecMembers + where + sortRecMembers (Rec prs) = Rec (sortOn (uncurry elemKey) prs) + sortRecMembers b = b + + -- 'sortRecMembers' runs first, so a 'Rec' is already sorted by 'elemKey' + -- when 'bindKey' sees it; its first member is therefore the minimum key. + bindKey :: CoreBind -> DumpSortKey + bindKey (NonRec b rhs) = elemKey b rhs + bindKey (Rec ((b,rhs):_)) = elemKey b rhs + bindKey (Rec []) = panic "sortCoreBindingsForDump: empty Rec" + + elemKey :: CoreBndr -> CoreExpr -> DumpSortKey + elemKey b rhs = (bucket, line, col, dollar_rank, s, rhsKey rhs) + where + s = getOccString b + (bucket, line, col) = case getSrcSpan b of + RealSrcSpan rs _ -> (0, srcSpanStartLine rs, srcSpanStartCol rs) + _ -> (1, 0, 0) -- noSrcSpan: sort last + -- A '$' anywhere in a tidied top-level OccName marks a compiler-derived + -- binder ($wfoo, but also call-site specialisations tidied to + -- bar_$sfoo); rank those before their origin within a shared source span, + -- mirroring GHC's default dependency order (the wrapper calls the worker, + -- so the worker comes first). + dollar_rank | '$' `elem` s = 0 + | otherwise = 1 + +-- | A content-based tie-break on a binder's right-hand side: see point 4 of +-- Note [Stable Core dump order]. +type RhsKey = + ( Maybe Literal -- the floated literal, if any (Nothing sorts first) + , (Int, Int, Int, Int, Int) -- exprStats counts: terms, types, coercions, value binds, join binds + ) + +rhsKey :: CoreExpr -> RhsKey +rhsKey rhs = (litOf rhs, statsTuple (exprStats rhs)) + where + statsTuple (CS tm ty co vb jb) = (tm, ty, co, vb, jb) + litOf (Lit l) = Just l + litOf (App f a) = case a of { Lit l -> Just l; _ -> litOf f } + litOf (Cast e _) = litOf e + litOf (Tick _ e) = litOf e + litOf _ = Nothing + instance OutputableBndr b => Outputable (Bind b) where ppr bind = ppr_bind noAnn bind ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1594,6 +1594,7 @@ initSDocContext dflags style = SDC , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags , sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags + , sdocStableCoreDumpOrder = gopt Opt_StableCoreDumpOrder dflags , sdocErrorSpans = gopt Opt_ErrorSpans dflags , sdocStarIsType = xopt LangExt.StarIsType dflags , sdocLinearTypes = xopt LangExt.LinearTypes dflags ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -859,6 +859,10 @@ data GeneralFlag | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps + -- | Reorder top-level bindings in Core dumps into a stable, diffable order. + -- See Note [Stable Core dump order] in GHC.Core.Ppr. + | Opt_StableCoreDumpOrder + -- Error message suppression | Opt_ShowErrorContext ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2468,6 +2468,7 @@ dFlagsDeps = [ flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, depFlagSpec' "ppr-ticks" Opt_PprShowTicks (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), + flagSpec "stable-core-dump-order" Opt_StableCoreDumpOrder, flagSpec "suppress-ticks" Opt_SuppressTicks, depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts (useInstead "-d" "suppress-stg-exts"), ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -422,6 +422,7 @@ data SDocContext = SDC , sdocSuppressModulePrefixes :: !Bool , sdocSuppressStgExts :: !Bool , sdocSuppressStgReps :: !Bool + , sdocStableCoreDumpOrder :: !Bool , sdocErrorSpans :: !Bool , sdocStarIsType :: !Bool , sdocLinearTypes :: !Bool @@ -490,6 +491,7 @@ defaultSDocContext = SDC , sdocSuppressModulePrefixes = False , sdocSuppressStgExts = False , sdocSuppressStgReps = True + , sdocStableCoreDumpOrder = False , sdocErrorSpans = False , sdocStarIsType = False , sdocLinearTypes = False ===================================== docs/users_guide/debugging.rst ===================================== @@ -959,6 +959,33 @@ parts that you are not interested in. has shown you where to look, you can try again without :ghc-flag:`-dsuppress-uniques` +.. ghc-flag:: -dstable-core-dump-order + :shortdesc: Reorder top-level bindings in Core dumps into a stable, + diffable order + :type: dynamic + :reverse: -dno-stable-core-dump-order + :category: verbosity + + :since: 10.2.1 + + Normally the order of top-level bindings in a Core dump (such as the + output of :ghc-flag:`-ddump-simpl`) reflects the compiler's internal + processing order, which depends on ``Unique`` values. Those uniques can + shift whenever an unrelated upstream module changes, so the bindings get + re-ordered and a textual ``diff`` of two dumps fails to line up the real + changes. + + This flag is opt-in and reorders the top-level bindings of Core dumps that + go through the pass-result printer (e.g. :ghc-flag:`-ddump-simpl`, + :ghc-flag:`-ddump-prep`, :ghc-flag:`-ddump-ds`, + :ghc-flag:`-ddump-simpl-iterations`) into a stable, source-location-driven + order that does not depend on uniques. + + It is intended to be combined with :ghc-flag:`-dsuppress-uniques` when + diffing two dumps, but because the ordering does not depend on uniques the + output is also more diffable without it. The default (in-compiler) order is + retained because it is useful when debugging the compiler itself. + .. ghc-flag:: -dsuppress-idinfo :shortdesc: Suppress extended information about identifiers where they are bound ===================================== hadrian/src/Hadrian/Oracles/Path.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Hadrian.Oracles.Path ( - lookupInPath, fixAbsolutePathOnWindows, pathOracle + lookupInPath, fixAbsolutePathOnWindows, fixUnixPathsOnWindows, + pathOracle ) where import Control.Monad @@ -33,6 +34,14 @@ fixAbsolutePathOnWindows path = else return path +-- | Fix a unix path list on Windows: +-- * "C:\\foo\\bar;C:\\msys2\\bin" => "/c/foo/bar:/c/msys2/bin" +fixUnixPathsOnWindows :: FilePath -> Action FilePath +fixUnixPathsOnWindows paths = + if isWindows + then askOracle $ UnixPathList paths + else return paths + newtype LookupInPath = LookupInPath String deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult LookupInPath = String @@ -41,6 +50,10 @@ newtype WindowsPath = WindowsPath FilePath deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult WindowsPath = String +newtype UnixPathList = UnixPathList FilePath + deriving (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult UnixPathList = String + -- | Oracles for looking up paths. These are slow and require caching. pathOracle :: Rules () pathOracle = do @@ -50,6 +63,12 @@ pathOracle = do putVerbose $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath return windowsPath + void $ addOracleCache $ \(UnixPathList paths) -> do + Stdout out <- quietly $ cmd ["cygpath", "-p", "-u", paths] + let unixPaths = unifyPath $ dropWhileEnd isSpace out + putVerbose $ "| Unix path mapping: " ++ paths ++ " => " ++ unixPaths + return unixPaths + void $ addOracleCache $ \(LookupInPath name) -> do path <- liftIO getSearchPath exes <- liftIO (findExecutablesInDirectories path name) ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -3,18 +3,19 @@ module Rules.BinaryDist where import CommandLine import Context +import Data.Either +import qualified Data.Set as Set import Expression +import Hadrian.Oracles.Path (fixUnixPathsOnWindows) +import Oracles.Flavour import Oracles.Setting import Packages +import Rules.Generate (generateSettings) import Settings +import qualified System.Directory.Extra as IO import Settings.Program (programContext) import Target import Utilities -import qualified System.Directory.Extra as IO -import Data.Either -import qualified Data.Set as Set -import Oracles.Flavour -import Rules.Generate (generateSettings) {- Note [Binary distributions] @@ -343,7 +344,25 @@ bindistRules = do ghcRoot <- topDirectory copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4") copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib") - buildWithCmdOptions [] $ + + -- Note [Autoreconf unix paths from ACLOCAL_PATH] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable contains Windows- + -- style paths. This happens because MSYS2 automatically converts env variables to + -- Windows-style paths. To fix this, we convert ACLOCAL_PATH back to Unix style. + -- This is done both in the boot Python script and here when building a bindist. + win_host <- isWinHost + env <- if not win_host + then pure [] + else do + aclocalPathMay <- getEnv "ACLOCAL_PATH" + case aclocalPathMay of + Nothing -> pure [] + Just aclocalPath -> do + unixAclocalPath <- fixUnixPathsOnWindows aclocalPath + pure [AddEnv "ACLOCAL_PATH" unixAclocalPath] + + buildWithCmdOptions env $ target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] [] -- We clean after ourselves, moving the configure script we generated in -- our bindist dir ===================================== testsuite/driver/runtests.py ===================================== @@ -133,7 +133,7 @@ if args.unexpected_output_dir: config.unexpected_output_dir = Path(args.unexpected_output_dir) if args.only: - config.only = args.only + config.only = set(args.only) config.run_only_some_tests = True if args.skip: ===================================== testsuite/mk/test.mk ===================================== @@ -109,9 +109,11 @@ endif HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi) -# we need a better way to find which backend is selected and if --check flag is -# used -BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP) +# Detect whether the fast (GMP) bignum backend is in use. The GMP backend module +# in ghc-internal is hidden, so we look instead for the gmp library it links +# against: GMP_LIBS adds gmp to ghc-internal's extra-libraries only on a GMP +# build. +BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-internal extra-libraries 2>/dev/null | grep gmp) ifeq "$(filter thr, $(GhcRTSWays))" "thr" RUNTEST_OPTS += -e config.ghc_with_threaded_rts=True ===================================== testsuite/tests/simplCore/should_compile/Makefile ===================================== @@ -298,3 +298,36 @@ T17901: $(RM) -f T17901.o T17901.hi '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques T17901.hs | grep 'wombat' # All three functions should get their case alternatives combined + +# Check -dstable-core-dump-order on a small Data.Map-style module. The +# sed allow-list prints, deduplicated, the top-level binders we care about in +# dump order. It inspects names only, so it is insensitive to unrelated +# Core-format churn. +# +# The allow-list covers one binder of each interesting category, so the test +# exercises the clustering of generated binders next to their origin: +# * derived instances ($fEqKey/$fOrdKey/$fOrdKey_$ccompare), +# * a call-site specialisation (findI_$slookupG, from lookupG's SPECIALISE), and +# * a recursive worker ($wrotate). +T27296: + $(RM) -f T27296.o T27296.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques \ + -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \ + -dstable-core-dump-order T27296.hs 2> /dev/null \ + | sed -nE 's/^(\$$fEqKey|\$$fOrdKey|\$$fOrdKey_\$$ccompare|size|findI_\$$slookupG|lookupG|member|findI|\$$wrotate|rotate|insertG|insertManyI|insertTwoI|weight|balance|ratios|fromAscI)( .*)?$$/\1/p' \ + | uniq + +# See T27296b.hs for what this pins and why. -ddump-float-out is an untidied +# dump, so the sed normalises it down to just the bindings: it collapses each +# pass header to a bare "Float out" separator (dropping the noisy FOS config) +# and drops the "Result size" and "-- RHS size" lines. +T27296b: + $(RM) -f T27296b.o T27296b.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-float-out -dsuppress-uniques \ + -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \ + -dstable-core-dump-order T27296b.hs 2> /dev/null \ + | sed -E \ + -e '/^=+ Float out/,/=+$$/c\==================== Float out ====================' \ + -e '/^Result size of Float out/,/^ = \{terms/d' \ + -e '/^-- RHS size:/d' \ + | cat -s ===================================== testsuite/tests/simplCore/should_compile/T27296.hs ===================================== @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns #-} + +-- See Note [Stable Core dump order] in GHC.Core.Ppr. +-- +-- A small Data.Map-style module exercising the trickier parts of the stable +-- dump ordering. Under -O it produces, alongside the user functions: +-- * derived Eq/Ord instances for a custom Key type ($fEqKey/$fOrdKey/...), +-- * a call-site specialisation of lookupG (findI_$slookupG), and +-- * a worker/wrapper split of the recursive, strict rotate ($wrotate). +-- Each generated binder inherits its origin's source span, so the stable order +-- clusters it next to that origin. The source order is deliberately neither +-- alphabetical nor the default dump order (insertG forward-references balance), +-- so the test pins source-position ordering specifically. +module T27296 + ( Key(..), size, lookupG, member, findI, rotate, insertG, insertManyI + , insertTwoI, weight, balance, ratios, fromAscI ) + where + +-- A custom key with a derived Ord instance: the derived $fEqKey/$fOrdKey +-- binders inherit this declaration's source span, so they cluster here. +data Key = Key Int deriving (Eq, Ord) + +data Map k a = Tip | Bin !Int k a !(Map k a) !(Map k a) + +data Sizes = Sizes !Int !Int + +size :: Map k a -> Int +size Tip = 0 +size (Bin sz _ _ _ _) = sz + +lookupG :: Ord k => k -> Map k a -> Maybe a +lookupG _ Tip = Nothing +lookupG k (Bin _ kx x l r) = case compare k kx of + LT -> lookupG k l + GT -> lookupG k r + EQ -> Just x +{-# SPECIALISE lookupG :: Key -> Map Key a -> Maybe a #-} + +member :: Key -> Map Key a -> Bool +member k m = case lookupG k m of + Nothing -> False + Just _ -> True + +findI :: Key -> Map Key a -> a -> a +findI k m def = case lookupG k m of + Nothing -> def + Just v -> v + +-- rotate is recursive and strict in the product 'Sizes', so worker/wrapper +-- unboxes it into a recursive worker ($wrotate). The loop only repackages the +-- fields (no arithmetic), so the worker is stable across build flavours. +rotate :: Sizes -> [a] -> Sizes +rotate s [] = s +rotate (Sizes a b) (_:xs) = rotate (Sizes b a) xs + +-- insertG references 'balance', which is defined further down (forward ref). +insertG :: Ord k => k -> a -> Map k a -> Map k a +insertG k x Tip = Bin 1 k x Tip Tip +insertG k x (Bin sz kx kv l r) = case compare k kx of + LT -> balance kx kv (insertG k x l) r + GT -> balance kx kv l (insertG k x r) + EQ -> Bin sz k x l r +{-# SPECIALISE insertG :: Key -> a -> Map Key a -> Map Key a #-} + +insertManyI :: [(Key, a)] -> Map Key a -> Map Key a +insertManyI xs m0 = foldr (\(k, x) m -> insertG k x m) m0 xs + +insertTwoI :: Key -> Key -> a -> Map Key a +insertTwoI k1 k2 x = insertG k1 x (insertG k2 x Tip) + +-- weight unboxes the strict fields of Sizes -> worker/wrapper $wweight. +weight :: Sizes -> Int +weight (Sizes a b) = a * a + 3 * b * b + a * b + 1 + +balance :: k -> a -> Map k a -> Map k a -> Map k a +balance k x l r = Bin (weight (Sizes sl sr)) k x l r + where + sl = size l + sr = size r + +-- baseRatios is a closed constant under a lambda -> floated to a top-level lvl. +ratios :: Int -> [Int] +ratios n = map (n +) baseRatios + where baseRatios = [2, 3, 5, 7, 11, 13] + +fromAscI :: [(Key, a)] -> Map Key a +fromAscI = foldr (\(k, x) m -> insertG k x m) Tip ===================================== testsuite/tests/simplCore/should_compile/T27296.stdout ===================================== @@ -0,0 +1,17 @@ +$fEqKey +$fOrdKey +$fOrdKey_$ccompare +size +findI_$slookupG +lookupG +member +findI +$wrotate +rotate +insertG +insertManyI +insertTwoI +weight +balance +ratios +fromAscI ===================================== testsuite/tests/simplCore/should_compile/T27296b.hs ===================================== @@ -0,0 +1,21 @@ +-- See Note [Stable Core dump order] in GHC.Core.Ppr. +-- +-- Companion to T27296 that pins the ordering of *anonymous* top-level floats. +-- Under -O the boxed Int constants in sel's branches are floated to top level +-- as separate CAFs, all of which the compiler names "lvl" with noSrcSpan (see +-- newLvlVar). Before -dstable-core-dump-order their dump order was the +-- unique-driven processing order; the flag's content-based tie-break (rhsKey) +-- now orders them by literal value -- here 1000..6000, despite the scrambled +-- source order. This dump is intentionally *untidied* (-ddump-float-out), the +-- only place the "lvl" collision is observable; tidied dumps like -ddump-simpl +-- already give the floats distinct names (lvl, lvl1, ...). +module T27296b (sel) where + +{-# NOINLINE sel #-} +sel :: Int -> Int +sel 0 = 5000 +sel 1 = 1000 +sel 2 = 4000 +sel 3 = 2000 +sel 4 = 3000 +sel _ = 6000 ===================================== testsuite/tests/simplCore/should_compile/T27296b.stdout ===================================== @@ -0,0 +1,54 @@ + +==================== Float out ==================== + +sel :: Int -> Int +sel + = \ (ds :: Int) -> + case ds of { I# ds -> + case ds of { + __DEFAULT -> lvl; + 0# -> lvl; + 1# -> lvl; + 2# -> lvl; + 3# -> lvl; + 4# -> lvl + } + } + +lvl :: Int +lvl = I# 1000# + +lvl :: Int +lvl = I# 2000# + +lvl :: Int +lvl = I# 3000# + +lvl :: Int +lvl = I# 4000# + +lvl :: Int +lvl = I# 5000# + +lvl :: Int +lvl = I# 6000# + +==================== Float out ==================== + +$wsel :: Int# -> Int# +$wsel + = \ (ww :: Int#) -> + case ww of { + __DEFAULT -> 6000#; + 0# -> 5000#; + 1# -> 1000#; + 2# -> 4000#; + 3# -> 2000#; + 4# -> 3000# + } + +sel :: Int -> Int +sel + = \ (ds :: Int) -> + case ds of { I# ww -> case $wsel ww of ww { __DEFAULT -> I# ww } } + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -602,3 +602,5 @@ test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) +test('T27296', [], makefile_test, ['T27296']) +test('T27296b', [], makefile_test, ['T27296b']) ===================================== utils/check-exact/Main.hs ===================================== @@ -646,7 +646,7 @@ addLocaLDecl3 :: Changer addLocaLDecl3 libdir top = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = replaceDecls (anchorEof lp) [parent',d2'] + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) [parent',d2'] where lp = top (de1:d2:_) = hsDecls lp @@ -667,7 +667,7 @@ addLocaLDecl4 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let - doAddLocal = replaceDecls (anchorEof lp) (parent':ds) + doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) (parent':ds) where (parent:ds) = hsDecls (makeDeltaAst lp) @@ -781,7 +781,7 @@ rmDecl3 _libdir lp = do rmDecl4 :: Changer rmDecl4 _libdir lp = do let - doRmDecl = replaceDecls (anchorEof lp) [de1',sd1] + doRmDecl = replaceDecls (addModuleCommentOrigDeltas lp) [de1',sd1] where [de1] = hsDecls lp (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] -> ===================================== utils/check-exact/Transform.hs ===================================== @@ -65,7 +65,7 @@ module Transform , balanceComments , balanceCommentsList , balanceCommentsListA - , anchorEof + , addModuleCommentOrigDeltas -- ** Managing lists, pure functions , captureOrderBinds @@ -724,8 +724,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) -- --------------------------------------------------------------------- -anchorEof :: ParsedSource -> ParsedSource -anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) +addModuleCommentOrigDeltas :: ParsedSource -> ParsedSource +addModuleCommentOrigDeltas (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) where an' = addCommentOrigDeltasAnn an View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c83b1d2794a55828567a5b471ea66… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3c83b1d2794a55828567a5b471ea66… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/davide/hadrian_avoid_response_files_2] Hadrian: avoid response files when command line is short enough
by David Eichmann (＠DavidEichmann) 09 Jun '26

09 Jun '26

David Eichmann pushed to branch wip/davide/hadrian_avoid_response_files_2 at Glasgow Haskell Compiler / GHC Commits: 31fcac5a by David Eichmann at 2026-06-09T09:20:42+01:00 Hadrian: avoid response files when command line is short enough This replaces the logic of always using response files on Windows. With the new condition based on command line lenght, reponse files can be avoided in many more cases (on windows). Now that response files are only used in a small number of cases, response files are always kept and the -r / --keep-response-files command line options have been removed The response file paths are nolonger randomized. They are placed in the `_build/rsp` directory. This ensures they are ignored by git and we that Hadrian reuses response file paths when rebuilding rather than leaving stale response files around. Update user guide putting response files in its own section - - - - - 6 changed files: - changelog.d/hadrian-response-files.md - docs/users_guide/using.rst - hadrian/src/Builder.hs - hadrian/src/CommandLine.hs - hadrian/src/Hadrian/Builder/Ar.hs - hadrian/src/Hadrian/Utilities.hs Changes: ===================================== changelog.d/hadrian-response-files.md ===================================== @@ -1,9 +1,15 @@ section: packaging -synopsis: Add a flag to tell Hadrian to keep response files -issues: #27184 -mrs: !15906 +synopsis: Improved Hadrian's use of response files +issues: #27230 +mrs: !15906 !16134 description: - Hadrian can now be instructed to keep response files with the new - --keep-response-files command line flag. This is helpful when debugging a - build failure, as it allows re-running the failing command line invocation - without an error due to a missing response file. + Response files are files that contain command-line arguments. Hadrian uses + response files to shorten command-line lengths. This is important on Windows + where command-line lengths are limited. + + Hadrian now supports response files when invoking GHC. In order to support + manually rerunning commands issued by Hadrian, response files are no longer + deleted. Instead they are stored under `_build/rsp`. Response files are now + only used when the corresponding command-line is too long for the host + platform. This greatly reduces the use of response files and avoids excessive + file usage. Response files are overwritten on subsequent Hadrian builds. ===================================== docs/users_guide/using.rst ===================================== @@ -85,17 +85,6 @@ all files; you cannot, for example, invoke ``ghc -c -O1 Foo.hs -O2 Bar.hs`` to apply different optimisation levels to the files ``Foo.hs`` and ``Bar.hs``. -In addition to passing arguments via the command-line, arguments can be passed -via GNU-style response files. For instance, - -.. code-block:: bash - - $ cat response-file - -O1 - Hello.hs - -o Hello - $ ghc @response-file - .. note:: .. index:: @@ -118,9 +107,24 @@ via GNU-style response files. For instance, ``-fspecialise`` will not be enabled, since the ``-fno-specialise`` overrides the ``-fspecialise`` implied by ``-O1``. + +Command-line arguments in response files +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In addition to passing arguments via the command-line, arguments can be passed +via GNU-style response files. For instance, + +.. code-block:: bash + + $ cat response-file + -O1 + Hello.hs + -o Hello + $ ghc @response-file + .. _source-file-options: -Command line options in source files +Command-line options in source files ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. index:: ===================================== hadrian/src/Builder.hs ===================================== @@ -304,7 +304,7 @@ instance H.Builder Builder where case builder of Ar Pack stg -> do useTempFile <- arSupportsAtFile stg - if useTempFile then runAr path buildArgs buildInputs buildOptions + if useTempFile then runAr output path buildArgs buildInputs buildOptions else runArWithoutTempFile path buildArgs buildInputs buildOptions Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions @@ -343,7 +343,7 @@ instance H.Builder Builder where Exit _ <- cmd' [path] (buildArgs ++ [input]) buildOptions return () - Haddock BuildPackage -> runHaddock path buildArgs buildInputs + Haddock BuildPackage -> runHaddock output path buildArgs buildInputs Ghc _ _ -> -- Use a response file for ghc invocations to avoid issues with command line @@ -351,9 +351,11 @@ instance H.Builder Builder where -- NB: we can't put the buildArgs in a response file, because some flags require -- empty arguments (such as the -dep-suffix flag), but that isn't supported -- yet due to #26560. - withResponseFileOnWindows - (\buildInputs' -> cmd [path] buildArgs buildInputs' buildOptions) + withResponseFileIfLongCmd + output + (toCmdArgument [path] <> toCmdArgument buildArgs) buildInputs + (toCmdArgument buildOptions) HsCpp -> captureStdout @@ -389,13 +391,16 @@ instance H.Builder Builder where -- | Invoke @haddock@ given a path to it and a list of arguments. On Windows, -- the input file arguments are passed as a response file. -runHaddock :: FilePath -- ^ path to @haddock@ +runHaddock :: FilePath -- ^ base name to use for response file + -> FilePath -- ^ path to @haddock@ -> [String] -> [FilePath] -- ^ input file paths -> Action () -runHaddock haddockPath flagArgs fileInputs = withResponseFileOnWindows - (cmd [haddockPath] flagArgs) +runHaddock outputFilePath haddockPath flagArgs fileInputs = withResponseFileIfLongCmd + outputFilePath + (toCmdArgument [haddockPath] <> toCmdArgument flagArgs) fileInputs + (CmdArgument []) -- TODO: Some builders are required only on certain platforms. For example, -- 'Objdump' is only required on OpenBSD and AIX. Add support for platform ===================================== hadrian/src/CommandLine.hs ===================================== @@ -3,8 +3,7 @@ module CommandLine ( lookupBignum, cmdBignum, cmdProgressInfo, cmdCompleteSetting, cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs, - cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs, - cmdKeepResponseFiles + cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs ) where import Data.Either @@ -12,7 +11,7 @@ import qualified Data.HashMap.Strict as Map import Data.List.Extra import Development.Shake hiding (Normal) import Flavour (DocTargets, DocTarget(..)) -import Hadrian.Utilities hiding (buildRoot, keepResponseFiles) +import Hadrian.Utilities hiding (buildRoot) import Settings.Parser import System.Console.GetOpt import System.Environment @@ -37,7 +36,6 @@ data CommandLineArgs = CommandLineArgs , testArgs :: TestArgs , docsArgs :: DocArgs , docTargets :: DocTargets - , keepResponseFiles :: Bool , prefix :: Maybe FilePath , changelogVersion :: Maybe String , completeStg :: Maybe String } @@ -58,7 +56,6 @@ defaultCommandLineArgs = CommandLineArgs , testArgs = defaultTestArgs , docsArgs = defaultDocArgs , docTargets = Set.fromList [minBound..maxBound] - , keepResponseFiles = False , prefix = Nothing , changelogVersion = Nothing , completeStg = Nothing } @@ -141,9 +138,6 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True } readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True } readSkipDepends = Right $ \flags -> flags { skipDepends = True } -readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs) -readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True } - readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs) readUnitIdHash = Right $ \flags -> trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $ @@ -302,8 +296,6 @@ optDescrs = "Progress info style (None, Brief, Normal or Unicorn)." , Option [] ["docs"] (ReqArg readDocsArg "TARGET") "Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]." - , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles) - "Keep response files created during the build (for debugging)." , Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles) "Keep all the files generated when running the testsuite." , Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER") @@ -382,7 +374,6 @@ cmdLineArgsMap = do return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities $ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities - $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities $ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest $ insertExtra (docsArgs args) -- Accessed by Rules.Documentation $ insertExtra allSettings -- Accessed by Settings @@ -424,9 +415,6 @@ cmdUnitIdHash = unitIdHash <$> cmdLineArgs cmdBignum :: Action (Maybe String) cmdBignum = bignum <$> cmdLineArgs -cmdKeepResponseFiles :: Action Bool -cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs - cmdProgressInfo :: Action ProgressInfo cmdProgressInfo = progressInfo <$> cmdLineArgs ===================================== hadrian/src/Hadrian/Builder/Ar.hs ===================================== @@ -35,14 +35,16 @@ instance NFData ArMode -- to be archived is passed via a temporary response file. Passing arguments -- via a response file is not supported by some versions of @ar@, in which -- case you should use 'runArWithoutTempFile' instead. -runAr :: FilePath -- ^ path to @ar@ +runAr :: FilePath -- ^ base name to use for response files + -> FilePath -- ^ path to @ar@ -> [String] -- ^ other arguments -> [FilePath] -- ^ input file paths -> [CmdOption] -- ^ Additional options -> Action () -runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do - writeFile' tmp $ unwords fileArgs - cmd [arPath] flagArgs ('@' : tmp) buildOptions +runAr outputFilePath arPath flagArgs fileArgs buildOptions = do + rspFile <- responseFilePath outputFilePath + writeFile' rspFile $ unwords fileArgs + cmd [arPath] flagArgs ('@' : rspFile) buildOptions -- | Invoke @ar@ given a path to it and a list of arguments. Note that @ar@ -- will be called multiple times if the list of files to be archived is too ===================================== hadrian/src/Hadrian/Utilities.hs ===================================== @@ -1,4 +1,6 @@ +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE TypeFamilies #-} + module Hadrian.Utilities ( -- * List manipulation fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize, @@ -14,7 +16,7 @@ module Hadrian.Utilities ( -- * Paths BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource, - KeepResponseFiles (..), keepResponseFiles, withResponseFile, withResponseFileOnWindows, + withResponseFileIfLongCmd, responseFilePath, -- * File system operations copyFile, copyFileUntracked, createFileLink, fixFile, @@ -47,11 +49,10 @@ import Data.Maybe import Data.Typeable (TypeRep, typeOf) import Development.Shake hiding (Normal) import Development.Shake.Classes +import Development.Shake.Command (CmdArgument (..), IsCmdArgument (toCmdArgument)) import Development.Shake.FilePath import GHC.ResponseFile (escapeArgs) import System.Environment (lookupEnv) -import System.Info.Extra (isWindows) -import System.IO (hClose, openTempFile) import System.IO.Error (isPermissionError) import qualified Data.ByteString as BS @@ -255,13 +256,13 @@ infix 1 %%> -- library, they can reach 2MB! Some operating systems do not support command -- lines of such length, and this function can be used to obtain a reasonable -- approximation of the limit. On Windows, it is theoretically 32768 characters --- (since Windows 7). In practice we use 31000 to leave some breathing space for +-- (since Windows 7). In practice we use 30000 to leave some breathing space for -- the builder path & name, auxiliary flags, and other overheads. On Mac OS X, -- ARG_MAX is 262144, yet when using @xargs@ on OSX this is reduced by over -- 20000. Hence, 200000 seems like a sensible limit. On other operating systems -- we currently use the 4194304 setting. cmdLineLengthLimit :: Int -cmdLineLengthLimit | IO.isWindows = 31000 +cmdLineLengthLimit | IO.isWindows = 30000 | IO.isMac = 200000 | otherwise = 4194304 @@ -321,53 +322,35 @@ buildRootRules = do isGeneratedSource :: FilePath -> Action Bool isGeneratedSource file = buildRoot <&> (`isPrefixOf` file) -newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show) - --- | Whether to retain response files after the build action that created them --- completes. Mainly useful for debugging. -keepResponseFiles :: Action Bool -keepResponseFiles = do - KeepResponseFiles keep <- userSetting (KeepResponseFiles False) - return keep - --- | Run an action either with command arguments direcly or by, on Windows, --- placing those arguments into a response file escaped with @GHC.ResponseFile.escapeArgs@. --- --- With @--keep-response-files@, the file is left on disk (if used) -withResponseFileOnWindows :: - ([String] -> Action a) -- ^ Action to perform given arguments (of the form @["\@reponseFilePath"]@ on Windows) - -> [String] -- ^ Command arguments - -> Action a -withResponseFileOnWindows action commandArgs = do - if isWindows - then withResponseFile $ \tmp -> do - writeFile' tmp (escapeArgs commandArgs) - action ['@' : tmp] - else action commandArgs - --- | Run an action with a response file path. --- --- With @--keep-response-files@, the file is left on disk. -withResponseFile :: (FilePath -> Action a) -> Action a -withResponseFile action = do - keep <- keepResponseFiles - let putVerboseResponseFile tmp = do - verbosity <- getVerbosity - when (verbosity >= Verbose) $ do - tmpContent <- liftIO (readFile tmp) - putVerbose (tmp <> " (use hadrian flag --keep-response-files to keep this file):\n" <> tmpContent) - if keep - then do - (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp" - liftIO $ hClose h - putInfo $ "Keeping response file: " ++ tmp - result <- action tmp - putVerboseResponseFile tmp - return result - else withTempFile $ \tmp -> do - result <- action tmp - putVerboseResponseFile tmp - return result +-- | Run an command with the given arguments. If the command is too long then the +-- response file arguments are placed into a response file and escaped with @GHC.ResponseFile.escapeArgs@. +withResponseFileIfLongCmd :: + CmdResult c + => FilePath -- ^ Response base name. The reponse file is placed in @_build/rsp/\<Response base name\>@. + -> CmdArgument -- ^ Command and arguments before the response file arguments. + -> [String] -- ^ Response file aruguments. + -> CmdArgument -- ^ Command arguments after the response file arguments. + -> Action c +withResponseFileIfLongCmd outputFilePath argsPre argsResp argsPost = do + let cmdLineLengh = sum + [ 1 + length arg -- add one to account for space inbetween arguments + | let CmdArgument args = argsPre <> toCmdArgument argsResp <> argsPost + , Right arg <- args + ] + if cmdLineLengh < cmdLineLengthLimit + then cmd argsPre argsResp argsPost + else do + rspFile <- responseFilePath outputFilePath + writeFile' rspFile (escapeArgs argsResp) + cmd argsPre ['@' : rspFile] argsPost + +-- | Convert a command's output file path to a response file path to be used for that command. +-- Response files are placed in a dedicated @rps@ directory under the build directory. This avoids +-- clutering the work tree or interfearing with other build directories. +responseFilePath :: FilePath -> Action FilePath +responseFilePath outputFilePath = do + buildDir <- buildRoot + return $ buildDir </> "rsp" </> outputFilePath -- | Link a file tracking the link target. Create the target directory if -- missing. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31fcac5a3e63d10efb53a5dc174fd0e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31fcac5a3e63d10efb53a5dc174fd0e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/ghc-9-14-building-base] Add installation of GHC 9.14.1
by Wolfgang Jeltsch (＠jeltsch) 09 Jun '26

09 Jun '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/ghc-9-14-building-base at Glasgow Haskell Compiler / GHC Commits: 4c6f494e by Wolfgang Jeltsch at 2026-06-08T16:25:20+03:00 Add installation of GHC 9.14.1 - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -1154,15 +1154,23 @@ base-build-with-ghc-914: - job: release-x86_64-linux-deb13-release optional: true dependencies: null - image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb13:$DOCKER_REV" + image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb12:$DOCKER_REV" tags: - x86_64-linux script: - - printf '%s\n' 'Check for some tools …' - | - type ghcup - type ghc && ghc --version - type cabal + ghc_version=9.14.1 + url=https://downloads.haskell.org/~ghc/$ghc_version/ghc-$ghc_version-x86_64… + curl "$url" >ghc-$ghc_version.tar.xz + tar -xJF ghc-$ghc_version.tar.xz + cd ghc-$ghc_version + ./configure --prefix "$PWD/../ghc" + make install + cd - + printf '%s\n' 'To be continued …' + printf '%s\n' 'For now some debug output:' + shopt -s globstar + ls -l ghc/**/bin rules: - *full-ci View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c6f494e40ad95b5bab2f6c3864ffbf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4c6f494e40ad95b5bab2f6c3864ffbf… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 2 commits: EPA Remove LocatedLC / LocatedLS
by Alan Zimmerman (＠alanz) 09 Jun '26

09 Jun '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: d18f8202 by Alan Zimmerman at 2026-06-07T22:06:59+01:00 EPA Remove LocatedLC / LocatedLS LocatedLC/LocatedLS were unused - - - - - ce98f3ce by Alan Zimmerman at 2026-06-08T23:15:52+01:00 EPA: Remove LocatedLW from LStmtLR - - - - - 11 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Tc/Gen/Match.hs - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -535,9 +535,6 @@ type instance XPragE (GhcPass _) = NoExtField type instance XFunRhs = AnnFunRhs -type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW -type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA - mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p) mkHsVar n = HsVar noExtField $ case ghcPass @p of @@ -2647,8 +2644,10 @@ instance UnXRec p => Outputable (DotFieldOcc p) where type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnA -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnA +-- type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnA +-- type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA @@ -2664,7 +2663,8 @@ type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnA +-- type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO type instance Anno FieldLabelString = SrcSpanAnnN ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -320,8 +320,10 @@ nlParPat p = noLocA (gParPat p) mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs -mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs +-- mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsDo :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> HsExpr GhcPs +-- mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs +mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs @@ -349,12 +351,14 @@ mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc) emptyRecStmt :: (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] - ~ SrcSpanAnnLW) + -- ~ SrcSpanAnnLW) + ~ SrcSpanAnnA) => StmtLR (GhcPass idL) GhcPs bodyR emptyRecStmtName :: (Anno [GenLocated (Anno (StmtLR GhcRn GhcRn bodyR)) (StmtLR GhcRn GhcRn bodyR)] - ~ SrcSpanAnnLW) + -- ~ SrcSpanAnnLW) + ~ SrcSpanAnnA) => StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) @@ -362,9 +366,11 @@ mkRecStmt :: forall (idL :: Pass) bodyR. (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] - ~ SrcSpanAnnLW) + -- ~ SrcSpanAnnLW) + ~ SrcSpanAnnA) => AnnList (EpToken "rec") - -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR] + -- -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR] + -> LocatedA [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) { recS_stmts = stmts } ===================================== compiler/GHC/Parser.y ===================================== @@ -3144,15 +3144,17 @@ aexp :: { ECP } return $ ECP $ $2 >>= \ $2 -> mkHsDoPV (comb2 $1 $2) + (stmtlistAnns $2) (fmap mkModuleNameFS (getDO $1)) - $2 + (stmtlistStmts $2) (glR $1) (glR $2) } | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 -> fmap ecpFromExp $ amsA' (L (comb2 $1 $2) - (mkMDo (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) - $2 + (mkMDo (stmtlistAnns $2) + (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) + (stmtlistStmts $2) (glR $1) (glR $2))) } | 'proc' aexp '->' exp @@ -3648,11 +3650,11 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))]) } +stmtlist :: { forall b. DisambECP b => PV (LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), [LocatedA (Stmt GhcPs (LocatedA b))])) } : '{' stmts '}' { $2 >>= \ $2 -> - amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) noAnn []) } - | vocurly stmts close { $2 >>= \ $2 -> amsr - (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) ListNone (fromOL $ fst $ unLoc $2) noAnn []) } + amsA' (sLL $1 $> ((epTok $1, fromOL $ fst $ unLoc $2, epTok $3), reverse $ snd $ unLoc $2))} + | vocurly stmts close { $2 >>= \ $2 -> + amsA' (L (stmtsLoc $2) ((NoEpTok, fromOL $ fst $ unLoc $2, NoEpTok), reverse $ snd $ unLoc $2))} -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -3694,7 +3696,8 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> - amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) $2) $2) } + amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) (stmtlistAnns $2) $2) + (stmtlistStmts $2)) } qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : bindpat '<-' exp { unECP $3 >>= \ $3 -> @@ -4717,9 +4720,9 @@ commentsPA la@(L l a) = do !cs <- getPriorCommentsFor (getLocA la) return (L (addCommentsToEpAnn l cs) a) -hsDoAnn :: EpToken "rec" -> LocatedAn t b -> AnnList (EpToken "rec") -hsDoAnn tok (L ll _) - = AnnList (Just $ spanAsAnchor (locA ll)) ListNone [] tok [] +hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> AnnList (EpToken "rec") +hsDoAnn rec (ob, semis, cb) (L ll _) + = AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis rec [] listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation listAsAnchorM [] = Nothing @@ -4745,6 +4748,16 @@ epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2) -- ------------------------------------- +stmtlistStmts :: LocatedA (a, [LocatedA (Stmt GhcPs (LocatedA b))]) + -> LocatedA [LocatedA (Stmt GhcPs (LocatedA b))] +stmtlistStmts (L la (_,stmts)) = L la stmts + +stmtlistAnns :: LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), a) + -> (EpToken "{", [EpToken ";"], EpToken "}") +stmtlistAnns (L _ (an,_)) = an + +-- ------------------------------------- + addTrailingCommaFBind :: MonadP m => Fbind b -> EpToken "," -> m (Fbind b) addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l) addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l) ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -28,10 +28,10 @@ module GHC.Parser.Annotation ( -- ** Annotations in 'GenLocated' LocatedA, LocatedN, LocatedAn, LocatedP, - LocatedLC, LocatedLS, LocatedLW, + LocatedLW, LocatedE, LocatedBF, SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN, - SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, + SrcSpanAnnLW, SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' @@ -432,19 +432,13 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN --- type LocatedL = GenLocated SrcSpanAnnL -type LocatedLC = GenLocated SrcSpanAnnLC -type LocatedLS = GenLocated SrcSpanAnnLS type LocatedLW = GenLocated SrcSpanAnnLW type LocatedP = GenLocated SrcSpanAnnP --- type LocatedC = GenLocated SrcSpanAnnC type LocatedBF = GenLocated SrcSpanAnnBF type SrcSpanAnnA = EpAnn AnnListItem type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","]) -type SrcSpanAnnLS = EpAnn (AnnList ()) type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where")) type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnBF = EpAnn AnnBooleanFormula ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -436,9 +436,10 @@ mkRoleAnnotDecl loc tycon roles anns addFatalError $ mkPlainErrorMsgEnvelope loc_role $ (PsErrIllegalRoleName role nearby) -mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs -mkMDo ctxt stmts tok loc - = mkHsDoAnns ctxt stmts (AnnList (Just loc) ListNone [] tok []) +-- mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs +mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs +mkMDo (ob, semis, cb) ctxt stmts tok loc + = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis tok []) -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if @@ -1733,7 +1734,8 @@ type AnnoBody b , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA , Anno [LocatedA (StmtLR GhcPs GhcPs - (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW + -- (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW + (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnA ) -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are @@ -1795,8 +1797,10 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | Disambiguate "do { ... }" (do notation) mkHsDoPV :: SrcSpan -> + (EpToken "{", [EpToken ";"], EpToken "}") -> Maybe ModuleName -> - LocatedLW [LStmt GhcPs (LocatedA b)] -> + -- LocatedLW [LStmt GhcPs (LocatedA b)] -> + LocatedA [LStmt GhcPs (LocatedA b)] -> EpaLocation -> -- Token EpaLocation -> -- Anchor PV (LocatedA b) @@ -1948,10 +1952,10 @@ instance DisambECP (HsCmd GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) - mkHsDoPV l Nothing stmts tok_loc anc = do + mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) ListNone [] tok_loc []) stmts) - mkHsDoPV l (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis tok_loc []) stmts) + mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c) @@ -2047,9 +2051,9 @@ instance DisambECP (HsExpr GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) - mkHsDoPV l mod stmts loc_tok anc = do + mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) ListNone [] loc_tok []) (DoExpr mod) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis loc_tok []) (DoExpr mod) stmts) mkHsParPV l lpar e rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) @@ -2145,7 +2149,7 @@ instance DisambECP (PatBuilder GhcPs) where !cs <- getCommentsFor (locA l) return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat - mkHsDoPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat + mkHsDoPV l _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do ===================================== compiler/GHC/Parser/Types.hs ===================================== @@ -110,7 +110,8 @@ instance Outputable DataConBuilder where ppr (InfixDataConBuilder lhs data_con rhs) = ppr lhs <+> ppr data_con <+> ppr rhs -type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW +-- type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnA data ExplicitNamespaceKeyword = ExplicitTypeNamespace !(EpToken "type") ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -376,7 +376,8 @@ tcGRHSNE ctxt tc_body grhss res_ty -} tcDoStmts :: HsDoFlavour - -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)] + -- -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)] + -> LocatedA [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTc) -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -287,7 +287,9 @@ (AnnList (Just (EpaSpan { DumpParsedAstComments.hs:16:3 })) - (ListNone) + (ListBraces + (NoEpTok) + (NoEpTok)) [] (EpaSpan { DumpParsedAstComments.hs:14:7-8 }) []) @@ -296,12 +298,7 @@ (L (EpAnn (EpaSpan { DumpParsedAstComments.hs:16:3 }) - (AnnList - (Just - (EpaSpan { DumpParsedAstComments.hs:16:3 })) - (ListNone) - [] - (NoEpTok) + (AnnListItem []) (EpaComments [])) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -337,7 +337,9 @@ (AnnList (Just (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) - (ListNone) + (ListBraces + (NoEpTok) + (NoEpTok)) [] (EpaSpan { DumpSemis.hs:10:7-8 }) []) @@ -346,12 +348,7 @@ (L (EpAnn (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) - (ListNone) - [] - (NoEpTok) + (AnnListItem []) (EpaComments [])) @@ -375,8 +372,17 @@ (AnnList (Just (EpaSpan { DumpSemis.hs:11:6-15 })) - (ListNone) - [] + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:11:6 })) + (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:11:8 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:9 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:10 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:11 }))] (EpaSpan { DumpSemis.hs:11:3-4 }) []) (DoExpr @@ -384,21 +390,7 @@ (L (EpAnn (EpaSpan { DumpSemis.hs:11:6-15 }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:11:8-13 })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:11:6 })) - (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:11:8 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:9 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:10 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:11 }))] - (NoEpTok) + (AnnListItem []) (EpaComments [])) @@ -649,8 +641,13 @@ (AnnList (Just (EpaSpan { DumpSemis.hs:(16,3)-(19,3) })) - (ListNone) - [] + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:16:3 })) + (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:16:5 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:16:8 }))] (EpaSpan { DumpSemis.hs:15:7-8 }) []) (DoExpr @@ -658,17 +655,7 @@ (L (EpAnn (EpaSpan { DumpSemis.hs:(16,3)-(19,3) }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(16,5)-(18,5) })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:16:3 })) - (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:16:5 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:16:8 }))] - (NoEpTok) + (AnnListItem []) (EpaComments [])) @@ -913,8 +900,13 @@ (AnnList (Just (EpaSpan { DumpSemis.hs:22:10-30 })) - (ListNone) - [] + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:22:10 })) + (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:22:12 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:22:13 }))] (EpaSpan { DumpSemis.hs:22:7-8 }) []) (DoExpr @@ -922,17 +914,7 @@ (L (EpAnn (EpaSpan { DumpSemis.hs:22:10-30 }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:22:12-28 })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:22:10 })) - (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:22:12 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:22:13 }))] - (NoEpTok) + (AnnListItem []) (EpaComments [])) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1447,10 +1447,14 @@ instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where a' <- markAnnotated a return (L la a') -instance (ExactPrint a) => ExactPrint [a] where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor ls _ _ _ = ls - exact ls = mapM markAnnotated ls +-- --------------------------------------------------------------------- + +-- instance (ExactPrint a) => ExactPrint [a] where +-- getAnnotationEntry = const NoEntryVal +-- setAnnotationAnchor ls _ _ _ = ls +-- exact ls = mapM markAnnotated ls + +-- --------------------------------------------------------------------- instance (ExactPrint a) => ExactPrint (Maybe a) where getAnnotationEntry = const NoEntryVal @@ -1489,7 +1493,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- markAnnotated exps + exps' <- mapM markAnnotated exps tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) @@ -1570,7 +1574,7 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os - ws' <- markAnnotated ws + ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) @@ -1578,7 +1582,7 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os - ws' <- markAnnotated ws + ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) @@ -1706,7 +1710,7 @@ instance ExactPrint HsDocString where pe <- getPriorEndD debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x) x' <- markAnnotated x - xs' <- markAnnotated (map dedentDocChunk xs) + xs' <- mapM markAnnotated (map dedentDocChunk xs) return (MultiLineDocString decorator (x' :| xs')) exact x = do -- TODO: can this happen? @@ -1929,7 +1933,7 @@ instance ExactPrint (WarnDecls GhcPs) where exact (Warnings ((o,c),src) warns) = do o' <- markAnnOpen'' o src "{-# WARNING" -- Note: might be {-# DEPRECATED - warns' <- markAnnotated warns + warns' <- mapM markAnnotated warns c' <- markEpToken c return (Warnings ((o',c'),src) warns') @@ -1942,17 +1946,17 @@ instance ExactPrint (WarnDecl GhcPs) where exact (Warning (o,c) ns_spec lns (WarningTxt src mb_cat ls )) = do mb_cat' <- markAnnotated mb_cat ns_spec' <- exactNsSpec ns_spec - lns' <- markAnnotated lns + lns' <- mapM markAnnotated lns o' <- markEpToken o - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls c' <- markEpToken c return (Warning (o',c') ns_spec' lns' (WarningTxt src mb_cat' ls')) exact (Warning (o,c) ns_spec lns (DeprecatedTxt src ls)) = do ns_spec' <- exactNsSpec ns_spec - lns' <- markAnnotated lns + lns' <- mapM markAnnotated lns o' <- markEpToken o - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls c' <- markEpToken c return (Warning (o',c') ns_spec' lns' (DeprecatedTxt src ls')) @@ -1996,7 +2000,7 @@ instance ExactPrint (RuleDecls GhcPs) where case src of NoSourceText -> printStringAtAA o "{-# RULES" SourceText srcTxt -> printStringAtAA o (unpackFS srcTxt) - rules' <- markAnnotated rules + rules' <- mapM markAnnotated rules c' <- markEpToken c return (HsRules ((o',c'),src) rules') @@ -2188,7 +2192,7 @@ exactHsFamInstLHS ops cps thing bndrs typats fixity mb_ctxt = do exact_pats ops0 cps0 pats = do ops' <- mapM markEpToken ops0 thing' <- markAnnotated thing - pats' <- markAnnotated pats + pats' <- mapM markAnnotated pats cps' <- mapM markEpToken cps0 return (ops', cps', thing', pats') @@ -2318,7 +2322,7 @@ instance ExactPrint (HsBind GhcPs) where return (FunBind x fun_id' matches') exact (PatBind x pat q grhss) = do - q' <- markAnnotated q + q' <- mapM markAnnotated q pat' <- markAnnotated pat grhss' <- markAnnotated grhss return (PatBind x pat' q' grhss') @@ -2348,12 +2352,12 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where return (psyn', InfixCon x v1' v2') PrefixCon x vs -> do psyn' <- markAnnotated psyn - vs' <- markAnnotated vs + vs' <- mapM markAnnotated vs return (psyn', PrefixCon x vs') RecCon (ao,ac) vs -> do psyn' <- markAnnotated psyn ao' <- markEpToken ao - vs' <- markAnnotated vs + vs' <- mapM markAnnotated vs ac' <- markEpToken ac return (psyn', RecCon (ao',ac') vs') @@ -2424,7 +2428,7 @@ exactMatch (Match an mctxt pats grhss) = do epTokensToComments "(" opens epTokensToComments ")" closes fun' <- markAnnotated fun - pats' <- markAnnotated pats + pats' <- (mapM . mapM) markAnnotated pats return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), pats') Infix -> case pats of @@ -2445,11 +2449,11 @@ exactMatch (Match an mctxt pats grhss) = do _ -> panic "FunRhs" LamAlt v -> do - pats' <- markAnnotated pats + pats' <- (mapM . mapM) markAnnotated pats return (LamAlt v, pats') CaseAlt -> do - pats' <- markAnnotated pats + pats' <- (mapM . mapM) markAnnotated pats return (CaseAlt, pats') _ -> do @@ -2548,7 +2552,7 @@ instance ExactPrint (HsIPBinds GhcPs) where setAnnotationAnchor a _ _ _ = a exact (IPBinds x binds) = setLayoutBoth $ do - binds' <- markAnnotated binds + binds' <- mapM markAnnotated binds return (IPBinds x binds') -- --------------------------------------------------------------------- @@ -2617,13 +2621,13 @@ instance ExactPrint (Sig GhcPs) where setAnnotationAnchor a _ _ _ = a exact (TypeSig (AnnSig dc mp md) mods vars ty) = do - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods (dc', vars', ty') <- exactVarSig dc vars ty return (TypeSig (AnnSig dc' mp md) mods' vars' ty') exact (PatSynSig (AnnSig dc mp md) lns typ) = do mp' <- mapM markEpToken mp - lns' <- markAnnotated lns + lns' <- mapM markAnnotated lns dc' <- markEpUniToken dc typ' <- markAnnotated typ return (PatSynSig (AnnSig dc' mp' md) lns' typ') @@ -2645,7 +2649,7 @@ instance ExactPrint (Sig GhcPs) where af' <- printStringAtAA af fixstr ma' <- mapM (\l -> printStringAtAA l (sourceTextToString src (show v))) ma ns' <- markAnnotated ns - names' <- markAnnotated names + names' <- mapM markAnnotated names return (FixSig ((af',ma'),src) (FixitySig noExtField ns' names' (Fixity v fdir))) exact (InlineSig (o,c,act) ln inl) = do @@ -2660,7 +2664,7 @@ instance ExactPrint (Sig GhcPs) where act' <- markActivation act (inlinePragmaActivation inl) ln' <- markAnnotated ln dc' <- traverse markEpUniToken dc - typs' <- markAnnotated typs + typs' <- mapM markAnnotated typs c' <- markEpToken c return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl) @@ -2749,11 +2753,11 @@ instance ExactPrint (DefaultDecl GhcPs) where setAnnotationAnchor a _ _ _ = a exact (DefaultDecl (d,op,cp) mods cl tys) = do - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods d' <- markEpToken d cl' <- markAnnotated cl op' <- markEpToken op - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys cp' <- markEpToken cp return (DefaultDecl (d',op',cp') mods' cl' tys') @@ -2792,10 +2796,10 @@ instance ExactPrint (BF.BooleanFormula GhcPs) where x' <- markAnnotated x return (BF.Var x') exact (BF.Or ls) = do - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls return (BF.Or ls') exact (BF.And ls) = do - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls return (BF.And ls') exact (BF.Parens x) = do x' <- markAnnotated x @@ -2992,13 +2996,13 @@ instance ExactPrint (HsExpr GhcPs) where exact (HsDo an do_or_list_comp stmts) = do debugM $ "HsDo" - (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts + (an',stmts') <- markAnnListA' an0 $ \a -> exactDo a do_or_list_comp stmts return (HsDo an' do_or_list_comp stmts') exact (ExplicitList an es) = do debugM $ "ExplicitList start" an0 <- markLensBracketsO' an lal_brackets - es' <- markAnnotated es + es' <- mapM markAnnotated es an1 <- markLensBracketsC' an0 lal_brackets debugM $ "ExplicitList end" return (ExplicitList an1 es') @@ -3081,7 +3085,7 @@ instance ExactPrint (HsExpr GhcPs) where exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do o' <- markEpToken o oc' <- markEpToken oc - e' <- markAnnotated e + e' <- mapM markAnnotated e cc' <- markEpToken cc c' <- markEpUniToken c return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e')) @@ -3151,7 +3155,7 @@ instance ExactPrint (HsExpr GhcPs) where exact (HsQual (op,cp,da) ctxt body) = do op' <- mapM markEpToken op - ctxt' <- markAnnotated ctxt + ctxt' <- mapM markAnnotated ctxt cp' <- mapM markEpToken cp da' <- markEpUniToken da body' <- markAnnotated body @@ -3277,7 +3281,7 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where setAnnotationAnchor a _ _ _ = a exact (HsRecFields (oc,cc) fields mdot) = do oc' <- markEpToken oc - fields' <- markAnnotated fields + fields' <- mapM markAnnotated fields mdot' <- case mdot of Nothing -> return Nothing Just (L ss d) -> do @@ -3329,11 +3333,11 @@ instance ExactPrint (LHsRecUpdFields GhcPs) where exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do debugM $ "RegularRecUpdFields" - rbinds' <- markAnnotated rbinds + rbinds' <- mapM markAnnotated rbinds return $ flds { recUpdFields = rbinds' } exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do debugM $ "OverloadedRecUpdFields" - pbinds' <- markAnnotated pbinds + pbinds' <- mapM markAnnotated pbinds return $ flds { olRecUpdFields = pbinds' } -- --------------------------------------------------------------------- @@ -3419,11 +3423,11 @@ instance ExactPrint (HsCmd GhcPs) where (Infix, (arg1:argrest)) -> do arg1' <- markAnnotated arg1 e' <- markAnnotated e - argrest' <- markAnnotated argrest + argrest' <- mapM markAnnotated argrest return (e', arg1':argrest') (Prefix, _) -> do e' <- markAnnotated e - cs' <- markAnnotated cs + cs' <- mapM markAnnotated cs return (e', cs') (Infix, []) -> error "Not possible" an1 <- markLensBracketsC' an0 lal_brackets @@ -3475,19 +3479,24 @@ instance ExactPrint (HsCmd GhcPs) where e' <- markAnnotated e return (HsCmdLet (tkLet', tkIn') binds' e') - exact (HsCmdDo an es) = do + exact (HsCmdDo an (L l es)) = do debugM $ "HsCmdDo" - an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do") - es' <- markAnnotated es - return (HsCmdDo an0 es') + an0 <- markLensFun an lal_rest (\ll -> printStringAtAA ll "do") + (an1,es') <- markAnnList' an0 $ do + ee <- mapM markAnnotated es + return ee + -- es' <- mapM markAnnotated es + return (HsCmdDo an1 (L l es')) -- --------------------------------------------------------------------- instance ( ExactPrint (LocatedA (body GhcPs)), Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, - Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW, - (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + -- Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW, + Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnA, + -- (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + (ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _s = a @@ -3657,7 +3666,7 @@ instance ExactPrint (TyClDecl GhcPs) where tcdModifiers = mods'}) where top_matter = do - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods epTokensToComments "(" ops epTokensToComments ")" cps c' <- markEpToken c @@ -3666,7 +3675,7 @@ instance ExactPrint (TyClDecl GhcPs) where then return (vb, fds) else do vb' <- markEpToken vb - fds' <- markAnnotated fds + fds' <- mapM markAnnotated fds return (vb', fds') w' <- markEpToken w return (mods', c', w', vb', fds', lclas', tyvars',context') @@ -3679,9 +3688,9 @@ instance ExactPrint (FunDep GhcPs) where setAnnotationAnchor a _ _ _ = a exact (FunDep an ls rs') = do - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls an0 <- markEpUniToken an - rs'' <- markAnnotated rs' + rs'' <- mapM markAnnotated rs' return (FunDep an0 ls' rs'') -- --------------------------------------------------------------------- @@ -3723,7 +3732,7 @@ instance ExactPrint (FamilyDecl GhcPs) where dd' <- markEpToken dd return (dd', mb_eqns) Just eqns -> do - eqns' <- markAnnotated eqns + eqns' <- mapM markAnnotated eqns return (dd, Just eqns') cc' <- markEpToken cc return (w',oc',dd',cc', ClosedTypeFamily mb_eqns') @@ -3844,12 +3853,12 @@ exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context varl' <- markAnnotated varl thing' <- markAnnotated thing hvarsr' <- markAnnotated hvarsr - tvarsr' <- markAnnotated tvarsr + tvarsr' <- mapM markAnnotated tvarsr return (thing', varl':hvarsr':tvarsr') | fixity == Infix = do varl' <- markAnnotated varl thing' <- markAnnotated thing - varsr' <- markAnnotated varsr + varsr' <- mapM markAnnotated varsr return (thing', varl':varsr') | otherwise = do thing' <- markAnnotated thing @@ -3984,12 +3993,12 @@ instance ExactPrint (HsType GhcPs) where return (HsListTy (o',c') t') exact (HsTupleTy an con tys) = do an0 <- markOpeningParen an - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys an1 <- markClosingParen an0 return (HsTupleTy an1 con tys') exact (HsSumTy an tys) = do an0 <- markOpeningParen an - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys an1 <- markClosingParen an0 return (HsSumTy an1 tys') exact (HsOpTy x t1 lo t2) = do @@ -4030,7 +4039,7 @@ instance ExactPrint (HsType GhcPs) where then markEpToken sq else return sq o' <- markEpToken o - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys c' <- markEpToken c return (HsExplicitListTy (sq',o',c') prom tys') exact (HsExplicitTupleTy (sq, an) prom tys) = do @@ -4038,7 +4047,7 @@ instance ExactPrint (HsType GhcPs) where then markEpToken sq else return sq an0 <- markOpeningParen an - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys an1 <- markClosingParen an0 return (HsExplicitTupleTy (sq', an1) prom tys') exact (HsTyLit an lit) = do @@ -4060,13 +4069,13 @@ instance ExactPrint (HsForAllTelescope GhcPs) where exact (HsForAllVis (EpAnn l (f,r) cs) bndrs) = do f' <- markEpUniToken f - bndrs' <- markAnnotated bndrs + bndrs' <- mapM markAnnotated bndrs r' <- markEpUniToken r return (HsForAllVis (EpAnn l (f',r') cs) bndrs') exact (HsForAllInvis (EpAnn l (f,d) cs) bndrs) = do f' <- markEpUniToken f - bndrs' <- markAnnotated bndrs + bndrs' <- mapM markAnnotated bndrs d' <- markEpToken d return (HsForAllInvis (EpAnn l (f',d') cs) bndrs') @@ -4119,7 +4128,7 @@ instance (ExactPrint a) => ExactPrint (HsContextDetails GhcPs a) where exact (HsContext (opens, closes) tys) = do opens' <- mapM markEpToken opens - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys closes' <- mapM markEpToken closes return (HsContext (opens', closes') tys') @@ -4135,7 +4144,7 @@ instance ExactPrint (DerivClauseTys GhcPs) where return (DctSingle x ty') exact (DctMulti (op,cp) tys) = do op' <- markEpToken op - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys cp' <- markEpToken cp return (DctMulti (op',cp') tys') @@ -4326,12 +4335,12 @@ instance ExactPrint (ConDecl GhcPs) where return (con', InfixCon x t1' t2') exact_details (PrefixCon x tys) = do con' <- markAnnotated con - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys return (con', PrefixCon x tys') exact_details (RecCon (oc,cc) (L an fields)) = do con' <- markAnnotated con oc' <- markEpToken oc - fields' <- markAnnotated fields + fields' <- mapM markAnnotated fields cc' <- markEpToken cc return (con', RecCon (oc',cc') (L an fields')) @@ -4365,7 +4374,7 @@ instance ExactPrint (ConDecl GhcPs) where return (PrefixConGADT x args0') (RecConGADT (oc,cc,rarr) (L an fields)) -> do oc' <- markEpToken oc - fields' <- markAnnotated fields + fields' <- mapM markAnnotated fields cc' <- markEpToken cc rarr' <- markEpUniToken rarr return (RecConGADT (oc',cc',rarr') (L an fields')) @@ -4397,7 +4406,7 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher exact b@(HsOuterImplicit _) = pure b exact (HsOuterExplicit (EpAnn l (f,d) cs) bndrs) = do f' <- markEpUniToken f - bndrs' <- markAnnotated bndrs + bndrs' <- mapM markAnnotated bndrs d' <- markEpToken d return (HsOuterExplicit (EpAnn l (f',d') cs) bndrs') @@ -4408,7 +4417,7 @@ instance ExactPrint (HsConDeclRecField GhcPs) where setAnnotationAnchor a _ _ _ = a exact (HsConDeclRecField _ names ftype) = do - names' <- markAnnotated names + names' <- mapM markAnnotated names ftype' <- markAnnotated ftype return (HsConDeclRecField noExtField names' ftype') @@ -4436,7 +4445,7 @@ markModifiedFunArrOf :: (Monad m, Monoid w, ExactPrint a) -> EP w m (HsModifiedFunArrOf a GhcPs, b) markModifiedFunArrOf (HsModifiedFunArr _ mods arr) tyM = do ty' <- if isColon then pure (Left ()) else Right <$> tyM - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods arr' <- case arr of HsStandardArr (EpArrow a) -> HsStandardArr . EpArrow <$> markEpUniToken a HsStandardArr (EpColon c) -> HsStandardArr . EpColon <$> markEpUniToken c @@ -4530,35 +4539,78 @@ instance (ExactPrint (Match GhcPs (LocatedA body))) an0 <- markLensFun' an lal_rest markEpToken an1 <- markLensBracketsO an0 lal_brackets an2 <- markEpAnnAllLT an1 lal_semis - a' <- markAnnotated a + a' <- mapM markAnnotated a an3 <- markLensBracketsC an2 lal_brackets return (L an3 a') -instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L an stmts) = do +-- instance ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where +-- getAnnotationEntry = entryFromLocatedA +-- setAnnotationAnchor = setAnchorAn +-- exact (L an stmts) = do +-- debugM $ "LocatedL [ExprLStmt" +-- (an'', stmts') <- markAnnList an $ do +-- case snocView stmts of +-- Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do +-- debugM $ "LocatedL [ExprLStmt: snocView" +-- ls' <- markAnnotated ls +-- initStmts' <- markAnnotated initStmts +-- return (initStmts' ++ [ls']) +-- _ -> do +-- markAnnotated stmts +-- return (L an'' stmts') + +instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))] where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact stmts = do debugM $ "LocatedL [ExprLStmt" - (an'', stmts') <- markAnnList an $ do - case snocView stmts of - Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do - debugM $ "LocatedL [ExprLStmt: snocView" - ls' <- markAnnotated ls - initStmts' <- markAnnotated initStmts - return (initStmts' ++ [ls']) - _ -> do - markAnnotated stmts - return (L an'' stmts') - -instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L ann es) = do - debugM $ "LocatedL [CmdLStmt" - an0 <- markLensBracketsO ann lal_brackets - es' <- mapM markAnnotated es - an1 <- markLensBracketsC an0 lal_brackets - return (L an1 es') + -- (an'', stmts') <- markAnnList an $ do + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + ls' <- markAnnotated ls + initStmts' <- markAnnotated initStmts + return (initStmts' ++ [ls']) + _ -> do + stmts' <- mapM markAnnotated stmts + return stmts' + +-- TODO: harmonise with prior, on payload +instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact stmts = do + debugM $ "LocatedL [ExprLStmt" + -- (an'', stmts') <- markAnnList an $ do + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + ls' <- markAnnotated ls + initStmts' <- markAnnotated initStmts + return (initStmts' ++ [ls']) + _ -> do + stmts' <- markAnnotated stmts + return stmts' + +-- instance ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where +-- getAnnotationEntry = entryFromLocatedA +-- setAnnotationAnchor = setAnchorAn +-- exact (L ann es) = do +-- debugM $ "LocatedL [CmdLStmt" +-- -- an0 <- markLensBracketsO ann lal_brackets +-- es' <- mapM markAnnotated es +-- -- an1 <- markLensBracketsC an0 lal_brackets +-- return (L ann es') + +-- instance ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where +-- getAnnotationEntry = entryFromLocatedA +-- setAnnotationAnchor = setAnchorAn +-- exact (L ann es) = do +-- debugM $ "LocatedL [CmdLStmt" +-- an0 <- markLensBracketsO ann lal_brackets +-- es' <- mapM markAnnotated es +-- an1 <- markLensBracketsC an0 lal_brackets +-- return (L an1 es') instance ExactPrint (LocatedA [LocatedA (HsConDeclRecField GhcPs)]) where getAnnotationEntry = entryFromLocatedA @@ -4619,14 +4671,14 @@ instance ExactPrint (IE GhcPs) where (dd',c', wc', withs') <- case wc of NoIEWildcard -> do - withs'' <- markAnnotated withs + withs'' <- mapM markAnnotated withs return (dd, c, wc, withs'') IEWildcard pos -> do let (bs, as) = splitAt pos withs - bs' <- markAnnotated bs + bs' <- mapM markAnnotated bs dd' <- markEpToken dd c' <- markEpToken c - as' <- markAnnotated as + as' <- mapM markAnnotated as return (dd',c', wc, bs'++as') cp' <- markEpToken cp doc' <- markAnnotated doc @@ -4719,12 +4771,12 @@ instance ExactPrint (Pat GhcPs) where return (BangPat an0 pat') exact (ListPat an pats) = do - (an', pats') <- markAnnList' an (markAnnotated pats) + (an', pats') <- markAnnList' an (mapM markAnnotated pats) return (ListPat an' pats') exact (TuplePat an pats boxity) = do an0 <- markOpeningParen an - pats' <- markAnnotated pats + pats' <- mapM markAnnotated pats an1 <- markClosingParen an0 return (TuplePat an1 pats' boxity) @@ -4737,7 +4789,7 @@ instance ExactPrint (Pat GhcPs) where return (SumPat an3 pat' alt arity) exact (OrPat an pats) = do - pats' <- markAnnotated (NE.toList pats) + pats' <- mapM markAnnotated (NE.toList pats) return (OrPat an (NE.fromList pats')) exact (ConPat x con details) = do @@ -4783,7 +4835,7 @@ instance ExactPrint (Pat GhcPs) where pure (InvisPat (tokat', spec) tp') exact (ModifiedPat x mods pat) = do - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods pat' <- markAnnotated pat return (ModifiedPat x mods' pat') @@ -4878,7 +4930,7 @@ exactUserCon c details = do exactConArgs :: (Monad m, Monoid w) => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) exactConArgs (PrefixCon x pats) = do - pats' <- markAnnotated pats + pats' <- mapM markAnnotated pats return (PrefixCon x pats') exactConArgs (InfixCon x p1 p2) = do p1' <- markAnnotated p1 ===================================== utils/check-exact/Main.hs ===================================== @@ -101,7 +101,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Ppr007.hs" Nothing -- "../../testsuite/tests/printer/Ppr008.hs" Nothing -- "../../testsuite/tests/printer/Ppr009.hs" Nothing - "../../testsuite/tests/printer/Ppr011.hs" Nothing + -- "../../testsuite/tests/printer/Ppr011.hs" Nothing -- "../../testsuite/tests/printer/Ppr011a.hs" Nothing -- "../../testsuite/tests/printer/Ppr012.hs" Nothing -- "../../testsuite/tests/printer/Ppr013.hs" Nothing @@ -124,7 +124,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Ppr030.hs" Nothing -- "../../testsuite/tests/printer/Ppr031.hs" Nothing -- "../../testsuite/tests/printer/Ppr032.hs" Nothing - -- "../../testsuite/tests/printer/Ppr033.hs" Nothing + "../../testsuite/tests/printer/Ppr033.hs" Nothing -- "../../testsuite/tests/printer/Ppr034.hs" Nothing -- "../../testsuite/tests/printer/Ppr035.hs" Nothing -- "../../testsuite/tests/printer/Ppr036.hs" Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d87dd8eae9d1f5e336a3ba07497cdf… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d87dd8eae9d1f5e336a3ba07497cdf… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 5 commits: EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas
by Alan Zimmerman (＠alanz) 09 Jun '26

09 Jun '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: 4588a803 by Alan Zimmerman at 2026-06-07T22:06:43+01:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - 84760acf by Alan Zimmerman at 2026-06-07T22:06:59+01:00 EPA: Use standard type family declaration for Anno - - - - - 59cfea13 by Alan Zimmerman at 2026-06-07T22:06:59+01:00 TTG: Add extension points to HsConDetails In contrast to normal TTG extension points, these are indexed by the arg and rec type parameters, since HsConDetails is a container type used in various roles. Each of these uses a GhcPass based structure, so the overall effect is a family of pass-sensitive extension points. data HsConDetails p arg rec = PrefixCon !(XPrefixCon p) [arg] -- C @t1 @t2 p1 p2 p3 | RecCon !(XRecCon p) rec -- C { x = p1, y = p2 } | InfixCon !(XInfixCon p) arg arg -- p1 `C` p2 | XHsConDetails !(XXHsConDetails p) type family XPrefixCon p type family XRecCon p type family XInfixCon p type family XXHsConDetails p - - - - - 12384160 by Alan Zimmerman at 2026-06-07T22:06:59+01:00 EPA: remove LocatedLI / SrcSpanAnnLI These were used for module export lists, and import decl lists. Replace them with direct capture of the relevant EP Annotations in HsModule and ImportDecl annotation extension points. Also use the HsConDetails RecCon extension point to capture the braces in a record constructor - - - - - d87dd8ea by Alan Zimmerman at 2026-06-07T22:06:59+01:00 EPA: Remove LocatedC / SrcSpanAnnC Used for contexts - - - - - 92 changed files: - compiler/GHC/Data/BooleanFormula.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Pat.hs - compiler/GHC/Hs/Stats.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Constructor.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Pat.hs - compiler/Language/Haskell/Syntax/Type.hs - ghc/GHCi/UI.hs - testsuite/tests/ghc-api/T25121_status.stdout - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/Makefile - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f181f913450312fb3c17211069390… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8f181f913450312fb3c17211069390… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/T27156] 13 commits: compiler: use nubOrd from containers
by Apoorv Ingle (＠ani) 09 Jun '26

09 Jun '26

Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: 576987d0 by Simon Jakobi at 2026-06-02T04:53:36-04:00 compiler: use nubOrd from containers Address #27103 by replacing GHC.Utils.Misc.ordNub[On] with Data.Containers.ListUtils.nubOrd[On]. Note that nubOrd suffers from a small inefficiency, a fix for which will be included in the next containers release: https://github.com/haskell/containers/issues/1202 - - - - - deea53c3 by David Eichmann at 2026-06-02T04:54:22-04:00 Hadrian: disable response files for GHC/Haddock builders on non-Windows This makes debugging build errors easier on non-windows hosts. See issue #27230 - - - - - f2f5c6ba by Nikita Efremov at 2026-06-02T16:04:54+00:00 fix typo : compete with performance, not complete - - - - - 5524ea0e by Wolfgang Jeltsch at 2026-06-03T08:01:26-04:00 Make the current `base` buildable with GHC 9.14 This comprises the following changes: * Disable some imports into `GHC.Base` for GHC 9.14 * Disable some imports into `Prelude` for GHC 9.14 * Disable separate `ArrowLoop` import for GHC 9.14 * Disable `GHC.Internal.STM` import for GHC 9.14 * Disable `GHC.Internal.Unicode.Version` import for GHC 9.14 * Disable `GHC.Internal.TH.Monad` import for GHC 9.14 * Add alternative `fixIO` import for GHC 9.14 * Add alternative `unsafeCodeCoerce` import for GHC 9.14 * Disable hiding of imported SIMD operations for GHC 9.14 * Disable use of GHC 9.14’s `printToHandleFinalizerExceptionHandler` * Enable use of `getFileHash` from `ghc-internal` for GHC 9.14 * Make `thenA` available for GHC 9.14 * Make `thenM` available for GHC 9.14 * Disable translation of `IoManagerFlagPoll` for GHC 9.14 * Add `hGetNewlineMode` for GHC 9.14 - - - - - d3438055 by Enrico Maria De Angelis at 2026-06-03T08:02:17-04:00 Fix #27067 - Clarify haddocks on `minusNaturalMaybe` - - - - - f9bcfac2 by sheaf at 2026-06-03T14:47:19-04:00 Avoid mkTick in Core Prep breaking ANF As discovered in #27182, mkTick can break ANF. This patch introduces a variant of mkTick that skips the single optimisation that could break ANF. This is preferrable over switching to the raw Tick constructor, as the latter may introduce spurious cost centres in profiling reports. This is a temporary measure until we more thoroughly refactor how mkTick works (see #27141). See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep. Fixes #27182 - - - - - cf1fd661 by Artem Pelenitsyn at 2026-06-03T14:48:09-04:00 clarify comment for getSizeofMutableByteArray#: we get the size in bytes, not "elements" - - - - - a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00 Hadrian: convert env variable ACLOCAL_PATH to unix paths. Convert ACLOCAL_PATH to a unix style path when invoking autoreconf. Autoreconf doesn't handle windows paths. See Note [Autoreconf unix paths from ACLOCAL_PATH]. Fixes #27311 - - - - - 18f6138a by Simon Jakobi at 2026-06-04T20:20:31-04:00 testsuite: Deduplicate --only test names config.only is assumed to be a set, but supplying --only overwrote it with the (list) argparse result, which can contain duplicates. When a test ran, config.only.remove(name) dropped only the first occurrence, so a duplicated name lingered and was later misreported as a "test not found" framework failure. Store it as a set instead. Fixes #27322 Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 2f3cc9ff by Simon Jakobi at 2026-06-08T07:55:49-04:00 testsuite: detect fast bignum via ghc-internal, not removed ghc-bignum The ghc-bignum package was merged into ghc-internal, so the BIGNUM_GMP probe in test.mk ran `ghc-pkg field ghc-bignum exposed-modules`, which fails with "cannot find package ghc-bignum". That error went to stderr and leaked into the captured stderr of every makefile_test, causing spurious [bad stderr] failures across the suite. The probe also silently returned empty, so config.have_fast_bignum was wrongly False even on GMP builds. Probe ghc-internal's extra-libraries for the gmp library instead: the GMP backend module is an other-module (not exposed), but GMP_LIBS adds gmp to extra-libraries only on a GMP build, so this distinguishes the backends. Redirect stderr to keep any future missing-package error off the harness's stderr. This also removes a stale comment as per suggestion from hsyl20. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - eb3bf6e7 by Alan Zimmerman at 2026-06-08T07:56:32-04:00 EPA: Rename Transform.anchorEof to addModuleCommentOrigDeltas This now matches what it actually does. - - - - - 15891915 by Apoorv Ingle at 2026-06-08T16:56:29-05:00 Work on #27156 - Add RebindableSyntaxTable to store function/operator names while renaming in the XBlah fields - Expand the following expressins right before typechecking instead of in the renamer * OverloadedLabel * RecordDotSyntax: HsGetField and HsProjection * ExplicitList * RecordUpd * HsIf * HsDo (Vanilla cases) - - - - - 89ab658e by Apoorv Ingle at 2026-06-08T16:56:29-05:00 accept T18102b test diff - - - - - 58 changed files: - boot - + changelog.d/T27182.md - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/CmmToAsm/BlockLayout.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Linker/Unit.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Misc.hs - docs/users_guide/javascript.rst - ghc/GHCi/UI.hs - hadrian/src/Builder.hs - hadrian/src/Hadrian/Oracles/Path.hs - hadrian/src/Hadrian/Utilities.hs - hadrian/src/Rules/BinaryDist.hs - libraries/base/src/Control/Applicative.hs - libraries/base/src/Control/Arrow.hs - libraries/base/src/Control/Monad.hs - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Conc.hs - libraries/base/src/GHC/Conc/Sync.hs - libraries/base/src/GHC/Exts.hs - libraries/base/src/GHC/Fingerprint.hs - libraries/base/src/GHC/IO/Handle.hs - libraries/base/src/GHC/RTS/Flags.hs - libraries/base/src/GHC/Unicode.hs - libraries/base/src/GHC/Weak.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/IO.hs - libraries/base/src/System/Mem/Weak.hs - libraries/ghc-internal/src/GHC/Internal/Natural.hs - testsuite/driver/runtests.py - testsuite/mk/test.mk - testsuite/tests/ghc-api/T25121_status.stdout - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr - + testsuite/tests/profiling/should_compile/T27182.hs - testsuite/tests/profiling/should_compile/all.T - testsuite/tests/rebindable/T19918.stdout - testsuite/tests/th/T18102b.stdout - utils/check-exact/Main.hs - utils/check-exact/Transform.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8c875ee616a7541c8efb28dd62a11… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a8c875ee616a7541c8efb28dd62a11… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/T27156] accept T18102b test diff
by Apoorv Ingle (＠ani) 09 Jun '26

09 Jun '26

Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: a8c875ee by Apoorv Ingle at 2026-06-08T16:55:20-05:00 accept T18102b test diff - - - - - 2 changed files: - compiler/GHC/Rename/Splice.hs - testsuite/tests/th/T18102b.stdout Changes: ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -24,7 +24,6 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad -import GHC.Tc.Gen.Expand import GHC.Driver.Env.Types import GHC.Rename.Env @@ -142,12 +141,8 @@ rnTypedBracket e br_body ; recordThUse ; traceRn "Renaming typed TH bracket" empty - ; (body'@(L loc b) , fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body - -- ; return (HsTypedBracket noExtField body', fvs_e) - ; mb_b <- tcExpand b - ; case mb_b of - Nothing -> return (HsTypedBracket noExtField body', fvs_e) - Just hse -> return (HsTypedBracket noExtField (L loc (XExpr (ExpandedThingRn hse))), fvs_e) + ; (body, fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body + ; return (HsTypedBracket noExtField body, fvs_e) } rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeNames) ===================================== testsuite/tests/th/T18102b.stdout ===================================== @@ -1 +1 @@ -25 \ No newline at end of file +10 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8c875ee616a7541c8efb28dd62a112… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8c875ee616a7541c8efb28dd62a112… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T27296-stable-simpl] WIP: Stabilise anonymous float ordering in untidied Core dumps
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T27296-stable-simpl at Glasgow Haskell Compiler / GHC Commits: 3c83b1d2 by Simon Jakobi at 2026-06-08T22:40:46+02:00 WIP: Stabilise anonymous float ordering in untidied Core dumps Anonymous floats are all built with OccName "lvl" and noSrcSpan (newLvlVar), so the source-span/name sort key is identical for every one of them; sortOn then falls back to the unique-driven input order -- the very churn -dstable-core-dump-order is meant to remove. (Tidied dumps like -ddump-simpl are unaffected, as tidy gives the floats distinct names lvl, lvl1, ...) Add a content-based, unique-independent tie-break (rhsKey): the floated literal, if any, then the RHS size statistics. Add test T27296b pinning the float ordering in an untidied -ddump-float-out dump. It is a makefile_test that seds the dump down to just the bindings (collapsing each pass header to a bare "Float out" separator and dropping the FOS config / size lines), so the six lvl floats are asserted to come out ordered by literal value. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 5 changed files: - compiler/GHC/Core/Ppr.hs - testsuite/tests/simplCore/should_compile/Makefile - + testsuite/tests/simplCore/should_compile/T27296b.hs - + testsuite/tests/simplCore/should_compile/T27296b.stdout - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -28,10 +28,10 @@ module GHC.Core.Ppr ( import GHC.Prelude import GHC.Core -import GHC.Core.Stats (exprStats) +import GHC.Core.Stats (CoreStats(..), exprStats) import GHC.Types.Fixity (LexicalFixity(..)) -import GHC.Types.Literal( pprLiteral ) -import GHC.Types.Name( pprInfixName, pprPrefixName, getOccString, getSrcSpan ) +import GHC.Types.Literal( Literal, pprLiteral ) +import GHC.Types.Name( getOccString, getSrcSpan, pprInfixName, pprPrefixName ) import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info @@ -46,8 +46,8 @@ import GHC.Types.Basic import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic (panic) -import GHC.Types.SrcLoc ( SrcSpan(..), srcSpanStartLine, srcSpanStartCol - , pprUserRealSpan ) +import GHC.Types.SrcLoc ( SrcSpan(..), pprUserRealSpan, srcSpanStartCol + , srcSpanStartLine ) import GHC.Types.Tickish import Data.List ( sortOn ) @@ -99,7 +99,21 @@ Uniques*, so two dumps line up across rebuilds. The sort key is: whether the OccName *contains* a '$', which marks a derived binder: a worker is @$wfoo@, but a call-site specialisation is tidied to @bar_$sfoo@ (no leading '$'), so a leading-'$' test would miss it. - 3. the OccName string, as a final lexical, deterministic tie-break. + 3. the OccName string, as a lexical, deterministic tie-break. + 4. a content-based tie-break on the right-hand side ('rhsKey'): the floated + literal, if any, then the RHS size statistics. This matters for the + anonymous floats: 'newLvlVar' builds them all with OccName "lvl" and + noSrcSpan, so keys 1-3 are identical and, without this, their order would + fall back to the Unique-driven input order -- exactly the churn we set out + to remove. (In tidied dumps like -ddump-simpl the floats already have + distinct names lvl, lvl1, ...; this tie-break additionally stabilises the + untidied dumps -ddump-simpl-iterations, -dverbose-core2core etc.) It is a + best-effort tie-break, not a total order: two RHSs that agree on the + floated literal and on every size statistic still fall back to input + order. And it is Unique-independent for the floats we target -- the one + exception is a rubbish literal (LitRubbish), whose 'cmpLit' compares the + underlying type with the Unique-dependent 'nonDetCmpType'; that does not + arise for the numeric CAFs this targets. Recursive groups are never split: a 'Rec' is one 'CoreBind', placed as a unit by its earliest-source member, with its members sorted by the same key. @@ -114,24 +128,36 @@ suffer the cross-module churn this flag addresses. useful for debugging the compiler itself. -} +-- | The sort key for one top-level binder. The trailing 'RhsKey' is a +-- content-based tiebreak, used only when two binders agree on everything +-- before it. See Note [Stable Core dump order]. +type DumpSortKey = + ( Int -- source-span bucket: 0 = real span, 1 = noSrcSpan (sorts last) + , Int -- source-span start line + , Int -- source-span start column + , Int -- dollar-rank: 0 = derived ($w/$s) binder, 1 = its origin + , String -- the OccName string, a lexical tiebreak + , RhsKey -- content-based tiebreak (see 'rhsKey') + ) + -- | Reorder a 'CoreProgram' into a stable, source-location-driven order for -- dumping. See Note [Stable Core dump order]. Used by 'dumpPassResult' when -- -dstable-core-dump-order is enabled. sortCoreBindingsForDump :: CoreProgram -> CoreProgram sortCoreBindingsForDump = sortOn bindKey . map sortRecMembers where - sortRecMembers (Rec prs) = Rec (sortOn (bndrKey . fst) prs) + sortRecMembers (Rec prs) = Rec (sortOn (uncurry elemKey) prs) sortRecMembers b = b - -- 'sortRecMembers' runs first, so a 'Rec' is already sorted by 'bndrKey' + -- 'sortRecMembers' runs first, so a 'Rec' is already sorted by 'elemKey' -- when 'bindKey' sees it; its first member is therefore the minimum key. - bindKey :: CoreBind -> (Int, Int, Int, Int, String) - bindKey (NonRec b _) = bndrKey b - bindKey (Rec ((b,_):_)) = bndrKey b - bindKey (Rec []) = panic "sortCoreBindingsForDump: empty Rec" + bindKey :: CoreBind -> DumpSortKey + bindKey (NonRec b rhs) = elemKey b rhs + bindKey (Rec ((b,rhs):_)) = elemKey b rhs + bindKey (Rec []) = panic "sortCoreBindingsForDump: empty Rec" - bndrKey :: CoreBndr -> (Int, Int, Int, Int, String) - bndrKey b = (bucket, line, col, dollar_rank, s) + elemKey :: CoreBndr -> CoreExpr -> DumpSortKey + elemKey b rhs = (bucket, line, col, dollar_rank, s, rhsKey rhs) where s = getOccString b (bucket, line, col) = case getSrcSpan b of @@ -145,6 +171,27 @@ sortCoreBindingsForDump = sortOn bindKey . map sortRecMembers dollar_rank | '$' `elem` s = 0 | otherwise = 1 +-- | A cheap tie-break on a binder's right-hand side, used to order binders that +-- are otherwise indistinguishable -- in practice the anonymous floats, which all +-- share OccName \"lvl\" and 'noSrcSpan' (see 'GHC.Core.Opt.SetLevels.newLvlVar'). +-- It pairs the floated literal (if any, looking through the @I#@-style box and +-- casts/ticks) with the RHS size statistics. For its Unique-independence and +-- best-effort caveats see Note [Stable Core dump order]. +type RhsKey = + ( Maybe Literal -- the floated literal, if any (Nothing sorts first) + , (Int, Int, Int, Int, Int) -- exprStats counts: terms, types, coercions, value binds, join binds + ) + +rhsKey :: CoreExpr -> RhsKey +rhsKey rhs = (litOf rhs, statsTuple (exprStats rhs)) + where + statsTuple (CS tm ty co vb jb) = (tm, ty, co, vb, jb) + litOf (Lit l) = Just l + litOf (App f a) = case a of { Lit l -> Just l; _ -> litOf f } + litOf (Cast e _) = litOf e + litOf (Tick _ e) = litOf e + litOf _ = Nothing + instance OutputableBndr b => Outputable (Bind b) where ppr bind = ppr_bind noAnn bind ===================================== testsuite/tests/simplCore/should_compile/Makefile ===================================== @@ -316,3 +316,22 @@ T27296: -dstable-core-dump-order T27296.hs 2> /dev/null \ | sed -nE 's/^(\$$fEqKey|\$$fOrdKey|\$$fOrdKey_\$$ccompare|size|findI_\$$slookupG|lookupG|member|findI|\$$wrotate|rotate|insertG|insertManyI|insertTwoI|weight|balance|ratios|fromAscI)( .*)?$$/\1/p' \ | uniq + +# Companion to T27296 that pins the ordering of *anonymous* top-level floats. +# See Note [Stable Core dump order] in GHC.Core.Ppr and the header of T27296b.hs. +# This is an *untidied* dump (-ddump-float-out), the only place the "lvl" +# collision is observable. The sed collapses each float-out pass header to a +# bare "==================== Float out ====================" separator (dropping +# the noisy FOS config) and drops the "Result size" and "-- RHS size" lines, +# leaving just the bindings of each pass -- the six lvl floats in the first pass +# must come out ordered by literal value (1000..6000). +T27296b: + $(RM) -f T27296b.o T27296b.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-float-out -dsuppress-uniques \ + -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \ + -dstable-core-dump-order T27296b.hs 2> /dev/null \ + | sed -E \ + -e '/^=+ Float out/,/=+$$/c\==================== Float out ====================' \ + -e '/^Result size of Float out/,/^ = \{terms/d' \ + -e '/^-- RHS size:/d' \ + | cat -s ===================================== testsuite/tests/simplCore/should_compile/T27296b.hs ===================================== @@ -0,0 +1,21 @@ +-- See Note [Stable Core dump order] in GHC.Core.Ppr. +-- +-- Companion to T27296 that pins the ordering of *anonymous* top-level floats. +-- Under -O the boxed Int constants in sel's branches are floated to top level +-- as separate CAFs, all of which the compiler names "lvl" with noSrcSpan (see +-- newLvlVar). Before -dstable-core-dump-order their dump order was the +-- unique-driven processing order; the flag's content-based tie-break (rhsKey) +-- now orders them by literal value -- here 1000..6000, despite the scrambled +-- source order. This dump is intentionally *untidied* (-ddump-float-out), the +-- only place the "lvl" collision is observable; tidied dumps like -ddump-simpl +-- already give the floats distinct names (lvl, lvl1, ...). +module T27296b (sel) where + +{-# NOINLINE sel #-} +sel :: Int -> Int +sel 0 = 5000 +sel 1 = 1000 +sel 2 = 4000 +sel 3 = 2000 +sel 4 = 3000 +sel _ = 6000 ===================================== testsuite/tests/simplCore/should_compile/T27296b.stdout ===================================== @@ -0,0 +1,54 @@ + +==================== Float out ==================== + +sel :: Int -> Int +sel + = \ (ds :: Int) -> + case ds of { I# ds -> + case ds of { + __DEFAULT -> lvl; + 0# -> lvl; + 1# -> lvl; + 2# -> lvl; + 3# -> lvl; + 4# -> lvl + } + } + +lvl :: Int +lvl = I# 1000# + +lvl :: Int +lvl = I# 2000# + +lvl :: Int +lvl = I# 3000# + +lvl :: Int +lvl = I# 4000# + +lvl :: Int +lvl = I# 5000# + +lvl :: Int +lvl = I# 6000# + +==================== Float out ==================== + +$wsel :: Int# -> Int# +$wsel + = \ (ww :: Int#) -> + case ww of { + __DEFAULT -> 6000#; + 0# -> 5000#; + 1# -> 1000#; + 2# -> 4000#; + 3# -> 2000#; + 4# -> 3000# + } + +sel :: Int -> Int +sel + = \ (ds :: Int) -> + case ds of { I# ww -> case $wsel ww of ww { __DEFAULT -> I# ww } } + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -603,3 +603,4 @@ test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) test('T27296', [], makefile_test, ['T27296']) +test('T27296b', [], makefile_test, ['T27296b']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c83b1d2794a55828567a5b471ea66d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3c83b1d2794a55828567a5b471ea66d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/T27296-stable-simpl] WIP: Stabilise anonymous float ordering in untidied Core dumps
by Simon Jakobi (＠sjakobi2) 09 Jun '26

09 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T27296-stable-simpl at Glasgow Haskell Compiler / GHC Commits: b925ad78 by Simon Jakobi at 2026-06-08T20:59:53+02:00 WIP: Stabilise anonymous float ordering in untidied Core dumps Anonymous floats are all built with OccName "lvl" and noSrcSpan (newLvlVar), so the source-span/name sort key is identical for every one of them; sortOn then falls back to the unique-driven input order -- the very churn -dstable-core-dump-order is meant to remove. (Tidied dumps like -ddump-simpl are unaffected, as tidy gives the floats distinct names lvl, lvl1, ...) Add a content-based, unique-independent tie-break (rhsKey): the floated literal, if any, then the RHS size statistics. Add test T27296b pinning the float ordering in an untidied -ddump-float-out dump. It is a makefile_test that seds the dump down to just the bindings (collapsing each pass header to a bare "Float out" separator and dropping the FOS config / size lines), so the six lvl floats are asserted to come out ordered by literal value. Co-Authored-By: Claude Opus 4.7 <noreply(a)anthropic.com> - - - - - 5 changed files: - compiler/GHC/Core/Ppr.hs - testsuite/tests/simplCore/should_compile/Makefile - + testsuite/tests/simplCore/should_compile/T27296b.hs - + testsuite/tests/simplCore/should_compile/T27296b.stdout - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -28,10 +28,10 @@ module GHC.Core.Ppr ( import GHC.Prelude import GHC.Core -import GHC.Core.Stats (exprStats) +import GHC.Core.Stats (CoreStats(..), exprStats) import GHC.Types.Fixity (LexicalFixity(..)) -import GHC.Types.Literal( pprLiteral ) -import GHC.Types.Name( pprInfixName, pprPrefixName, getOccString, getSrcSpan ) +import GHC.Types.Literal( Literal, pprLiteral ) +import GHC.Types.Name( getOccString, getSrcSpan, pprInfixName, pprPrefixName ) import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info @@ -46,8 +46,8 @@ import GHC.Types.Basic import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic (panic) -import GHC.Types.SrcLoc ( SrcSpan(..), srcSpanStartLine, srcSpanStartCol - , pprUserRealSpan ) +import GHC.Types.SrcLoc ( SrcSpan(..), pprUserRealSpan, srcSpanStartCol + , srcSpanStartLine ) import GHC.Types.Tickish import Data.List ( sortOn ) @@ -99,7 +99,21 @@ Uniques*, so two dumps line up across rebuilds. The sort key is: whether the OccName *contains* a '$', which marks a derived binder: a worker is @$wfoo@, but a call-site specialisation is tidied to @bar_$sfoo@ (no leading '$'), so a leading-'$' test would miss it. - 3. the OccName string, as a final lexical, deterministic tie-break. + 3. the OccName string, as a lexical, deterministic tie-break. + 4. a content-based tie-break on the right-hand side ('rhsKey'): the floated + literal, if any, then the RHS size statistics. This matters for the + anonymous floats: 'newLvlVar' builds them all with OccName "lvl" and + noSrcSpan, so keys 1-3 are identical and, without this, their order would + fall back to the Unique-driven input order -- exactly the churn we set out + to remove. (In tidied dumps like -ddump-simpl the floats already have + distinct names lvl, lvl1, ...; this tie-break additionally stabilises the + untidied dumps -ddump-simpl-iterations, -dverbose-core2core etc.) It is a + best-effort tie-break, not a total order: two RHSs that agree on the + floated literal and on every size statistic still fall back to input + order. And it is Unique-independent for the floats we target -- the one + exception is a rubbish literal (LitRubbish), whose 'cmpLit' compares the + underlying type with the Unique-dependent 'nonDetCmpType'; that does not + arise for the numeric CAFs this targets. Recursive groups are never split: a 'Rec' is one 'CoreBind', placed as a unit by its earliest-source member, with its members sorted by the same key. @@ -114,24 +128,36 @@ suffer the cross-module churn this flag addresses. useful for debugging the compiler itself. -} +-- | The sort key for one top-level binder. The trailing 'RhsKey' is a +-- content-based tiebreak, used only when two binders agree on everything +-- before it. See Note [Stable Core dump order]. +type DumpSortKey = + ( Int -- source-span bucket: 0 = real span, 1 = noSrcSpan (sorts last) + , Int -- source-span start line + , Int -- source-span start column + , Int -- $-rank: 0 = derived ($w/$s) binder, 1 = its origin + , String -- the OccName string, a lexical tiebreak + , RhsKey -- content-based tiebreak (see 'rhsKey') + ) + -- | Reorder a 'CoreProgram' into a stable, source-location-driven order for -- dumping. See Note [Stable Core dump order]. Used by 'dumpPassResult' when -- -dstable-core-dump-order is enabled. sortCoreBindingsForDump :: CoreProgram -> CoreProgram sortCoreBindingsForDump = sortOn bindKey . map sortRecMembers where - sortRecMembers (Rec prs) = Rec (sortOn (bndrKey . fst) prs) + sortRecMembers (Rec prs) = Rec (sortOn (uncurry elemKey) prs) sortRecMembers b = b - -- 'sortRecMembers' runs first, so a 'Rec' is already sorted by 'bndrKey' + -- 'sortRecMembers' runs first, so a 'Rec' is already sorted by 'elemKey' -- when 'bindKey' sees it; its first member is therefore the minimum key. - bindKey :: CoreBind -> (Int, Int, Int, Int, String) - bindKey (NonRec b _) = bndrKey b - bindKey (Rec ((b,_):_)) = bndrKey b - bindKey (Rec []) = panic "sortCoreBindingsForDump: empty Rec" + bindKey :: CoreBind -> DumpSortKey + bindKey (NonRec b rhs) = elemKey b rhs + bindKey (Rec ((b,rhs):_)) = elemKey b rhs + bindKey (Rec []) = panic "sortCoreBindingsForDump: empty Rec" - bndrKey :: CoreBndr -> (Int, Int, Int, Int, String) - bndrKey b = (bucket, line, col, dollar_rank, s) + elemKey :: CoreBndr -> CoreExpr -> DumpSortKey + elemKey b rhs = (bucket, line, col, dollar_rank, s, rhsKey rhs) where s = getOccString b (bucket, line, col) = case getSrcSpan b of @@ -145,6 +171,27 @@ sortCoreBindingsForDump = sortOn bindKey . map sortRecMembers dollar_rank | '$' `elem` s = 0 | otherwise = 1 +-- | A cheap tie-break on a binder's right-hand side, used to order binders that +-- are otherwise indistinguishable -- in practice the anonymous floats, which all +-- share OccName \"lvl\" and 'noSrcSpan' (see 'GHC.Core.Opt.SetLevels.newLvlVar'). +-- It pairs the floated literal (if any, looking through the @I#@-style box and +-- casts/ticks) with the RHS size statistics. For its Unique-independence and +-- best-effort caveats see Note [Stable Core dump order]. +type RhsKey = + ( Maybe Literal -- the floated literal, if any (Nothing sorts first) + , (Int, Int, Int, Int, Int) -- exprStats counts: terms, types, coercions, value binds, join binds + ) + +rhsKey :: CoreExpr -> RhsKey +rhsKey rhs = (litOf rhs, statsTuple (exprStats rhs)) + where + statsTuple (CS tm ty co vb jb) = (tm, ty, co, vb, jb) + litOf (Lit l) = Just l + litOf (App f a) = case a of { Lit l -> Just l; _ -> litOf f } + litOf (Cast e _) = litOf e + litOf (Tick _ e) = litOf e + litOf _ = Nothing + instance OutputableBndr b => Outputable (Bind b) where ppr bind = ppr_bind noAnn bind ===================================== testsuite/tests/simplCore/should_compile/Makefile ===================================== @@ -316,3 +316,22 @@ T27296: -dstable-core-dump-order T27296.hs 2> /dev/null \ | sed -nE 's/^(\$$fEqKey|\$$fOrdKey|\$$fOrdKey_\$$ccompare|size|findI_\$$slookupG|lookupG|member|findI|\$$wrotate|rotate|insertG|insertManyI|insertTwoI|weight|balance|ratios|fromAscI)( .*)?$$/\1/p' \ | uniq + +# Companion to T27296 that pins the ordering of *anonymous* top-level floats. +# See Note [Stable Core dump order] in GHC.Core.Ppr and the header of T27296b.hs. +# This is an *untidied* dump (-ddump-float-out), the only place the "lvl" +# collision is observable. The sed collapses each float-out pass header to a +# bare "==================== Float out ====================" separator (dropping +# the noisy FOS config) and drops the "Result size" and "-- RHS size" lines, +# leaving just the bindings of each pass -- the six lvl floats in the first pass +# must come out ordered by literal value (1000..6000). +T27296b: + $(RM) -f T27296b.o T27296b.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-float-out -dsuppress-uniques \ + -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \ + -dstable-core-dump-order T27296b.hs 2> /dev/null \ + | sed -E \ + -e '/^=+ Float out/,/=+$$/c\==================== Float out ====================' \ + -e '/^Result size of Float out/,/^ = \{terms/d' \ + -e '/^-- RHS size:/d' \ + | cat -s ===================================== testsuite/tests/simplCore/should_compile/T27296b.hs ===================================== @@ -0,0 +1,21 @@ +-- See Note [Stable Core dump order] in GHC.Core.Ppr. +-- +-- Companion to T27296 that pins the ordering of *anonymous* top-level floats. +-- Under -O the boxed Int constants in sel's branches are floated to top level +-- as separate CAFs, all of which the compiler names "lvl" with noSrcSpan (see +-- newLvlVar). Before -dstable-core-dump-order their dump order was the +-- unique-driven processing order; the flag's content-based tie-break (rhsKey) +-- now orders them by literal value -- here 1000..6000, despite the scrambled +-- source order. This dump is intentionally *untidied* (-ddump-float-out), the +-- only place the "lvl" collision is observable; tidied dumps like -ddump-simpl +-- already give the floats distinct names (lvl, lvl1, ...). +module T27296b (sel) where + +{-# NOINLINE sel #-} +sel :: Int -> Int +sel 0 = 5000 +sel 1 = 1000 +sel 2 = 4000 +sel 3 = 2000 +sel 4 = 3000 +sel _ = 6000 ===================================== testsuite/tests/simplCore/should_compile/T27296b.stdout ===================================== @@ -0,0 +1,54 @@ + +==================== Float out ==================== + +sel :: Int -> Int +sel + = \ (ds :: Int) -> + case ds of { I# ds -> + case ds of { + __DEFAULT -> lvl; + 0# -> lvl; + 1# -> lvl; + 2# -> lvl; + 3# -> lvl; + 4# -> lvl + } + } + +lvl :: Int +lvl = I# 1000# + +lvl :: Int +lvl = I# 2000# + +lvl :: Int +lvl = I# 3000# + +lvl :: Int +lvl = I# 4000# + +lvl :: Int +lvl = I# 5000# + +lvl :: Int +lvl = I# 6000# + +==================== Float out ==================== + +$wsel :: Int# -> Int# +$wsel + = \ (ww :: Int#) -> + case ww of { + __DEFAULT -> 6000#; + 0# -> 5000#; + 1# -> 1000#; + 2# -> 4000#; + 3# -> 2000#; + 4# -> 3000# + } + +sel :: Int -> Int +sel + = \ (ds :: Int) -> + case ds of { I# ww -> case $wsel ww of ww { __DEFAULT -> I# ww } } + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -603,3 +603,4 @@ test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds']) test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) test('T27296', [], makefile_test, ['T27296']) +test('T27296b', [], makefile_test, ['T27296b']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b925ad78dc1fb2836062e3414a59295… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b925ad78dc1fb2836062e3414a59295… You're receiving this email because of your account on gitlab.haskell.org.

1 0