August 2026 - ghc-commits

[Git][ghc/ghc][wip/ani/T27156] revert th test
by Apoorv Ingle (＠ani) 16 Aug '26

16 Aug '26

Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: e65ad951 by Apoorv Ingle at 2026-08-16T12:21:54-05:00 revert th test - - - - - 4 changed files: - compiler/GHC/Rename/Expr.hs - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/th/T18102b.hs - testsuite/tests/th/T18102b_aux.hs Changes: ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -46,7 +46,6 @@ import GHC.Driver.DynFlags import GHC.Builtin.KnownKeys import GHC.Builtin.KnownOccs import GHC.Builtin.WiredIn.Types ( nilDataConName, oneDataConName ) -import GHC.Builtin.WiredIn.Ids( rightSectionName, leftSectionName ) import GHC.Unit.Module ( isInteractiveModule ) @@ -74,7 +73,7 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad import qualified Data.Foldable as Partial (maximum) import Data.List (unzip4) -import Data.List.NonEmpty ( NonEmpty(..), head, init, last, nonEmpty, scanl, tail ) +import Data.List.NonEmpty ( NonEmpty(..), head, nonEmpty, scanl, tail ) import Data.Ord import Data.Array import GHC.Driver.Env (HscEnv) ===================================== testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr ===================================== @@ -1,41 +1,42 @@ RecordDotSyntaxFail8.hs:47:17: error: [GHC-39999] • No instance for ‘HasField "quux1" Quux Quux’ - arising from selecting the field ‘quux1’ - NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class. + arising from selecting the field ‘quux1’ + NB: ‘HasField’ is not the built-in ‘HasField’ class. • In the second argument of ‘($)’, namely ‘a.foo.bar.baz.quux1’ In a stmt of a 'do' block: print @Quux $ a.foo.bar.baz.quux1 In the expression: - do let a = Foo {foo = ...} - print @Quux $ ....bar.baz.quux1 - let b = myQuux - print @Quux $ b.quux2 - let c = Foo {foo = ...} - ... + do let a = Foo {foo = ...} + print @Quux $ ....bar.baz.quux1 + let b = myQuux + print @Quux $ b.quux2 + let c = Foo {foo = ...} + ... RecordDotSyntaxFail8.hs:50:17: error: [GHC-39999] • No instance for ‘HasField "quux2" Quux Quux’ - arising from selecting the field ‘quux2’ + arising from selecting the field ‘quux2’ NB: ‘HasField’ is not the built-in ‘HasField’ class. • In the second argument of ‘($)’, namely ‘b.quux2’ In a stmt of a 'do' block: print @Quux $ b.quux2 In the expression: - do let a = Foo {foo = ...} - print @Quux $ ....bar.baz.quux1 - let b = myQuux - print @Quux $ b.quux2 - let c = Foo {foo = ...} - ... + do let a = Foo {foo = ...} + print @Quux $ ....bar.baz.quux1 + let b = myQuux + print @Quux $ b.quux2 + let c = Foo {foo = ...} + ... RecordDotSyntaxFail8.hs:53:17: error: [GHC-39999] • No instance for ‘HasField "quux3" Quux r0’ - arising from selecting the field ‘quux3’ - NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class. + arising from selecting the field ‘quux3’ + NB: ‘HasField’ is not the built-in ‘HasField’ class. • In the second argument of ‘($)’, namely ‘a.foo.bar.baz.quux3.wob’ In a stmt of a 'do' block: print @Bool $ a.foo.bar.baz.quux3.wob In the expression: - do let a = Foo {foo = ...} - print @Quux $ ....bar.baz.quux1 - let b = myQuux - print @Quux $ b.quux2 - let c = Foo {foo = ...} - ... + do let a = Foo {foo = ...} + print @Quux $ ....bar.baz.quux1 + let b = myQuux + print @Quux $ b.quux2 + let c = Foo {foo = ...} + ... + ===================================== testsuite/tests/th/T18102b.hs ===================================== @@ -1,47 +1,9 @@ -{-# LANGUAGE TemplateHaskell, RebindableSyntax #-} +{-# LANGUAGE TemplateHaskell #-} -import Prelude import T18102b_aux -x1 :: Int -x1 = $$(intQuote_TTH) - -z1 :: Int -z1 = $(intQuote_TH) - -x2 :: Char -x2 = $$(charQuote_TTH) - -z2 :: Char -z2 = $(charQuote_TH) - -x3 :: [Int] -x3 = $$(seqQuote_TTH) - -z3 :: [Int] -z3 = $(seqQuote_TH) - -x4 :: [Int] -x4 = $$(listQuote_TTH) - -z4 :: [Int] -z4 = $(listQuote_TH) - +x :: Int +x = $$(intQuote) main :: IO () -main = do - print t1 - print x1 - print z1 - - print t2 - print x2 - print z2 - - print t3 - print x3 - print z3 - - print t4 - print x4 - print z4 +main = print x ===================================== testsuite/tests/th/T18102b_aux.hs ===================================== @@ -1,60 +1,11 @@ -{-# LANGUAGE RebindableSyntax, TemplateHaskell, OverloadedLists #-} +{-# LANGUAGE RebindableSyntax, TemplateHaskell #-} module T18102b_aux where -import Prelude hiding ((>>=), return ) +import Prelude import Language.Haskell.TH.Syntax - - ifThenElse :: Bool -> Int -> Int -> Int ifThenElse _ a b = a+b -intQuote_TTH :: Code Q Int -intQuote_TTH = [|| if True then 10 else 15 ||] - -intQuote_TH :: Quote m => m Exp -intQuote_TH = [| if True then 10 else 15 |] - -t1 :: Int -t1 = if True then 10 else 15 - - -(>>=) :: a -> ((forall b . b) -> c) -> c -a >>= f = f undefined -return _ = 'b' -fail s = undefined - -t2 :: Char -t2 = do { return 'k' } - -charQuote_TTH :: Code Q Char -charQuote_TTH = [|| do { return 'k' } ||] - -charQuote_TH :: Quote m => m Exp -charQuote_TH = [| do { return 'k' } |] - -fromListN :: Int -> [Int] -> [Int] -fromListN _ l = replicate (length l) (length l) - -fromList :: [Int] -> [Int] -fromList x = replicate (length x) (length x) - - -t3 :: [Int] -t3 = [2..7] - -seqQuote_TTH :: Code Q [Int] -seqQuote_TTH = [|| [2..7] ||] - -seqQuote_TH :: Quote m => m Exp -seqQuote_TH = [| [2..7] |] - - -t4 :: [Int] -t4 = [1,2,3] - -listQuote_TTH :: Code Q [Int] -listQuote_TTH = [|| [1,2,3] ||] - -listQuote_TH :: Quote m => m Exp -listQuote_TH = [| [1,2,3] |] +intQuote :: Code Q Int +intQuote = [|| if True then 10 else 15 ||] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e65ad951348d5e11786b3d6de329396… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e65ad951348d5e11786b3d6de329396… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/ani/T27156] revert th test
by Apoorv Ingle (＠ani) 16 Aug '26

16 Aug '26

Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: f0448b76 by Apoorv Ingle at 2026-08-16T12:19:58-05:00 revert th test - - - - - 4 changed files: - compiler/GHC/Rename/Expr.hs - testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr - testsuite/tests/th/T18102b.hs - testsuite/tests/th/T18102b_aux.hs Changes: ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -46,7 +46,6 @@ import GHC.Driver.DynFlags import GHC.Builtin.KnownKeys import GHC.Builtin.KnownOccs import GHC.Builtin.WiredIn.Types ( nilDataConName, oneDataConName ) -import GHC.Builtin.WiredIn.Ids( rightSectionName, leftSectionName ) import GHC.Unit.Module ( isInteractiveModule ) ===================================== testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr ===================================== @@ -1,41 +1,42 @@ RecordDotSyntaxFail8.hs:47:17: error: [GHC-39999] • No instance for ‘HasField "quux1" Quux Quux’ - arising from selecting the field ‘quux1’ - NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class. + arising from selecting the field ‘quux1’ + NB: ‘HasField’ is not the built-in ‘HasField’ class. • In the second argument of ‘($)’, namely ‘a.foo.bar.baz.quux1’ In a stmt of a 'do' block: print @Quux $ a.foo.bar.baz.quux1 In the expression: - do let a = Foo {foo = ...} - print @Quux $ ....bar.baz.quux1 - let b = myQuux - print @Quux $ b.quux2 - let c = Foo {foo = ...} - ... + do let a = Foo {foo = ...} + print @Quux $ ....bar.baz.quux1 + let b = myQuux + print @Quux $ b.quux2 + let c = Foo {foo = ...} + ... RecordDotSyntaxFail8.hs:50:17: error: [GHC-39999] • No instance for ‘HasField "quux2" Quux Quux’ - arising from selecting the field ‘quux2’ + arising from selecting the field ‘quux2’ NB: ‘HasField’ is not the built-in ‘HasField’ class. • In the second argument of ‘($)’, namely ‘b.quux2’ In a stmt of a 'do' block: print @Quux $ b.quux2 In the expression: - do let a = Foo {foo = ...} - print @Quux $ ....bar.baz.quux1 - let b = myQuux - print @Quux $ b.quux2 - let c = Foo {foo = ...} - ... + do let a = Foo {foo = ...} + print @Quux $ ....bar.baz.quux1 + let b = myQuux + print @Quux $ b.quux2 + let c = Foo {foo = ...} + ... RecordDotSyntaxFail8.hs:53:17: error: [GHC-39999] • No instance for ‘HasField "quux3" Quux r0’ - arising from selecting the field ‘quux3’ - NB: ‘HasField’ is not the built-in ‘GHC.Internal.Records.HasField’ class. + arising from selecting the field ‘quux3’ + NB: ‘HasField’ is not the built-in ‘HasField’ class. • In the second argument of ‘($)’, namely ‘a.foo.bar.baz.quux3.wob’ In a stmt of a 'do' block: print @Bool $ a.foo.bar.baz.quux3.wob In the expression: - do let a = Foo {foo = ...} - print @Quux $ ....bar.baz.quux1 - let b = myQuux - print @Quux $ b.quux2 - let c = Foo {foo = ...} - ... + do let a = Foo {foo = ...} + print @Quux $ ....bar.baz.quux1 + let b = myQuux + print @Quux $ b.quux2 + let c = Foo {foo = ...} + ... + ===================================== testsuite/tests/th/T18102b.hs ===================================== @@ -1,47 +1,9 @@ -{-# LANGUAGE TemplateHaskell, RebindableSyntax #-} +{-# LANGUAGE TemplateHaskell #-} -import Prelude import T18102b_aux -x1 :: Int -x1 = $$(intQuote_TTH) - -z1 :: Int -z1 = $(intQuote_TH) - -x2 :: Char -x2 = $$(charQuote_TTH) - -z2 :: Char -z2 = $(charQuote_TH) - -x3 :: [Int] -x3 = $$(seqQuote_TTH) - -z3 :: [Int] -z3 = $(seqQuote_TH) - -x4 :: [Int] -x4 = $$(listQuote_TTH) - -z4 :: [Int] -z4 = $(listQuote_TH) - +x :: Int +x = $$(intQuote) main :: IO () -main = do - print t1 - print x1 - print z1 - - print t2 - print x2 - print z2 - - print t3 - print x3 - print z3 - - print t4 - print x4 - print z4 +main = print x ===================================== testsuite/tests/th/T18102b_aux.hs ===================================== @@ -1,60 +1,11 @@ -{-# LANGUAGE RebindableSyntax, TemplateHaskell, OverloadedLists #-} +{-# LANGUAGE RebindableSyntax, TemplateHaskell #-} module T18102b_aux where -import Prelude hiding ((>>=), return ) +import Prelude import Language.Haskell.TH.Syntax - - ifThenElse :: Bool -> Int -> Int -> Int ifThenElse _ a b = a+b -intQuote_TTH :: Code Q Int -intQuote_TTH = [|| if True then 10 else 15 ||] - -intQuote_TH :: Quote m => m Exp -intQuote_TH = [| if True then 10 else 15 |] - -t1 :: Int -t1 = if True then 10 else 15 - - -(>>=) :: a -> ((forall b . b) -> c) -> c -a >>= f = f undefined -return _ = 'b' -fail s = undefined - -t2 :: Char -t2 = do { return 'k' } - -charQuote_TTH :: Code Q Char -charQuote_TTH = [|| do { return 'k' } ||] - -charQuote_TH :: Quote m => m Exp -charQuote_TH = [| do { return 'k' } |] - -fromListN :: Int -> [Int] -> [Int] -fromListN _ l = replicate (length l) (length l) - -fromList :: [Int] -> [Int] -fromList x = replicate (length x) (length x) - - -t3 :: [Int] -t3 = [2..7] - -seqQuote_TTH :: Code Q [Int] -seqQuote_TTH = [|| [2..7] ||] - -seqQuote_TH :: Quote m => m Exp -seqQuote_TH = [| [2..7] |] - - -t4 :: [Int] -t4 = [1,2,3] - -listQuote_TTH :: Code Q [Int] -listQuote_TTH = [|| [1,2,3] ||] - -listQuote_TH :: Quote m => m Exp -listQuote_TH = [| [1,2,3] |] +intQuote :: Code Q Int +intQuote = [|| if True then 10 else 15 ||] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0448b763abcffc52f2af97477a74c7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f0448b763abcffc52f2af97477a74c7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27602] 3 commits: testsuite: Show baseline sample count and spread in perf failures
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27602 at Glasgow Haskell Compiler / GHC Commits: befe88fd by Simon Jakobi at 2026-08-16T17:54:44+02:00 testsuite: Show baseline sample count and spread in perf failures A perf baseline is the mean of all samples recorded for a commit, so a single outlier can silently corrupt it. Previously, the failure output gave no hint about such outliers: the baseline printed as one number. In #27602, T27336's peak_megabytes_allocated baseline showed as 757 when the underlying samples were 605 and 909. When the baseline is averaged from more than one sample, say so in the failure message and list the samples, both in the one-line stat-failure reason and in the detail block. Single-sample baselines print exactly as before. Context: #27602 Assisted-by: Claude Fable 5 - - - - - d54d52ea by Simon Jakobi at 2026-08-16T17:54:44+02:00 ci: Clarify comment on pushing perf notes after failures Context: #27602 Assisted-by: Claude Fable 5 - - - - - e17c0f57 by Simon Jakobi at 2026-08-16T17:55:13+02:00 DEMO: Tighten T3064 residency tolerance (do not merge) Assisted-by: Claude Fable 5 - - - - - 3 changed files: - .gitlab/ci.sh - testsuite/driver/perf_notes.py - testsuite/tests/perf/compiler/all.T Changes: ===================================== .gitlab/ci.sh ===================================== @@ -1120,9 +1120,10 @@ case ${1:-help} in setup) setup && cleanup_submodules ;; configure) time_it "configure" configure ;; build_hadrian) time_it "build" build_hadrian ;; - # N.B. Always push notes, even if the build fails. This is okay to do as the - # testsuite driver doesn't record notes for tests that fail due to - # correctness. + # N.B. Always push notes, even if the build fails. Metrics from runs failing + # a perf stat check are deliberately recorded too — discarding them would + # bias the baseline towards whichever sample came first. Only correctness + # failures record nothing. test_hadrian) fetch_perf_notes res=0 ===================================== testsuite/driver/perf_notes.py ===================================== @@ -84,8 +84,11 @@ PerfStat = NamedTuple('PerfStat', [('test_env', TestEnv), ('value', float)]) # A baseline recovered form stored metrics. -Baseline = NamedTuple('Baseline', [('perfStat', PerfStat), - ('commit', GitHash)]) +class Baseline(NamedTuple): + perfStat: PerfStat + commit: GitHash + # The raw samples the baseline value was averaged over. + samples: List[float] = [] # The type of exceptions which are thrown when computing the current stat value # fails. @@ -465,6 +468,10 @@ def get_allowed_changes(baseline_ref: Optional[GitRef]) -> Dict[TestName, List[A # (bool , str ) -> (str , str , str , str) -> float _commit_metric_cache = {} # type: ignore +# Like _commit_metric_cache, but mapping to the list of raw sample values the +# baseline was averaged over. Filled by get_commit_metric. +_commit_samples_cache = {} # type: ignore + # Get the baseline of a test at a given commit. This is the expected value # *before* the commit is applied (i.e. on the parent commit). # This searches git notes from older commits for recorded metrics (locally and @@ -506,7 +513,8 @@ def baseline_metric(commit: GitHash, if baseline_commit is not None: current_metric = get_commit_metric(namespace, baseline_commit, test_env, name, metric, way) if current_metric is not None: - return Baseline(current_metric, baseline_commit) + return Baseline(current_metric, baseline_commit, + get_commit_samples(namespace, baseline_commit, test_env, name, metric, way)) else: return None @@ -515,7 +523,8 @@ def baseline_metric(commit: GitHash, # Check for a metric on this commit. current_metric = get_commit_metric(namespace, current_commit, test_env, name, metric, way) if current_metric is not None: - return Baseline(current_metric, current_commit) + return Baseline(current_metric, current_commit, + get_commit_samples(namespace, current_commit, test_env, name, metric, way)) # Stop if there is an expected change at this commit. In that case # metrics on ancestor commits will not be a valid baseline. @@ -598,8 +607,26 @@ def get_commit_metric(gitNoteRef, # Save baselines to the cache. _commit_metric_cache[cacheKeyA] = baseline_by_cache_key_b + _commit_samples_cache[cacheKeyA] = values_by_cache_key_b return baseline_by_cache_key_b.get(cacheKeyB) +# Get the raw sample values that get_commit_metric averages over. Uses the +# cache filled by get_commit_metric, so no extra git calls after it has run. +def get_commit_samples(gitNoteRef, + ref: Union[GitRef, GitHash], + test_env: TestEnv, + name: TestName, + metric: MetricName, + way: WayName + ) -> List[float]: + get_commit_metric(gitNoteRef, ref, test_env, name, metric, way) + cacheKeyA = (gitNoteRef, commit_hash(ref)) + cacheKeyB = (test_env, name, metric, way) + return _commit_samples_cache.get(cacheKeyA, {}).get(cacheKeyB, []) + +def format_samples(samples: List[float]) -> str: + return ', '.join(str(int(s)) if s == int(s) else str(s) for s in samples) + def check_stats_change(actual: PerfStat, baseline: Baseline, acceptance_window: MetricAcceptanceWindow, @@ -654,9 +681,16 @@ def check_stats_change(actual: PerfStat, ' baseline @ %s' % baseline.commit print(actual.metric, error + ':') dev = 100.0 if expected_val == 0 else round(((float(actual.value) * 100) / int(expected_val)) - 100, 1) + # Show the samples so outliers become visible (#27602). + if len(baseline.samples) > 1: + samples_note = ('; baseline is mean of %d samples: %s' + % (len(baseline.samples), + format_samples(baseline.samples))) + else: + samples_note = '' change_line = (f'{actual.metric} {change.value} from {baseline.perfStat.test_env} ' f'baseline @ {baseline.commit[:7]}: {expected_val} -> {actual.value} ' - f'({dev:+g}%, allowed {acceptance_window.describe()})') + f'({dev:+g}%, allowed {acceptance_window.describe()}{samples_note})') result = failBecause('stat ' + change_line, tag='stat') if not change_allowed or force_print: @@ -666,6 +700,10 @@ def check_stats_change(actual: PerfStat, print(descr, str(val).rjust(length), extra) display(' Expected ' + full_name + ' ' + actual.metric + ':', expected_val, acceptance_window.describe()) + if len(baseline.samples) > 1: + display(' Samples ' + full_name + ' ' + actual.metric + ':', + len(baseline.samples), + '(' + format_samples(baseline.samples) + ')') display(' Lower bound ' + full_name + ' ' + actual.metric + ':', lowerBound, '') display(' Upper bound ' + full_name + ' ' + actual.metric + ':', upperBound, '') display(' Actual ' + full_name + ' ' + actual.metric + ':', actual.value, '') ===================================== testsuite/tests/perf/compiler/all.T ===================================== @@ -48,7 +48,9 @@ test('T4801', ['']) test('T3064', - [collect_compiler_residency(20), + [# Demo-only: tightened from 20 so the bimodal max_bytes_used + # baseline on aarch64-linux-deb13-validate fails. + collect_compiler_residency(1), collect_compiler_runtime(2), only_ways(['normal']), ], View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9c078d6ec9af1b48a31aec2a0e2b8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9c078d6ec9af1b48a31aec2a0e2b8… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27619-liveness-fixpoint-formats] NCG: compare register formats by width, remove Ord Format
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC Commits: 10e6330d by Simon Jakobi at 2026-08-16T16:28:30+02:00 NCG: compare register formats by width, remove Ord Format maxRegWithFormat, minusCoveredRegs and shrinkingRegs compared formats with Format's derived Ord, which orders by constructor, not by width: FF32 > II64, and VecFormat 16 FmtInt8 (16 bytes) > VecFormat 8 FmtDouble (64 bytes). This is harmless while all vector vregs are 128-bit, but becomes unsound in the (FmtBwd2) direction of Note [Register formats in liveness analysis] once wider vectors land in the NCG. Noted in #27619. The comparisons now go by formatToWidth, except the liveness join maxRegWithFormat, which needs a total order to keep the liveness fixpoint convergent and uses the new width-major compareFormat. See Note [Convergence of the liveness fixpoint] in GHC.CmmToAsm.Reg.Liveness. Also remove the Ord instances of Format and ScalarFormat, so no future call site can mistake the derived order for a width order. Their only other user was a width test in GHC.CmmToAsm.PPC.CodeGen, now expressed with formatToWidth. Assisted-by: Claude Fable 5 - - - - - 4 changed files: - compiler/GHC/CmmToAsm/Format.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Reg/Regs.hs Changes: ===================================== compiler/GHC/CmmToAsm/Format.hs ===================================== @@ -23,6 +23,7 @@ module GHC.CmmToAsm.Format ( vecFormat, isVecFormat, cmmTypeFormat, + compareFormat, formatToWidth, scalarWidth, formatInBytes, @@ -40,11 +41,13 @@ where import GHC.Prelude +import Data.Semigroup ( (<>) ) + import GHC.Cmm import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg ) import GHC.Types.Unique ( Uniquable(..) ) import GHC.Types.Unique.Set -import GHC.Utils.Outputable +import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic {- Note [GHC's data format representations] @@ -92,7 +95,9 @@ data Format | FF64 | VecFormat !Length -- ^ number of elements (always at least 2) !ScalarFormat -- ^ format of each element - deriving (Show, Eq, Ord) + deriving (Show, Eq) + -- No Ord: compare via 'formatToWidth', or use 'compareFormat' where a + -- total order is needed. pattern IntegerFormat :: Format pattern IntegerFormat <- ( isIntegerFormat -> True ) @@ -117,7 +122,7 @@ data ScalarFormat | FmtInt64 | FmtFloat | FmtDouble - deriving (Show, Eq, Ord) + deriving (Show, Eq) scalarFormatFormat :: ScalarFormat -> Format scalarFormatFormat = \case @@ -248,6 +253,33 @@ scalarWidth = \case formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth +-- | Total order on formats: by width, with an arbitrary but fixed tiebreak +-- between distinct formats of the same width. +-- +-- See Note [Convergence of the liveness fixpoint] in GHC.CmmToAsm.Reg.Liveness. +compareFormat :: Format -> Format -> Ordering +compareFormat f1 f2 = + compare (formatToWidth f1) (formatToWidth f2) <> compare (tag f1) (tag f2) + where + tag :: Format -> (Int, Length) + tag = \case + II8 -> (0, 0) + II16 -> (1, 0) + II32 -> (2, 0) + II64 -> (3, 0) + FF32 -> (4, 0) + FF64 -> (5, 0) + VecFormat l s -> (6 + scalarTag s, l) + + scalarTag :: ScalarFormat -> Int + scalarTag = \case + FmtInt8 -> 0 + FmtInt16 -> 1 + FmtInt32 -> 2 + FmtInt64 -> 3 + FmtFloat -> 4 + FmtDouble -> 5 + -------------------------------------------------------------------------------- -- | A typed virtual register: a virtual register, together with the specific ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -484,7 +484,7 @@ getRegister' _ _ (CmmMachOp (MO_SS_Conv src tgt) [CmmLoad mem pk _]) , src < tgt = do let format = cmmTypeFormat pk -- lwa is DS-form. See Note [Power instruction format] - let form = if format >= II32 then DS else D + let form = if formatToWidth format >= W32 then DS else D Amode addr addr_code <- getAmode form mem let code dst = assert (format == intFormat src) $ addr_code `snocOL` LA format dst addr ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -937,9 +937,13 @@ test: dependency order. Comparing the whole accumulated block map would make the fixpoint quadratic in procedure size (#27437). -The fixpoint terminates because the entries can only grow: registers are -only added, formats only increase via 'maxRegWithFormat' joins, and both -lattices are finite. +The fixpoint terminates because the entries can only grow: registers are only +added, formats only increase via 'maxRegWithFormat' joins, and both lattices +are finite. For that the join must be a max in a total order on formats — +comparing widths is not enough. Distinct formats can share a width (say +VecFormat 2 FmtDouble and VecFormat 4 FmtFloat), and if the join broke such +ties by argument order, two blocks in a loop could theoretically swap +same-width formats on every iteration and the fixpoint would never converge. -} ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -20,7 +20,8 @@ module GHC.CmmToAsm.Reg.Regs ( import GHC.Prelude import GHC.Platform.Reg ( Reg ) -import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) +import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat, + compareFormat, formatToWidth ) import GHC.Utils.Outputable ( Outputable ) import GHC.Types.Unique ( Uniquable(..) ) @@ -39,11 +40,12 @@ newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - = if fmt1 >= fmt2 - then r1 - else r2 - -- Re-using one of the arguments avoids allocating a new 'RegWithFormat', - -- compared with returning 'RegWithFormat r1 (max fmt1 fmt2)'. + | LT <- compareFormat fmt1 fmt2 = r2 + | otherwise = r1 + -- See Note [Convergence of the liveness fixpoint] in + -- GHC.CmmToAsm.Reg.Liveness. + -- + -- Re-using one of the arguments avoids allocating a new 'RegWithFormat'. noRegs :: Regs noRegs = Regs emptyUniqSet @@ -66,7 +68,7 @@ minusCoveredRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f r1@(RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = - if fmt2 >= fmt1 + if formatToWidth fmt2 >= formatToWidth fmt1 || not ( isVecFormat fmt1 ) -- See Wrinkle [Don't allow scalar partial writes] @@ -99,7 +101,7 @@ shrinkingRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f (RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - | fmt2 < fmt1 + | formatToWidth fmt2 < formatToWidth fmt1 = Just r2 | otherwise = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10e6330d9c54a295946b9aebb05a6df… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/10e6330d9c54a295946b9aebb05a6df… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27619-liveness-fixpoint-formats] NCG: compare register formats by width, remove Ord Format
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC Commits: e50eaaeb by Simon Jakobi at 2026-08-16T15:43:20+02:00 NCG: compare register formats by width, remove Ord Format maxRegWithFormat, minusCoveredRegs and shrinkingRegs compared formats with Format's derived Ord, which orders by constructor, not by width: FF32 > II64, and VecFormat 16 FmtInt8 (16 bytes) > VecFormat 8 FmtDouble (64 bytes). This is harmless while all vector vregs are 128-bit, but becomes unsound in the (FmtBwd2) direction of Note [Register formats in liveness analysis] once wider vectors land in the NCG. Noted in #27619. The comparisons now go by formatToWidth, except the liveness join maxRegWithFormat, which needs a total order to keep the liveness fixpoint convergent and uses the new width-major compareFormat. See Note [Format order is width-major] in GHC.CmmToAsm.Format. Also remove the Ord instances of Format and ScalarFormat, so no future call site can mistake the derived order for a width order. Their only other user was a width test in GHC.CmmToAsm.PPC.CodeGen, now expressed with formatToWidth. Assisted-by: Claude Fable 5 - - - - - 4 changed files: - compiler/GHC/CmmToAsm/Format.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Reg/Regs.hs Changes: ===================================== compiler/GHC/CmmToAsm/Format.hs ===================================== @@ -23,6 +23,7 @@ module GHC.CmmToAsm.Format ( vecFormat, isVecFormat, cmmTypeFormat, + compareFormat, formatToWidth, scalarWidth, formatInBytes, @@ -40,11 +41,13 @@ where import GHC.Prelude +import Data.Semigroup ( (<>) ) + import GHC.Cmm import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg ) import GHC.Types.Unique ( Uniquable(..) ) import GHC.Types.Unique.Set -import GHC.Utils.Outputable +import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic {- Note [GHC's data format representations] @@ -92,7 +95,8 @@ data Format | FF64 | VecFormat !Length -- ^ number of elements (always at least 2) !ScalarFormat -- ^ format of each element - deriving (Show, Eq, Ord) + deriving (Show, Eq) + -- No Ord: see Note [Format order is width-major] pattern IntegerFormat :: Format pattern IntegerFormat <- ( isIntegerFormat -> True ) @@ -117,7 +121,7 @@ data ScalarFormat | FmtInt64 | FmtFloat | FmtDouble - deriving (Show, Eq, Ord) + deriving (Show, Eq) scalarFormatFormat :: ScalarFormat -> Format scalarFormatFormat = \case @@ -248,6 +252,50 @@ scalarWidth = \case formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth +{- Note [Format order is width-major] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'Format' has no 'Ord' instance: the only meaningful order on formats is by +width, and code that needs "at least as wide" should say so by comparing +'formatToWidth' results. + +'compareFormat' exists for one caller: 'maxRegWithFormat' in +GHC.CmmToAsm.Reg.Regs, which joins the formats recorded for a register during +liveness analysis. That join must be a max in a *total* order. Width alone is +not total: distinct formats can share a width, e.g. VecFormat 2 FmtDouble and +VecFormat 4 FmtFloat. If the join broke such ties by argument order, two +blocks in a loop could swap same-width formats on every iteration of the +liveness fixpoint, and the fixpoint would never converge. See +Note [Convergence of the liveness fixpoint] in GHC.CmmToAsm.Reg.Liveness. +So 'compareFormat' refines width order with an arbitrary but fixed tiebreak. +-} + +-- | Total order on formats: by width, with an arbitrary but fixed tiebreak +-- between distinct formats of the same width. +-- +-- See Note [Format order is width-major]. +compareFormat :: Format -> Format -> Ordering +compareFormat f1 f2 = + compare (formatToWidth f1) (formatToWidth f2) <> compare (tag f1) (tag f2) + where + tag :: Format -> (Int, Length) + tag = \case + II8 -> (0, 0) + II16 -> (1, 0) + II32 -> (2, 0) + II64 -> (3, 0) + FF32 -> (4, 0) + FF64 -> (5, 0) + VecFormat l s -> (6 + scalarTag s, l) + + scalarTag :: ScalarFormat -> Int + scalarTag = \case + FmtInt8 -> 0 + FmtInt16 -> 1 + FmtInt32 -> 2 + FmtInt64 -> 3 + FmtFloat -> 4 + FmtDouble -> 5 + -------------------------------------------------------------------------------- -- | A typed virtual register: a virtual register, together with the specific ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -484,7 +484,7 @@ getRegister' _ _ (CmmMachOp (MO_SS_Conv src tgt) [CmmLoad mem pk _]) , src < tgt = do let format = cmmTypeFormat pk -- lwa is DS-form. See Note [Power instruction format] - let form = if format >= II32 then DS else D + let form = if formatToWidth format >= W32 then DS else D Amode addr addr_code <- getAmode form mem let code dst = assert (format == intFormat src) $ addr_code `snocOL` LA format dst addr ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -939,7 +939,8 @@ test: The fixpoint terminates because the entries can only grow: registers are only added, formats only increase via 'maxRegWithFormat' joins, and both -lattices are finite. +lattices are finite. This needs the join to be a max in a total order on +formats. See Note [Format order is width-major] in GHC.CmmToAsm.Format. -} ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -20,7 +20,8 @@ module GHC.CmmToAsm.Reg.Regs ( import GHC.Prelude import GHC.Platform.Reg ( Reg ) -import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) +import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat, + compareFormat, formatToWidth ) import GHC.Utils.Outputable ( Outputable ) import GHC.Types.Unique ( Uniquable(..) ) @@ -39,11 +40,13 @@ newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - = if fmt1 >= fmt2 - then r1 - else r2 - -- Re-using one of the arguments avoids allocating a new 'RegWithFormat', - -- compared with returning 'RegWithFormat r1 (max fmt1 fmt2)'. + | LT <- compareFormat fmt1 fmt2 = r2 + | otherwise = r1 + -- The join must be a max in a total order ('compareFormat', not a width + -- comparison), or the liveness fixpoint may not converge. + -- See Note [Format order is width-major] in GHC.CmmToAsm.Format. + -- + -- Re-using one of the arguments avoids allocating a new 'RegWithFormat'. noRegs :: Regs noRegs = Regs emptyUniqSet @@ -66,7 +69,7 @@ minusCoveredRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f r1@(RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = - if fmt2 >= fmt1 + if formatToWidth fmt2 >= formatToWidth fmt1 || not ( isVecFormat fmt1 ) -- See Wrinkle [Don't allow scalar partial writes] @@ -99,7 +102,7 @@ shrinkingRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f (RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - | fmt2 < fmt1 + | formatToWidth fmt2 < formatToWidth fmt1 = Just r2 | otherwise = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e50eaaebf4aa044d3254f3b7d2bb9a7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e50eaaebf4aa044d3254f3b7d2bb9a7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27619-liveness-fixpoint-formats] NCG: compare register formats by width, remove Ord Format
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC Commits: 41798691 by Simon Jakobi at 2026-08-16T15:37:27+02:00 NCG: compare register formats by width, remove Ord Format maxRegWithFormat, minusCoveredRegs and shrinkingRegs compared formats with Format's derived Ord, which orders by constructor, not by width: FF32 > II64, and VecFormat 16 FmtInt8 (16 bytes) > VecFormat 8 FmtDouble (64 bytes). This is harmless while all vector vregs are 128-bit, but becomes unsound in the (FmtBwd2) direction of Note [Register formats in liveness analysis] once wider vectors land in the NCG. Noted in #27619. The comparisons now go by formatToWidth, except the liveness join maxRegWithFormat, which needs a total order to keep the liveness fixpoint convergent and uses the new width-major compareFormat. See Note [Format order is width-major] in GHC.CmmToAsm.Format. Also remove the Ord instances of Format and ScalarFormat, so no future call site can mistake the derived order for a width order. Their only other user was a width test in GHC.CmmToAsm.PPC.CodeGen, now expressed with formatToWidth. Assisted-by: Claude Fable 5 - - - - - 4 changed files: - compiler/GHC/CmmToAsm/Format.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Reg/Regs.hs Changes: ===================================== compiler/GHC/CmmToAsm/Format.hs ===================================== @@ -23,6 +23,7 @@ module GHC.CmmToAsm.Format ( vecFormat, isVecFormat, cmmTypeFormat, + compareFormat, formatToWidth, scalarWidth, formatInBytes, @@ -40,11 +41,13 @@ where import GHC.Prelude +import Data.Semigroup ( (<>) ) + import GHC.Cmm import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg ) import GHC.Types.Unique ( Uniquable(..) ) import GHC.Types.Unique.Set -import GHC.Utils.Outputable +import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic {- Note [GHC's data format representations] @@ -92,7 +95,8 @@ data Format | FF64 | VecFormat !Length -- ^ number of elements (always at least 2) !ScalarFormat -- ^ format of each element - deriving (Show, Eq, Ord) + deriving (Show, Eq) + -- No Ord: see Note [Format order is width-major] pattern IntegerFormat :: Format pattern IntegerFormat <- ( isIntegerFormat -> True ) @@ -117,7 +121,7 @@ data ScalarFormat | FmtInt64 | FmtFloat | FmtDouble - deriving (Show, Eq, Ord) + deriving (Show, Eq) scalarFormatFormat :: ScalarFormat -> Format scalarFormatFormat = \case @@ -248,6 +252,50 @@ scalarWidth = \case formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth +{- Note [Format order is width-major] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'Format' has no 'Ord' instance: the only meaningful order on formats is by +width, and code that needs "at least as wide" should say so by comparing +'formatToWidth' results. + +'compareFormat' exists for one caller: 'maxRegWithFormat' in +GHC.CmmToAsm.Reg.Regs, which joins the formats recorded for a register during +liveness analysis. That join must be a max in a *total* order. Width alone is +not total: distinct formats can share a width, e.g. VecFormat 2 FmtDouble and +VecFormat 4 FmtFloat. If the join broke such ties by argument order, two +blocks in a loop could swap same-width formats on every iteration of the +liveness fixpoint, and the fixpoint would never converge. See +Note [Convergence of the liveness fixpoint] in GHC.CmmToAsm.Reg.Liveness. +So 'compareFormat' refines width order with an arbitrary but fixed tiebreak. +-} + +-- | Total order on formats: by width, with an arbitrary but fixed tiebreak +-- between distinct formats of the same width. +-- +-- See Note [Format order is width-major]. +compareFormat :: Format -> Format -> Ordering +compareFormat f1 f2 = + compare (formatToWidth f1) (formatToWidth f2) <> compare (tag f1) (tag f2) + where + tag :: Format -> (Int, Length) + tag = \case + II8 -> (0, 0) + II16 -> (1, 0) + II32 -> (2, 0) + II64 -> (3, 0) + FF32 -> (4, 0) + FF64 -> (5, 0) + VecFormat l s -> (6 + scalarTag s, l) + + scalarTag :: ScalarFormat -> Int + scalarTag = \case + FmtInt8 -> 0 + FmtInt16 -> 1 + FmtInt32 -> 2 + FmtInt64 -> 3 + FmtFloat -> 4 + FmtDouble -> 5 + -------------------------------------------------------------------------------- -- | A typed virtual register: a virtual register, together with the specific ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -484,7 +484,7 @@ getRegister' _ _ (CmmMachOp (MO_SS_Conv src tgt) [CmmLoad mem pk _]) , src < tgt = do let format = cmmTypeFormat pk -- lwa is DS-form. See Note [Power instruction format] - let form = if format >= II32 then DS else D + let form = if formatToWidth format >= W32 then DS else D Amode addr addr_code <- getAmode form mem let code dst = assert (format == intFormat src) $ addr_code `snocOL` LA format dst addr ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -939,7 +939,8 @@ test: The fixpoint terminates because the entries can only grow: registers are only added, formats only increase via 'maxRegWithFormat' joins, and both -lattices are finite. +lattices are finite. This needs the join to be a max in a total order on +formats. See Note [Format order is width-major] in GHC.CmmToAsm.Format. -} ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -20,7 +20,8 @@ module GHC.CmmToAsm.Reg.Regs ( import GHC.Prelude import GHC.Platform.Reg ( Reg ) -import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) +import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat, + compareFormat, formatToWidth ) import GHC.Utils.Outputable ( Outputable ) import GHC.Types.Unique ( Uniquable(..) ) @@ -39,11 +40,14 @@ newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - = if fmt1 >= fmt2 + = if compareFormat fmt1 fmt2 /= LT then r1 else r2 - -- Re-using one of the arguments avoids allocating a new 'RegWithFormat', - -- compared with returning 'RegWithFormat r1 (max fmt1 fmt2)'. + -- The join must be a max in a total order ('compareFormat', not a width + -- comparison), or the liveness fixpoint may not converge. + -- See Note [Format order is width-major] in GHC.CmmToAsm.Format. + -- + -- Re-using one of the arguments avoids allocating a new 'RegWithFormat'. noRegs :: Regs noRegs = Regs emptyUniqSet @@ -66,7 +70,7 @@ minusCoveredRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f r1@(RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = - if fmt2 >= fmt1 + if formatToWidth fmt2 >= formatToWidth fmt1 || not ( isVecFormat fmt1 ) -- See Wrinkle [Don't allow scalar partial writes] @@ -99,7 +103,7 @@ shrinkingRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f (RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - | fmt2 < fmt1 + | formatToWidth fmt2 < formatToWidth fmt1 = Just r2 | otherwise = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/41798691e2dd393e119315a01dc7ac6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/41798691e2dd393e119315a01dc7ac6… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27619-liveness-fixpoint-formats] NCG: compare register formats by width, remove Ord Format
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC Commits: 58b29d3c by Simon Jakobi at 2026-08-16T15:32:54+02:00 NCG: compare register formats by width, remove Ord Format maxRegWithFormat, minusCoveredRegs and shrinkingRegs compared formats with Format's derived Ord, which orders by constructor, not by width: FF32 > II64, and VecFormat 16 FmtInt8 (16 bytes) > VecFormat 8 FmtDouble (64 bytes). This is harmless while all vector vregs are 128-bit, but becomes unsound in the (FmtBwd2) direction of Note [Register formats in liveness analysis] once wider vectors land in the NCG. Noted in #27619. The comparisons now go by formatToWidth, except the liveness join maxRegWithFormat, which needs a total order to keep the liveness fixpoint convergent and uses the new width-major compareFormat. See Note [Format order is width-major] in GHC.CmmToAsm.Format. Also remove the Ord instances of Format and ScalarFormat, so no future call site can mistake the derived order for a width order. Their only other user was a width test in GHC.CmmToAsm.PPC.CodeGen, now expressed with formatToWidth. Assisted-by: Claude Fable 5 - - - - - 4 changed files: - compiler/GHC/CmmToAsm/Format.hs - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Reg/Regs.hs Changes: ===================================== compiler/GHC/CmmToAsm/Format.hs ===================================== @@ -23,6 +23,7 @@ module GHC.CmmToAsm.Format ( vecFormat, isVecFormat, cmmTypeFormat, + compareFormat, formatToWidth, scalarWidth, formatInBytes, @@ -40,11 +41,13 @@ where import GHC.Prelude +import Data.Semigroup ( (<>) ) + import GHC.Cmm import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg ) import GHC.Types.Unique ( Uniquable(..) ) import GHC.Types.Unique.Set -import GHC.Utils.Outputable +import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic {- Note [GHC's data format representations] @@ -92,7 +95,8 @@ data Format | FF64 | VecFormat !Length -- ^ number of elements (always at least 2) !ScalarFormat -- ^ format of each element - deriving (Show, Eq, Ord) + deriving (Show, Eq) + -- No Ord: see Note [Format order is width-major] pattern IntegerFormat :: Format pattern IntegerFormat <- ( isIntegerFormat -> True ) @@ -117,7 +121,7 @@ data ScalarFormat | FmtInt64 | FmtFloat | FmtDouble - deriving (Show, Eq, Ord) + deriving (Show, Eq) scalarFormatFormat :: ScalarFormat -> Format scalarFormatFormat = \case @@ -248,6 +252,52 @@ scalarWidth = \case formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth +{- Note [Format order is width-major] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'Format' deliberately has no 'Ord' instance. A derived one would order by +constructor, and that reads like a width comparison without being one: +FF32 > II64, and VecFormat 16 FmtInt8 (16 bytes) > VecFormat 8 FmtDouble +(64 bytes). Code that needs "at least as wide" should compare 'formatToWidth' +results instead. + +'compareFormat' exists for one caller: 'maxRegWithFormat' in +GHC.CmmToAsm.Reg.Regs, which joins the formats recorded for a register during +liveness analysis. That join must be a max in a *total* order. Width alone is +not total: distinct formats can share a width, e.g. VecFormat 2 FmtDouble and +VecFormat 4 FmtFloat. If the join broke such ties by argument order, two +blocks in a loop could swap same-width formats on every iteration of the +liveness fixpoint, and the fixpoint would never converge. See +Note [Convergence of the liveness fixpoint] in GHC.CmmToAsm.Reg.Liveness. +So 'compareFormat' refines width order with an arbitrary but fixed tiebreak. +-} + +-- | Total order on formats: by width, with an arbitrary but fixed tiebreak +-- between distinct formats of the same width. +-- +-- See Note [Format order is width-major]. +compareFormat :: Format -> Format -> Ordering +compareFormat f1 f2 = + compare (formatToWidth f1) (formatToWidth f2) <> compare (tag f1) (tag f2) + where + tag :: Format -> (Int, Length) + tag = \case + II8 -> (0, 0) + II16 -> (1, 0) + II32 -> (2, 0) + II64 -> (3, 0) + FF32 -> (4, 0) + FF64 -> (5, 0) + VecFormat l s -> (6 + scalarTag s, l) + + scalarTag :: ScalarFormat -> Int + scalarTag = \case + FmtInt8 -> 0 + FmtInt16 -> 1 + FmtInt32 -> 2 + FmtInt64 -> 3 + FmtFloat -> 4 + FmtDouble -> 5 + -------------------------------------------------------------------------------- -- | A typed virtual register: a virtual register, together with the specific ===================================== compiler/GHC/CmmToAsm/PPC/CodeGen.hs ===================================== @@ -484,7 +484,7 @@ getRegister' _ _ (CmmMachOp (MO_SS_Conv src tgt) [CmmLoad mem pk _]) , src < tgt = do let format = cmmTypeFormat pk -- lwa is DS-form. See Note [Power instruction format] - let form = if format >= II32 then DS else D + let form = if formatToWidth format >= W32 then DS else D Amode addr addr_code <- getAmode form mem let code dst = assert (format == intFormat src) $ addr_code `snocOL` LA format dst addr ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -939,7 +939,8 @@ test: The fixpoint terminates because the entries can only grow: registers are only added, formats only increase via 'maxRegWithFormat' joins, and both -lattices are finite. +lattices are finite. This needs the join to be a max in a total order on +formats. See Note [Format order is width-major] in GHC.CmmToAsm.Format. -} ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -20,7 +20,8 @@ module GHC.CmmToAsm.Reg.Regs ( import GHC.Prelude import GHC.Platform.Reg ( Reg ) -import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) +import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat, + compareFormat, formatToWidth ) import GHC.Utils.Outputable ( Outputable ) import GHC.Types.Unique ( Uniquable(..) ) @@ -39,11 +40,14 @@ newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - = if fmt1 >= fmt2 + = if compareFormat fmt1 fmt2 /= LT then r1 else r2 - -- Re-using one of the arguments avoids allocating a new 'RegWithFormat', - -- compared with returning 'RegWithFormat r1 (max fmt1 fmt2)'. + -- The join must be a max in a total order ('compareFormat', not a width + -- comparison), or the liveness fixpoint may not converge. + -- See Note [Format order is width-major] in GHC.CmmToAsm.Format. + -- + -- Re-using one of the arguments avoids allocating a new 'RegWithFormat'. noRegs :: Regs noRegs = Regs emptyUniqSet @@ -66,7 +70,7 @@ minusCoveredRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f r1@(RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = - if fmt2 >= fmt1 + if formatToWidth fmt2 >= formatToWidth fmt1 || not ( isVecFormat fmt1 ) -- See Wrinkle [Don't allow scalar partial writes] @@ -99,7 +103,7 @@ shrinkingRegs = coerce $ minusUniqSet_C f where f :: RegWithFormat -> RegWithFormat -> Maybe RegWithFormat f (RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) - | fmt2 < fmt1 + | formatToWidth fmt2 < formatToWidth fmt1 = Just r2 | otherwise = Nothing View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58b29d3c22d72c29cec399b06971131… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58b29d3c22d72c29cec399b06971131… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27619-liveness-fixpoint-formats] NCG: iterate the liveness fixpoint until register formats converge
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27619-liveness-fixpoint-formats at Glasgow Haskell Compiler / GHC Commits: fb01838c by Simon Jakobi at 2026-08-16T13:11:21+02:00 NCG: iterate the liveness fixpoint until register formats converge The convergence test of the per-SCC liveness fixpoint in GHC.CmmToAsm.Reg.Liveness compared BlockMap Regs values with the key-only Eq of UniqSet, which ignores the Format attached to each register. Formats grow across iterations (one control-flow edge per iteration), so the fixpoint could stop while formats were still growing, recording a vector register live at a too-narrow format and handing the register allocator an under-sized spill/reload width (#27619). The test also compared the entire accumulated block map on every iteration, although only the current SCC's entries can change, making it quadratic in procedure size (#27437). Compare only the SCC's own entries, using the new format-aware equalRegs. See the new Note [Convergence of the liveness fixpoint]. Also remove the Eq instance of Regs: inherited from UniqSet, it compared the register uniques only, silently ignoring the formats. The convergence test was its sole user. Fixes #27619. Fixes #27437. Assisted-by: Claude Fable 5 - - - - - 5 changed files: - compiler/GHC/CmmToAsm/Reg/Liveness.hs - compiler/GHC/CmmToAsm/Reg/Regs.hs - compiler/GHC/Types/Unique/FM.hs - + testsuite/tests/regalloc/T27619.hs - testsuite/tests/regalloc/all.T Changes: ===================================== compiler/GHC/CmmToAsm/Reg/Liveness.hs ===================================== @@ -879,7 +879,7 @@ computeLiveness platform sccs , ppr sccs']) livenessSCCs - :: Instruction instr + :: forall instr. Instruction instr => Platform -> BlockMap Regs -> [SCC (LiveBasicBlock instr)] -- accum @@ -897,37 +897,50 @@ livenessSCCs platform blockmap done (AcyclicSCC block : sccs) livenessSCCs platform blockmap done (CyclicSCC blocks : sccs) = livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs - where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks + where (blockmap', blocks') = fixpoint blockmap - iterateUntilUnchanged - :: (a -> b -> (a,c)) -> (a -> a -> Bool) - -> a -> b - -> (a,c) - - iterateUntilUnchanged f eq aa b = go aa + -- See Note [Convergence of the liveness fixpoint] + fixpoint :: BlockMap Regs -> (BlockMap Regs, [LiveBasicBlock instr]) + fixpoint bm + | all unchanged blocks = (bm', blocks'') + | otherwise = fixpoint bm' where - go a = if eq a a' then ac else go a' - where - ac@(a', _) = f a b - - linearLiveness - :: Instruction instr - => BlockMap Regs -> [LiveBasicBlock instr] - -> (BlockMap Regs, [LiveBasicBlock instr]) - - linearLiveness = mapAccumL (livenessBlock platform) - - -- probably the least efficient way to compare two - -- BlockMaps for equality. - equalBlockMaps :: BlockMap Regs -> BlockMap Regs -> Bool - equalBlockMaps a b - = a' == b' - where a' = mapToList a - b' = mapToList b - -- See Note [Unique Determinism and code generation] - + (bm', blocks'') = mapAccumL (livenessBlock platform) bm blocks + + unchanged :: LiveBasicBlock instr -> Bool + unchanged block = + case (mapLookup bid bm, mapLookup bid bm') of + (Just old, Just new) -> old `equalRegs` new + (Nothing, _ ) -> False -- first iteration + (Just _, Nothing ) -> False -- can't happen + where bid = blockId block + +{- Note [Convergence of the liveness fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a cyclic SCC, we iterate 'livenessBlock' over the SCC's blocks until the +recorded entry liveness stops changing. Two subtleties in the convergence +test: + +* It must compare register formats, not just sets of live registers – + hence the format-aware 'equalRegs'. A block's live-in set joins the + successors' entries with 'unionRegsMaxFmt', so a wide format may take one + iteration per control-flow edge to propagate backwards around a loop. The + register sets themselves are typically complete after the first iteration. + If we stopped as soon as the sets stabilise, a register could be recorded + at a narrower format than the reads it flows into. That would violate + property (FmtBwd1) of Note [Register formats in liveness analysis], which + the register allocator relies on for spill and reload widths. See #27619. + +* It is sufficient to compare the entries of the SCC's own blocks. No other + entries can change: 'livenessBlock' inserts only the block it processes, + and successor SCCs are already final because SCCs are processed in reverse + dependency order. Comparing the whole accumulated block map would make the + fixpoint quadratic in procedure size (#27437). + +The fixpoint terminates because the entries can only grow: registers are +only added, formats only increase via 'maxRegWithFormat' joins, and both +lattices are finite. +-} -- | Annotate a basic block with register liveness information. ===================================== compiler/GHC/CmmToAsm/Reg/Regs.hs ===================================== @@ -13,6 +13,7 @@ module GHC.CmmToAsm.Reg.Regs ( shrinkingRegs, mapRegs, elemRegs, lookupReg, + equalRegs, ) where @@ -23,6 +24,7 @@ import GHC.CmmToAsm.Format ( Format, RegWithFormat(..), isVecFormat ) import GHC.Utils.Outputable ( Outputable ) import GHC.Types.Unique ( Uniquable(..) ) +import GHC.Types.Unique.FM ( equalUFMBy ) import GHC.Types.Unique.Set import Data.Coerce ( coerce ) @@ -33,7 +35,7 @@ import Data.Coerce ( coerce ) -- register liveness analysis. See Note [Register formats in liveness analysis] -- in GHC.CmmToAsm.Reg.Liveness. newtype Regs = Regs { getRegs :: UniqSet RegWithFormat } - deriving newtype (Eq, Outputable) + deriving newtype (Outputable) maxRegWithFormat :: RegWithFormat -> RegWithFormat -> RegWithFormat maxRegWithFormat r1@(RegWithFormat _ fmt1) r2@(RegWithFormat _ fmt2) @@ -117,3 +119,10 @@ elemRegs r (Regs live) = elemUniqSet_Directly (getUnique r) live lookupReg :: Reg -> Regs -> Maybe Format lookupReg r (Regs live) = regWithFormat_format <$> lookupUniqSet_Directly live (getUnique r) + +-- | Do the two sets contain the same registers, at the same formats? +equalRegs :: Regs -> Regs -> Bool +equalRegs (Regs a) (Regs b) = equalUFMBy sameFormat (getUniqSet a) (getUniqSet b) + where + -- Registers with equal uniques are equal, so only compare the formats. + sameFormat (RegWithFormat _ fmt1) (RegWithFormat _ fmt2) = fmt1 == fmt2 ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -67,6 +67,7 @@ module GHC.Types.Unique.FM ( strictIntersectUFM_C, disjointUFM, equalKeysUFM, + equalUFMBy, diffUFM, nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM, nonDetFoldWithKeyUFM, @@ -590,7 +591,12 @@ unsafeCastUFMKey (UFM m) = UFM m -- Determines whether two 'UniqFM's contain the same keys. equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool -equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 +equalKeysUFM = equalUFMBy (\_ _ -> True) + +-- | Determines whether two 'UniqFM's contain the same keys, with values +-- that agree according to the given predicate. +equalUFMBy :: (a -> b -> Bool) -> UniqFM key a -> UniqFM key b -> Bool +equalUFMBy eq (UFM m1) (UFM m2) = liftEq eq m1 m2 -- | An edit on type @a@, relating an element of a container (like an entry in a -- map or a line in a file) before and after. ===================================== testsuite/tests/regalloc/T27619.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +-- The native code for this loop is a three-block cycle H -> X -> W -> H: +-- +-- H (loop head): reads v at FF64 (movsd lane-0 extract for the guard) +-- X: reads v at FF64 (another movsd lane-0 extract) +-- W: reads v at F64x2 (movhlps from the full unpack) +-- +-- v is loop-invariant, so its live format on entry to every block in the +-- cycle must be F64x2. -fno-cse only keeps the two syntactically identical +-- lane-0 extracts from being merged. +-- +-- The test greps -ddump-asm-liveness for a 128-bit vector register recorded +-- at FF64, which the too-early convergence of the liveness fixpoint produced. +module T27619 where + +import GHC.Exts + +loop :: Int# -> DoubleX2# -> Double# -> Double# +loop i v acc = + case unpackDoubleX2# v of + (# a1, _ #) -> + if isTrue# (a1 <## int2Double# i) + then acc + else case unpackDoubleX2# v of + (# a2, _ #) -> + if isTrue# (a2 *## 2.0## <## int2Double# i) + then acc *## 2.0## + else case unpackDoubleX2# v of + (# x, y #) -> loop (i -# 1#) v (acc +## (x *## y)) +{-# NOINLINE loop #-} ===================================== testsuite/tests/regalloc/all.T ===================================== @@ -6,3 +6,14 @@ test('regalloc_unit_tests', [ignore_stderr, only_ways(['normal'])], extra_run_opts('"' + config.libdir + '"') ], compile_and_run, ['-package ghc']) + +# The liveness fixpoint must iterate until the register formats converge, not +# just the sets of live registers (#27619). A vector register live at +# VecFormat 2 FmtDouble around the loop must not be recorded at FF64. +test('T27619', + [ unless(arch('x86_64'), skip), + when(not have_ncg(), skip), + only_ways(['normal']), + grep_errmsg(r'%vV128_\S+ :: FF64') ], + compile, + ['-O -fno-cse -ddump-asm-liveness']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fb01838c8a381359c096c6133111ea7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fb01838c8a381359c096c6133111ea7… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27547-testsuite-robustness-reword] 3 commits: testsuite: Don't let a straggling test process hang the whole run
by Simon Jakobi (＠sjakobi) 16 Aug '26

16 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27547-testsuite-robustness-reword at Glasgow Haskell Compiler / GHC Commits: 9c373e02 by Simon Jakobi at 2026-08-16T12:27:56+02:00 testsuite: Don't let a straggling test process hang the whole run A test process that outlives the timeout program's direct child -- for instance a forkProcess child that deadlocks during RTS shutdown (#27547) -- keeps the inherited stdout/stderr pipes open. The driver then blocks forever waiting for EOF, with no timeout left to break it, so a single bad test hangs the entire testsuite run. timeout.py now kills the test's whole process group once its direct child has been reaped. The child already puts itself in a fresh group via setpgrp(). T12903 in the threaded nonmoving ways is the concrete case. Running it alone used to hang the driver indefinitely, leaving the deadlocked child alive and holding the pipes. Now the run completes and the test passes. Assisted-by: Claude Fable 5 - - - - - 798f43df by Simon Jakobi at 2026-08-16T12:27:56+02:00 testsuite: Mark T25280 broken in threaded nonmoving ways (#27547) Under the threaded RTS with -xn, a forkProcess child inherits the nonmoving collector's state but not its nonmoving-mark thread, and deadlocks during RTS shutdown. Of the testsuite's forkProcess tests, only T25280 waits for its children, so it is the only one that observes the deadlock (as a timeout). T12903, T24672 and hpc_fork pass either way. Add a nonmoving_threaded_ways group and expect T25280 to be broken there, so the fix shows up as an unexpected pass. Assisted-by: Claude Fable 5 - - - - - 14fdef2e by Simon Jakobi at 2026-08-16T12:37:28+02:00 Make stopInterp wait for the external interpreter to exit stopInterp sent Shutdown and returned immediately, so GHC could exit while the interpreter process was still shutting down. Any buffered output the interpreter produced on GHC's behalf (e.g. from a TH splice writing to the shared stdout) was then lost if the process was killed before flushing on exit. The testsuite does exactly that since the straggler kill in timeout.py, which made T25155 flaky on slower CI machines. Wait for the process to exit after sending Shutdown, bounded by a timeout in case it is wedged. Context: #27547 Assisted-by: Claude Fable 5 - - - - - 4 changed files: - compiler/GHC/Runtime/Interpreter.hs - testsuite/config/ghc - testsuite/tests/rts/all.T - testsuite/timeout/timeout.py Changes: ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -113,6 +113,7 @@ import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) import System.Directory import System.Process +import System.Timeout (timeout) import qualified GHC.InfoProv as InfoProv import GHC.Builtin.Modules( gHC_PRIM, gHC_PRIMOPWRAPPERS ) @@ -652,10 +653,16 @@ stopInterp interp = case interpInstance interp of case state of InterpPending -> pure state -- already stopped InterpRunning i -> do - ex <- getProcessExitCode (interpHandle (instProcess i)) - if isJust ex - then pure () - else sendMessage i Shutdown + let hdl = interpHandle (instProcess i) + ex <- getProcessExitCode hdl + unless (isJust ex) $ do + sendMessage i Shutdown + -- The interpreter process shares our stdout/stderr; wait for + -- it to exit (flushing its output), lest output it produced + -- on our behalf be lost if it is killed once we exit. + -- Bounded, in case the process is wedged. + _ <- timeout 5000000 {- 5s -} (waitForProcess hdl) + pure () pure InterpPending -- ----------------------------------------------------------------------------- ===================================== testsuite/config/ghc ===================================== @@ -197,6 +197,11 @@ debug_ways = [x[0] for x in config.way_flags.items() threaded_ways = [x[0] for x in config.way_flags.items() if '-threaded' in x[1] or 'ghci' == x[0] or 'ghci-opt' == x[0]] +# #27547 +nonmoving_threaded_ways = [name for name, flags in config.way_flags.items() + if '-threaded' in flags + if '-xn' in config.way_rts_flags.get(name, [])] + # Ways which run with multiple capabilities concurrent_ways = [name for name, flags in config.way_flags.items() if '-threaded' in flags or 'ghci' == name or 'ghci-opt' == name ===================================== testsuite/tests/rts/all.T ===================================== @@ -668,7 +668,11 @@ test('IOManager', [js_skip, when(arch('wasm32'), skip), when(opsys('mingw32'), s test('T24142', [req_target_smp], compile_and_run, ['-threaded -with-rtsopts "-N2"']) test('T25232', [unless(have_profiling(), skip), only_ways(['normal','nonmoving','nonmoving_prof','nonmoving_thr_prof']), extra_ways(['nonmoving', 'nonmoving_prof'] + (['nonmoving_thr_prof'] if have_threaded() else []))], compile_and_run, ['']) -test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_run, ['']) +# T25280 waits for its forked children, so it detects the forkProcess +# child-shutdown deadlock of #27547 (by timing out). +test('T25280', [unless(opsys('linux'),skip),req_process,js_skip, + expect_broken_for(27547, nonmoving_threaded_ways)], + compile_and_run, ['']) # N.B. This will likely issue a warning on stderr but we merely care that the # program doesn't crash. ===================================== testsuite/timeout/timeout.py ===================================== @@ -27,6 +27,19 @@ try: else: raise e + def killStragglers(pid): + # A test can leave descendants that outlive its main process (e.g. a + # deadlocked forkProcess child, #27547). They hold the inherited + # stdout/stderr pipes open and would hang the testsuite driver, so + # kill the whole process group. + try: + os.killpg(pid, signal.SIGKILL) + except OSError as e: + # ESRCH: group already gone. EPERM: macOS quirk — signalling a + # group whose leader is a reaped zombie. + if e.errno not in (errno.ESRCH, errno.EPERM): + raise e + pid = os.fork() if pid == 0: # child @@ -40,6 +53,9 @@ try: old = signal.signal(signal.SIGALRM, handler) signal.alarm(secs) (pid2, res) = os.waitpid(pid, 0) + # The handler signals pid, so it must not run once pid is reaped. + signal.alarm(0) + killStragglers(pid) if (os.WIFEXITED(res)): sys.exit(os.WEXITSTATUS(res)) elif os.WIFSIGNALED(res): View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/49ef4cd7aafb781988f952e9f8ea62… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/49ef4cd7aafb781988f952e9f8ea62… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] EPA: Remove al_trailing from AnnList
by Marge Bot (＠marge-bot) 16 Aug '26

16 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 3915e982 by Alan Zimmerman at 2026-08-16T04:37:58-04:00 EPA: Remove al_trailing from AnnList It was not being used - - - - - 19 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.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/T15279.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20846.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 Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -1796,10 +1796,10 @@ cvars1 :: { [RecordPatSynField GhcPs] } where_decls :: { LocatedA (OrdList (LHsDecl GhcPs), EpToken "where", AnnList) } : 'where' '{' decls '}' {% amsA' (sLL $1 $> (thdOf3 $ unLoc $3, epTok $1, - AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3) [])) } + AnnList (Just (fstOf3 $ unLoc $3)) (ListBraces (epTok $2) (epTok $4)) (sndOf3 $ unLoc $3))) } | 'where' vocurly decls close {% amsA' (sLL $1 $3 (thdOf3 $ unLoc $3, epTok $1, - AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3) [])) } + AnnList (Just (fstOf3 $ unLoc $3)) ListNone (sndOf3 $ unLoc $3))) } pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype @@ -1935,9 +1935,9 @@ decls :: { Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs)) } | {- empty -} { noLoc (noAnn, [],nilOL) } decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } - : '{' decls '}' { sLL $1 $> (AnnList (Just (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) [] + : '{' decls '}' { sLL $1 $> (AnnList (Just (fstOf3 $ unLoc $2)) (ListBraces (epTok $1) (epTok $3)) (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } - | vocurly decls close { sL1 $2 (AnnList (Just (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2) [] + | vocurly decls close { sL1 $2 (AnnList (Just (fstOf3 $ unLoc $2)) ListNone (sndOf3 $ unLoc $2) ,sL1 $2 $ thdOf3 $ unLoc $2) } -- Binding groups other than those of class and instance declarations @@ -1945,16 +1945,16 @@ decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } binds :: { Located (HsLocalBinds GhcPs) } -- May have implicit parameters -- No type declarations - : decllist {% do { let { (AnnList anc p s t, decls) = unLoc $1 } + : decllist {% do { let { (AnnList anc p s, decls) = unLoc $1 } ; val_binds <- cvBindGroup (unLoc $ decls) ; !cs <- getCommentsFor (gl $1) - ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList anc p s t) cs, NoEpTok) val_binds)} } + ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (AnnList anc p s) cs, NoEpTok) val_binds)} } | '{' dbinds '}' {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (ListBraces (epTok $1) (epTok $3)) [] []) cs, NoEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (ListBraces (epTok $1) (epTok $3)) []) cs, NoEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } | vocurly dbinds close {% acs (gl $2) (\loc cs -> (L loc - $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) ListNone [] []) cs, NoEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } + $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) ListNone []) cs, NoEpTok) (IPBinds noExtField (reverse $ unLoc $2)))) } wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) } @@ -3282,7 +3282,7 @@ aexp2 :: { ECP } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromCmd $ - amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) [] []) $2 Prefix + amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) []) $2 Prefix (reverse $3)) } projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) } @@ -3414,9 +3414,9 @@ tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] } -- Never empty. list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b) } : texp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> - mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] []) } + mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } | lexps { \loc (ao,ac) -> $1 >>= \ $1 -> - mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] []) } + mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) } | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok $2) (EpTok ac)) Nothing (From $1)) >>= ecpFromExp' } @@ -3440,7 +3440,7 @@ list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV ( { \loc (ao,ac) -> checkMonadComp >>= \ ctxt -> unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (epTok $2) - ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] [], noAnn)) + ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [], noAnn)) >>= ecpFromExp' } } lexps :: { forall b. DisambECP b => PV [LocatedA b] } @@ -3546,11 +3546,11 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } altslist(PATS) :: { forall b. DisambECP b => PV (LocatedA ([LMatch GhcPs (LocatedA b)], AnnList)) } : '{' alts(PATS) '}' { $2 >>= \ $2 -> amsA' (sLL $1 $> (reverse (snd $ unLoc $2), - (AnnList (Just $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2) []))) } + (AnnList (Just $ glR $2) (ListBraces (epTok $1) (epTok $3)) (fst $ unLoc $2)))) } | vocurly alts(PATS) close { $2 >>= \ $2 -> amsA' (L (getLoc $2) (reverse (snd $ unLoc $2), - (AnnList (Just $ glR $2) ListNone (fst $ unLoc $2) []))) } - | '{' '}' { amsA' (sLL $1 $> ([], (AnnList Nothing (ListBraces (epTok $1) (epTok $2)) [] []))) } + (AnnList (Just $ glR $2) ListNone (fst $ unLoc $2)))) } + | '{' '}' { amsA' (sLL $1 $> ([], (AnnList Nothing (ListBraces (epTok $1) (epTok $2)) []))) } | vocurly close { return $ noLocA ([], noAnn) } alts(PATS) :: { forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)])) } @@ -4727,7 +4727,7 @@ commentsPA la@(L l a) = do 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) + = (AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis, rec) listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation listAsAnchorM [] = Nothing ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -43,7 +43,7 @@ module GHC.Parser.Annotation ( -- ** Trailing annotations in lists TrailingAnn(..), ta_location, - addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN, + addTrailingAnnToA, addTrailingCommaToN, addTrailingAnnToBF, noTrailingN, @@ -529,10 +529,7 @@ data AnnList = AnnList { al_anchor :: !(Maybe EpaLocation), -- ^ start point of a list having layout al_brackets :: !AnnListBrackets, - al_semis :: [EpToken ";"], -- decls - al_trailing :: ![TrailingAnn] -- ^ items appearing after the - -- list, such as '=>' for a - -- context + al_semis :: [EpToken ";"] -- decls } deriving (Data,Eq) data AnnListBrackets @@ -672,16 +669,6 @@ data AnnPragSCC -- --------------------------------------------------------------------- --- | Helper function used in the parser to add a 'TrailingAnn' items --- to an existing annotation. -addTrailingAnnToL :: TrailingAnn -> EpAnnComments - -> EpAnn AnnList -> EpAnn AnnList -addTrailingAnnToL t cs n = n { anns = addTrailing (anns n) - , comments = comments n <> cs } - where - -- See Note [list append in addTrailing*] - addTrailing n = n { al_trailing = al_trailing n ++ [t]} - addTrailingAnnToBF :: TrailingAnn -> EpAnnComments -> EpAnn AnnBooleanFormula -> EpAnn AnnBooleanFormula addTrailingAnnToBF t cs n = n { anns = addTrailing (anns n) @@ -714,7 +701,7 @@ noTrailingN s = s { anns = (anns s) { nann_trailing = [] } } {- Note [list append in addTrailing*] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN +The addTrailingAnnToA and addTrailingCommaToN functions are used to add a separator for an item when it occurs in a list. So they are used to capture a comma, vbar, semicolon and similar. @@ -1047,7 +1034,7 @@ instance NoAnn AnnBooleanFormula where noAnn = AnnBooleanFormula noAnn noAnn [] instance NoAnn AnnList where - noAnn = AnnList Nothing ListNone noAnn [] + noAnn = AnnList Nothing ListNone noAnn instance NoAnn NameAnn where noAnn = NameAnnTrailing [] @@ -1141,8 +1128,8 @@ instance Outputable NameAnn where = text "NameAnnTrailing" <+> ppr t instance Outputable AnnList where - ppr (AnnList anc p s t) - = text "AnnList" <+> ppr anc <+> ppr p <+> ppr s <+> ppr t + ppr (AnnList l p s) + = text "AnnList" <+> ppr l <+> ppr p <+> ppr s instance Outputable AnnListBrackets where ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -437,7 +437,7 @@ mkRoleAnnotDecl loc tycon roles anns 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) + = 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 @@ -1963,7 +1963,7 @@ instance DisambECP (HsCmd GhcPs) where return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) 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) (ListBraces ob cb) semis [], tok_loc) stmts) + 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 @@ -2062,7 +2062,7 @@ instance DisambECP (HsExpr GhcPs) where return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) 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) (ListBraces ob cb) semis [], 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) ===================================== testsuite/tests/ghc-api/exactprint/T22919.stderr ===================================== @@ -71,7 +71,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr ===================================== @@ -83,7 +83,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/module/mod185.stderr ===================================== @@ -95,7 +95,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -2124,7 +2124,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -91,7 +91,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -214,7 +213,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -294,7 +292,6 @@ (ListBraces (NoEpTok) (NoEpTok)) - [] []) (EpaSpan { DumpParsedAstComments.hs:14:7-8 })) (DoExpr @@ -364,7 +361,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -32,7 +32,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -259,7 +259,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -333,7 +332,6 @@ (ListBraces (NoEpTok) (NoEpTok)) - [] []) (EpaSpan { DumpSemis.hs:10:7-8 })) (DoExpr @@ -373,8 +371,7 @@ ,(EpTok (EpaSpan { DumpSemis.hs:11:10 })) ,(EpTok - (EpaSpan { DumpSemis.hs:11:11 }))] - []) + (EpaSpan { DumpSemis.hs:11:11 }))]) (EpaSpan { DumpSemis.hs:11:3-4 })) (DoExpr (Nothing)) @@ -554,7 +551,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -631,8 +627,7 @@ [(EpTok (EpaSpan { DumpSemis.hs:16:5 })) ,(EpTok - (EpaSpan { DumpSemis.hs:16:8 }))] - []) + (EpaSpan { DumpSemis.hs:16:8 }))]) (EpaSpan { DumpSemis.hs:15:7-8 })) (DoExpr (Nothing)) @@ -806,7 +801,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -883,8 +877,7 @@ [(EpTok (EpaSpan { DumpSemis.hs:22:12 })) ,(EpTok - (EpaSpan { DumpSemis.hs:22:13 }))] - []) + (EpaSpan { DumpSemis.hs:22:13 }))]) (EpaSpan { DumpSemis.hs:22:7-8 })) (DoExpr (Nothing)) @@ -1015,7 +1008,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1120,7 +1112,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1227,7 +1218,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1718,7 +1708,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1844,7 +1833,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1935,8 +1923,7 @@ ,(EpTok (EpaSpan { DumpSemis.hs:34:17 })) ,(EpTok - (EpaSpan { DumpSemis.hs:34:18 }))] - []) + (EpaSpan { DumpSemis.hs:34:18 }))]) (EpaComments [])) (NoEpTok)) @@ -1971,7 +1958,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -2084,7 +2070,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -2209,7 +2194,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -2328,8 +2312,7 @@ ,(EpTok (EpaSpan { DumpSemis.hs:38:7 })) ,(EpTok - (EpaSpan { DumpSemis.hs:38:8 }))] - [])) + (EpaSpan { DumpSemis.hs:38:8 }))])) (L (EpAnn (EpaSpan { DumpSemis.hs:(38,4)-(44,4) }) ===================================== testsuite/tests/parser/should_compile/KindSigs.stderr ===================================== @@ -964,7 +964,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1664,7 +1663,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T15279.stderr ===================================== @@ -154,7 +154,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20718.stderr ===================================== @@ -105,7 +105,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/parser/should_compile/T20846.stderr ===================================== @@ -95,7 +95,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -71,7 +71,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -163,7 +162,6 @@ (Just (EpaSpan { Test20297.hs:7:3-7 })) (ListNone) - [] []) (EpaComments [])) @@ -203,7 +201,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -289,7 +286,6 @@ (Just (EpaSpan { Test20297.hs:11:9-26 })) (ListNone) - [] []) (EpaComments [(L @@ -327,7 +323,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -401,7 +396,6 @@ (ListBraces (NoEpTok) (NoEpTok)) - [] []) (EpaSpan { Test20297.hs:11:19-20 })) (DoExpr @@ -517,7 +511,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -603,7 +596,6 @@ (Just (EpaSpan { Test20297.ppr.hs:5:3-7 })) (ListNone) - [] []) (EpaComments [])) @@ -637,7 +629,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -723,7 +714,6 @@ (Just (EpaSpan { Test20297.ppr.hs:9:7-24 })) (ListNone) - [] []) (EpaComments [])) @@ -755,7 +745,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -829,7 +818,6 @@ (ListBraces (NoEpTok) (NoEpTok)) - [] []) (EpaSpan { Test20297.ppr.hs:9:17-18 })) (DoExpr ===================================== testsuite/tests/printer/Test24533.stdout ===================================== @@ -521,7 +521,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn @@ -1093,7 +1092,6 @@ (AnnList (Nothing) (ListNone) - [] [])) (L (EpAnn ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -281,8 +281,8 @@ instance HasTrailing EpAnnSumPat where setTrailing a _ = a instance HasTrailing AnnList where - trailing a = al_trailing a - setTrailing a ts = a { al_trailing = ts } + trailing _ = [] + setTrailing a _ = a instance HasTrailing [TrailingAnn] where trailing a = a ===================================== utils/check-exact/Main.hs ===================================== @@ -524,8 +524,8 @@ changeLocalDecls libdir (L l p) = do let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) - let (EpAnn anc (AnnList (Just _) a b dd) cs) = van - let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b dd) cs) + let (EpAnn anc (AnnList (Just _) a b) cs) = van + let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b) cs) let binds' = (HsValBinds (van',w) (ValBinds noExtField (VbSig sig':VbBind decl':VbSig o':oldBinds))) return (L lm (Match an mln pats (GRHSs emptyComments rhs binds'))) @@ -552,7 +552,6 @@ changeLocalDecls2 libdir (L l p) = do let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 4) []) let an = (EpAnn anc (AnnList (Just anc2) ListNone - [] []) emptyComments, EpTok (EpaDelta noSrcSpan (SameLine 0) [])) let decls = [VbSig sig', VbBind decl'] ===================================== utils/check-exact/Transform.hs ===================================== @@ -1096,7 +1096,7 @@ oldWhereAnnotation (EpAnn anc an cs, _w) ww _oldSpan = an' -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, -- change the AnnList anchor to have the correct DP too where - (AnnList ancl p s t) = an + (AnnList ancl p s) = an w = case ww of WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) WithoutWhere -> NoEpTok @@ -1105,7 +1105,7 @@ oldWhereAnnotation (EpAnn anc an cs, _w) ww _oldSpan = an' WithWhere -> (anc, ancl) WithoutWhere -> (anc, ancl) an' = (EpAnn anc' - (AnnList ancl' p s t) + (AnnList ancl' p s) cs, w) newWhereAnnotation :: WithWhere -> (EpAnn AnnList, EpToken "where") @@ -1117,7 +1117,7 @@ newWhereAnnotation ww = (an, w) WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) WithoutWhere -> NoEpTok an = EpAnn anc - (AnnList (Just anc2) ListNone [] []) + (AnnList (Just anc2) ListNone []) emptyComments -- --------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3915e9827adebe83b7367a8a1cf90c5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3915e9827adebe83b7367a8a1cf90c5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0