- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/sjakobi/T27602] 2 commits: testsuite: Fold Baseline into CommitMetric
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27602 at Glasgow Haskell Compiler / GHC Commits: 6155fe6b by Simon Jakobi at 2026-08-17T22:51:46+02:00 testsuite: Fold Baseline into CommitMetric A Baseline was just a CommitMetric plus the commit it came from, built by copying fields across. Since get_commit_metric already knows that commit, record it on CommitMetric itself and drop Baseline. This also collapses both branches of find_baseline into plain returns. Assisted-by: Claude Fable 5 - - - - - b6b01ca0 by Simon Jakobi at 2026-08-17T22:51:46+02:00 ci: Clarify comment on pushing perf notes after failures Context: #27602 Assisted-by: Claude Fable 5 - - - - - 3 changed files: - .gitlab/ci.sh - testsuite/driver/perf_notes.py - testsuite/driver/testglobals.py 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,17 +84,12 @@ PerfStat = NamedTuple('PerfStat', [('test_env', TestEnv), ('value', float)]) # A test's metric recovered from a commit's git note: the raw sample values -# recorded there, and a PerfStat whose value is their mean. +# recorded there, and a PerfStat whose value is their mean. Serves as the +# baseline when comparing a test run against an earlier commit. class CommitMetric(NamedTuple): - perfStat: PerfStat - samples: List[float] - -# A baseline recovered form stored metrics. -class Baseline(NamedTuple): perfStat: PerfStat commit: GitHash - # The raw samples the baseline value was averaged over. - samples: List[float] = [] + samples: List[float] # The type of exceptions which are thrown when computing the current stat value # fails. @@ -486,7 +481,7 @@ _commit_metric_cache: Dict[Tuple[NoteNamespace, GitHash], # instead when looking for ci results) # metric: str - test metric # way: str - test way -# returns: the Baseline or None if no metric was found within +# returns: the baseline CommitMetric or None if no metric was found within # BaselineSearchDepth commits and since the last expected change # (ignoring any expected change in the given commit). def baseline_metric(commit: GitHash, @@ -495,7 +490,7 @@ def baseline_metric(commit: GitHash, metric: MetricName, way: WayName, baseline_ref: Optional[GitRef] - ) -> Optional[Baseline]: + ) -> Optional[CommitMetric]: # For performance reasons (in order to avoid calling commit_hash), we assert # commit is already a commit hash. assert is_commit_hash(commit) @@ -511,22 +506,16 @@ def baseline_metric(commit: GitHash, # Searches through previous commits trying local then ci for each commit in. def find_baseline(namespace: NoteNamespace, test_env: TestEnv - ) -> Optional[Baseline]: + ) -> Optional[CommitMetric]: 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.perfStat, baseline_commit, - current_metric.samples) - else: - return None + return get_commit_metric(namespace, baseline_commit, test_env, name, metric, way) for depth, current_commit in list(enumerate(commit_hashes)): if current_commit == commit: continue # 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.perfStat, current_commit, - current_metric.samples) + return current_metric # Stop if there is an expected change at this commit. In that case # metrics on ancestor commits will not be a valid baseline. @@ -538,7 +527,7 @@ def baseline_metric(commit: GitHash, # Test environment to use when comparing against CI namespace ci_test_env = best_fit_ci_test_env() - baseline = find_baseline(LocalNamespace, test_env) # type: Optional[Baseline] + baseline = find_baseline(LocalNamespace, test_env) # type: Optional[CommitMetric] if baseline is None and ci_test_env is not None: baseline = find_baseline(CiNamespace, ci_test_env) @@ -608,6 +597,7 @@ def get_commit_metric(gitNoteRef, currentCacheKey[3], currentCacheKey[2], sum(currentValues) / len(currentValues)), + commit, currentValues) # Save metrics to the cache. @@ -621,7 +611,7 @@ def format_samples(samples: List[float]) -> str: return ', '.join(format_sample(s) for s in samples) def check_stats_change(actual: PerfStat, - baseline: Baseline, + baseline: CommitMetric, acceptance_window: MetricAcceptanceWindow, allowed_perf_changes: Dict[TestName, List[AllowedPerfChange]] = {}, force_print = False @@ -631,8 +621,8 @@ def check_stats_change(actual: PerfStat, Parameters: actual: the PerfStat with actual value - baseline: the expected Baseline value (this should generally be derived - from baseline_metric()) + baseline: the CommitMetric to compare against (this should generally be + derived from baseline_metric()) acceptance_window: allowed deviation of the actual value from the expected value. allowed_perf_changes: allowed changes in stats. This is a dictionary as ===================================== testsuite/driver/testglobals.py ===================================== @@ -4,7 +4,7 @@ from my_typing import * from pathlib import Path -from perf_notes import MetricChange, PerfStat, Baseline, GitRef +from perf_notes import MetricChange, PerfStat, CommitMetric, GitRef from datetime import datetime # ----------------------------------------------------------------------------- @@ -312,7 +312,7 @@ class TestResult: PerfMetric = NamedTuple('PerfMetric', [('change', MetricChange), ('stat', PerfStat), - ('baseline', Optional[Baseline]) ]) + ('baseline', Optional[CommitMetric]) ]) class TestRun: def __init__(self) -> None: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/311048aa5dc176fb36dc6eb1ed0a90… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/311048aa5dc176fb36dc6eb1ed0a90… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/az/epa-tidy-locatedxxx-18
by Alan Zimmerman (＠alanz) 17 Aug '26

17 Aug '26

Alan Zimmerman pushed new branch wip/az/epa-tidy-locatedxxx-18 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/az/epa-tidy-locatedxxx-18 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/T27368-cbe-compress] Cmm: lint that call continuations are reachable
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27368-cbe-compress at Glasgow Haskell Compiler / GHC Commits: cbe671f4 by Simon Jakobi at 2026-08-17T19:52:52+02:00 Cmm: lint that call continuations are reachable The breakage behind #27368 was invisible to -dcmm-lint: the common block eliminator never deletes the blocks it eliminates, they merely become unreachable, so the stranded continuation label still named a block in the map and the existing "Branch to nonexistent id" check passed at every stage. The panic only surfaced four passes later, in setInfoTableStackMap. Check the violated invariant directly: a call continuation must be reachable even when the call itself sits in unreachable code. See Note [unreachable blocks] in GHC.Cmm.Pipeline. Without the preceding fix, this check turns the #27368 panic into a lint error located at "Post common block elimination". Assisted-by: Claude Fable 5 - - - - - 2 changed files: - compiler/GHC/Cmm/Lint.hs - compiler/GHC/Cmm/Pipeline.hs Changes: ===================================== compiler/GHC/Cmm/Lint.hs ===================================== @@ -68,18 +68,19 @@ lintCmmGraph g = do let blocks = toBlockList g labels = setFromList (map entryLabel blocks) - cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) blocks + reachable = setFromList (map entryLabel (revPostorder g)) + cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels reachable) blocks -- cmmLiveness throws an error if there are registers -- live on entry to the graph (i.e. undefined -- variables) -lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint () -lintCmmBlock labels block +lintCmmBlock :: LabelSet -> LabelSet -> CmmBlock -> CmmLint () +lintCmmBlock labels reachable block = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do let (_, middle, last) = blockSplit block mapM_ lintCmmMiddle (blockToList middle) - lintCmmLast labels last + lintCmmLast labels reachable last -- ----------------------------------------------------------------------------- -- lintCmmExpr @@ -188,8 +189,8 @@ lintCmmMiddle node = case node of lintTarget arg_tys target -lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint () -lintCmmLast labels node = case node of +lintCmmLast :: LabelSet -> LabelSet -> CmmNode O C -> CmmLint () +lintCmmLast labels reachable node = case node of CmmBranch id -> checkTarget id CmmCondBranch e t f _ -> do @@ -208,7 +209,7 @@ lintCmmLast labels node = case node of CmmCall { cml_target = target, cml_cont = cont } -> do _ <- lintCmmExpr target - maybe (return ()) checkTarget cont + maybe (return ()) checkCont cont CmmForeignCall tgt _ args succ _ _ _ -> do let lintArg expr = do @@ -222,12 +223,22 @@ lintCmmLast labels node = case node of lintCmmExpr expr arg_tys <- mapM lintArg args lintTarget arg_tys tgt - checkTarget succ + checkCont succ where checkTarget id | setMember id labels = return () | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) + -- A call continuation must be reachable even when the call itself is + -- in an unreachable block: callProcPoints collects continuations from + -- the whole block map, but only reachable blocks get stack maps + -- (#27368). See Note [unreachable blocks] in GHC.Cmm.Pipeline. + checkCont id = do + checkTarget id + unless (setMember id reachable) $ + cmmLintErr (text "Call continuation" <+> ppr id + <+> text "is not reachable") + lintTarget :: [CmmType] -> ForeignTarget -> CmmLint () lintTarget _arg_tys (ForeignTarget e _) = do mayNotMentionCallerSavedRegs (text "foreign target") e ===================================== compiler/GHC/Cmm/Pipeline.hs ===================================== @@ -368,6 +368,9 @@ but no stack map, and setInfoTableStackMap would panic (#27368). The common block eliminator therefore ensures that the labels in its unreachable leftovers coincide with labels of reachable code, see Note [Resolving the CBE substitution] in GHC.Cmm.CommonBlockElim. +-dcmm-lint checks the invariant: a call continuation must be +reachable even when the call itself is not (see checkCont in +GHC.Cmm.Lint). To make unreachable blocks visible in -ddump-cmm-* output, add -dppr-debug. -} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cbe671f40f376ff7a5bae61d69e9e49… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cbe671f40f376ff7a5bae61d69e9e49… 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/T27368-cbe-compress] 2 commits: Sharpen Note [Resolving the CBE substitution]
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27368-cbe-compress at Glasgow Haskell Compiler / GHC Commits: 5a1c5f69 by Simon Jakobi at 2026-08-17T19:18:55+02:00 Sharpen Note [Resolving the CBE substitution] The Note claimed that CBE's input contains no unreachable blocks, but the control-flow optimiser can leave unreachable goto-only blocks behind (see the comment at incPreds/decPreds in GHC.Cmm.ContFlowOpt). Scope the reachability claim to the blocks the resolved substitution maps to, which is what the argument actually needs. Assisted-by: Claude Fable 5 - - - - - c61c4b5d by Simon Jakobi at 2026-08-17T19:29:24+02:00 Cmm: rewrite Note [unreachable blocks] The Note mentioned only the control-flow optimiser and framed unreachable blocks as a mere matter of code size. In fact common block elimination leaves them behind too, and #27368 showed how a pass can go wrong when they leak into the generated code. State the actual invariant: only removeUnreachableBlocksProc guarantees their removal, so every earlier pass must tolerate them. Also: * Turn elimCommonBlocks's intro comment into a haddock and document its unreachable-block behaviour there. * Drop the stale claim that ContFlowOpt had already removed unreachable blocks -- shortcutting creates new ones. Adapted from the doc changes in !16169. Assisted-by: Claude Fable 5 - - - - - 2 changed files: - compiler/GHC/Cmm/CommonBlockElim.hs - compiler/GHC/Cmm/Pipeline.hs Changes: ===================================== compiler/GHC/Cmm/CommonBlockElim.hs ===================================== @@ -30,34 +30,6 @@ import Control.Arrow (first, second) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE --- ----------------------------------------------------------------------------- --- Eliminate common blocks - --- If two blocks are identical except for the label on the first node, --- then we can eliminate one of the blocks. To ensure that the semantics --- of the program are preserved, we have to rewrite each predecessor of the --- eliminated block to proceed with the block we keep. - --- The algorithm iterates over the blocks in the graph, --- checking whether it has seen another block that is equal modulo labels. --- If so, then it adds an entry in a map indicating that the new block --- is made redundant by the old block. --- Otherwise, it is added to the useful blocks. - --- To avoid comparing every block with every other block repeatedly, we group --- them by --- * a hash of the block, ignoring labels (explained below) --- * the list of outgoing labels --- The hash is invariant under relabeling, so we only ever compare within --- the same group of blocks. --- --- The list of outgoing labels is updated as we merge blocks (that is why they --- are not included in the hash, which we want to calculate only once). --- --- All in all, two blocks should never be compared if they have different --- hashes, and at most once otherwise. Previously, we were slower, and people --- rightfully complained: #10397 - {- Note [Resolving the CBE substitution] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The substitution built by `iterate` can contain chains: the winner of a @@ -79,10 +51,13 @@ produced no stack map for it, and setInfoTableStackMap panicked. With the substitution resolved, every edge -- including those in the unreachable losing copies -- points at a surviving block, and every -surviving block is reachable: the input graph contains no unreachable -blocks (the control-flow optimiser runs first and drops them), and -merging only diverts paths from losers to their body-equal winners. -In particular the continuation of a call in a losing copy is also the +block the resolved substitution maps to is reachable: merging diverts +each loser's predecessors to its winner, so a winner inherits its +losers' reachability. (The input graph is not entirely free of +unreachable blocks -- the control-flow optimiser that runs first can +leave unreachable goto-only blocks behind -- but such blocks contain +no calls, and if one wins a merge it thereby becomes reachable.) In +particular the continuation of a call in a losing copy is also the continuation of its reachable winner, so stack layout has a stack map for it. @@ -90,17 +65,46 @@ Resolving also improves copyTicks: each loser's ticks are copied into its final representative instead of into a dead intermediate block. -} --- TODO: Use optimization fuel +-- | Merge identical blocks +-- +-- If two blocks are identical except for the label on the first node, +-- then we can eliminate one of the blocks. To ensure that the semantics +-- of the program are preserved, we have to rewrite each predecessor of the +-- eliminated block to proceed with the block we keep. +-- +-- Unreachable blocks may occur both in the input and in the output: +-- we process whatever the block map contains, and a merge leaves the +-- losing copy behind, unreachable. See Note [unreachable blocks] in +-- GHC.Cmm.Pipeline. +-- +-- The algorithm iterates over the blocks in the graph, +-- checking whether it has seen another block that is equal modulo labels. +-- If so, then it adds an entry in a map indicating that the new block +-- is made redundant by the old block. +-- Otherwise, it is added to the useful blocks. +-- +-- To avoid comparing every block with every other block repeatedly, we group +-- them by +-- * a hash of the block, ignoring labels (explained below) +-- * the list of outgoing labels +-- The hash is invariant under relabeling, so we only ever compare within +-- the same group of blocks. +-- +-- The list of outgoing labels is updated as we merge blocks (that is why they +-- are not included in the hash, which we want to calculate only once). +-- +-- All in all, two blocks should never be compared if they have different +-- hashes, and at most once otherwise. Previously, we were slower, and people +-- rightfully complained: #10397 elimCommonBlocks :: CmmGraph -> CmmGraph +-- TODO: Use optimization fuel elimCommonBlocks g = replaceLabels env' $ copyTicks env' g where -- See Note [Resolving the CBE substitution] env' = mapMap (lookupBid env) env env = iterate mapEmpty blocks_with_key - -- The order of blocks doesn't matter here. While we could use - -- revPostorder which drops unreachable blocks this is done in - -- ContFlowOpt already which runs before this pass. So we use - -- toBlockList since it is faster. + -- Block order is irrelevant here, so we use toBlockList, which + -- is cheaper than revPostorder. groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]] blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups] ===================================== compiler/GHC/Cmm/Pipeline.hs ===================================== @@ -353,10 +353,21 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. {- Note [unreachable blocks] ~~~~~~~~~~~~~~~~~~~~~~~~~ -The control-flow optimiser sometimes leaves unreachable blocks behind -containing junk code. These aren't necessarily a problem, but -removing them is good because it might save time in the native code -generator later. +Both the control-flow optimiser and the common block eliminator leave +unreachable blocks behind. Several of the later passes drop them +incidentally, by rebuilding the graph from a reachability traversal, +but only removeUnreachableBlocksProc at the end of the pipeline +guarantees a graph without them. Every pass in between must +therefore tolerate unreachable blocks in its input, and must not let +them affect the code generated for the reachable part. + +The latter requirement is easy to violate: callProcPoints collects +call continuations from the whole block map, so a label mentioned +only in unreachable code would become a proc point with an info table +but no stack map, and setInfoTableStackMap would panic (#27368). +The common block eliminator therefore ensures that the labels in its +unreachable leftovers coincide with labels of reachable code, see +Note [Resolving the CBE substitution] in GHC.Cmm.CommonBlockElim. To make unreachable blocks visible in -ddump-cmm-* output, add -dppr-debug. -} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9cb1e12cfaee716f77c74e3e5bc81… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a9cb1e12cfaee716f77c74e3e5bc81… 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/T27368-cbe-compress] Cmm: resolve substitution chains in common block elimination
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27368-cbe-compress at Glasgow Haskell Compiler / GHC Commits: a9cb1e12 by Simon Jakobi at 2026-08-17T18:43:13+02:00 Cmm: resolve substitution chains in common block elimination The substitution built by elimCommonBlocks can map a label to another eliminated label, but replaceLabels looks up each label only once. An edge in a losing copy of a merged block could thus be rewritten to an eliminated label. When that label was a call continuation, callProcPoints turned it into a proc point, attachContInfoTables gave it an info table, but stack layout produced no stack map for it, and setInfoTableStackMap panicked. Resolve the substitution before rewriting, so that every label in the graph is mapped directly to its final representative. See Note [Resolving the CBE substitution] in GHC.Cmm.CommonBlockElim. Also: copyTicks now copies each loser's ticks into its final representative instead of into a dead intermediate block. The regression test distills the code shape that triggered the panic when compiling GHC.CmmToAsm.Dwarf.Types with -O2 on top of !16168. Fixes #27368 Assisted-by: Claude Fable 5 - - - - - 4 changed files: - + changelog.d/27368 - compiler/GHC/Cmm/CommonBlockElim.hs - + testsuite/tests/codeGen/should_compile/T27368.hs - testsuite/tests/codeGen/should_compile/all.T Changes: ===================================== changelog.d/27368 ===================================== @@ -0,0 +1,4 @@ +section: compiler +synopsis: Fix a ``setInfoTableStackMap`` panic caused by calls in unreachable Cmm blocks. +issues: #27368 +mrs: !16543 ===================================== compiler/GHC/Cmm/CommonBlockElim.hs ===================================== @@ -58,10 +58,44 @@ import qualified Data.List.NonEmpty as NE -- hashes, and at most once otherwise. Previously, we were slower, and people -- rightfully complained: #10397 +{- Note [Resolving the CBE substitution] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The substitution built by `iterate` can contain chains: the winner of a +merge may itself lose a later merge, giving k1 :-> k2 and k2 :-> k3. +`lookupBid` resolves such chains transitively, but `replaceLabels` +looks up each label only once. So before rewriting the graph we +resolve the substitution, mapping every eliminated label directly to +its final representative. + +This matters because the losing blocks of the merges stay in the block +map, unreachable (removing them here would take an extra reachability +pass). With an unresolved +substitution, an edge in a losing block could be rewritten to k2 -- +itself an eliminated label with no live twin. In #27368 such a stranded +label was a call continuation: callProcPoints folds over the whole +block map, so the label became a proc point, attachContInfoTables gave +it an info table, but stack layout (which walks reachable blocks only) +produced no stack map for it, and setInfoTableStackMap panicked. + +With the substitution resolved, every edge -- including those in the +unreachable losing copies -- points at a surviving block, and every +surviving block is reachable: the input graph contains no unreachable +blocks (the control-flow optimiser runs first and drops them), and +merging only diverts paths from losers to their body-equal winners. +In particular the continuation of a call in a losing copy is also the +continuation of its reachable winner, so stack layout has a stack map +for it. + +Resolving also improves copyTicks: each loser's ticks are copied into +its final representative instead of into a dead intermediate block. +-} + -- TODO: Use optimization fuel elimCommonBlocks :: CmmGraph -> CmmGraph -elimCommonBlocks g = replaceLabels env $ copyTicks env g +elimCommonBlocks g = replaceLabels env' $ copyTicks env' g where + -- See Note [Resolving the CBE substitution] + env' = mapMap (lookupBid env) env env = iterate mapEmpty blocks_with_key -- The order of blocks doesn't matter here. While we could use -- revPostorder which drops unreachable blocks this is done in ===================================== testsuite/tests/codeGen/should_compile/T27368.hs ===================================== @@ -0,0 +1,20 @@ +-- Regression test for #27368: setInfoTableStackMap panicked because a +-- call in an unreachable block returned to an eliminated label. The two +-- branches below have identical suffixes from the inner case onwards, +-- so common block elimination merges the duplicated call blocks in +-- several rounds, building a substitution chain. See Note [Resolving +-- the CBE substitution] in GHC.Cmm.CommonBlockElim. +module T27368 (f) where + +{-# NOINLINE put #-} +put :: Int -> Int -> IO () +put h x = if h + x == 12345 then errorWithoutStackTrace "boom" else pure () + +data T = N | J Int | K + +f :: Int -> Bool -> T -> IO () +f h a t = do + if a + then do put h 1; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + else do put h 2; case t of { N -> pure (); J _ -> put h 3; K -> put h 4 }; put h 0; put h 0 + put h 0 ===================================== testsuite/tests/codeGen/should_compile/all.T ===================================== @@ -150,3 +150,5 @@ test('T16351', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppres test('T20298a', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298b', normal, compile, ['-O2 -dno-bignum-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) test('T20298c', normal, compile, ['-O2 -dno-builtin-rules -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) + +test('T27368', normal, compile, ['-O2']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9cb1e12cfaee716f77c74e3e5bc81e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a9cb1e12cfaee716f77c74e3e5bc81e… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T27368-cbe-compress
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed new branch wip/sjakobi/T27368-cbe-compress at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27368-cbe-compress 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] TTG: Add extension points to BooleanFormula
by Marge Bot (＠marge-bot) 17 Aug '26

17 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d8f1a2a3 by Alan Zimmerman at 2026-08-17T12:13:18-04:00 TTG: Add extension points to BooleanFormula They are currently unused, but will be used for exact print annotations next, allowing us to get rid of LocatedBF / SrcSpanAnnBF - - - - - 14 changed files: - compiler/GHC/Core/Class.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Data/BooleanFormula.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Tc/TyCl/Class.hs - compiler/Language/Haskell/Syntax/BooleanFormula.hs - compiler/Language/Haskell/Syntax/Extension.hs - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Core/Class.hs ===================================== @@ -41,6 +41,7 @@ import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Utils.Outputable +import GHC.Data.BooleanFormula () -- for BooleanFormulaDefault instance import Language.Haskell.Syntax.BooleanFormula ( BooleanFormula, mkTrue ) import qualified Data.Data as Data ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -542,10 +542,11 @@ toIfGuidance src guidance toIfaceBooleanFormula :: BF.BooleanFormula GhcRn -> IfaceBooleanFormula toIfaceBooleanFormula = go where - go (BF.Var nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm - go (BF.And bfs ) = IfAnd $ map (go . unLoc) bfs - go (BF.Or bfs ) = IfOr $ map (go . unLoc) bfs - go (BF.Parens bf) = IfParens $ (go . unLoc) bf + go (BF.Var _ nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm + go (BF.And _ bfs ) = IfAnd $ map (go . unLoc) bfs + go (BF.Or _ bfs ) = IfOr $ map (go . unLoc) bfs + go (BF.Parens _ bf) = IfParens $ (go . unLoc) bf + go (BF.XBooleanFormula _) = panic "toIfaceBooleanFormula" {- ************************************************************************ ===================================== compiler/GHC/Data/BooleanFormula.hs ===================================== @@ -27,7 +27,10 @@ import GHC.Types.SrcLoc (unLoc) import GHC.Utils.Outputable import GHC.Parser.Annotation ( SrcSpanAnnBF ) import GHC.Hs.Extension (GhcPass (..), OutputableBndrId) -import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP) +import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP, + noExtField, NoExtField, DataConCantHappen, + XBFVar, XBFAnd, XBFOr, XBFParens, + XXBooleanFormula) import Language.Haskell.Syntax.BooleanFormula @@ -37,6 +40,17 @@ import Language.Haskell.Syntax.BooleanFormula type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnBF +type instance XBFVar (GhcPass _) = NoExtField +type instance XBFAnd (GhcPass _) = NoExtField +type instance XBFOr (GhcPass _) = NoExtField +type instance XBFParens (GhcPass _) = NoExtField +type instance XXBooleanFormula (GhcPass _) = DataConCantHappen + +instance BooleanFormulaDefault (GhcPass p) where + bfAnnAnd = noExtField + bfAnnOr = noExtField + + -- if we had Functor/Traversable (LbooleanFormula p) we could use that -- as a constraint and we wouldn't need to specialize to just GhcPass p, -- but becuase LBooleanFormula is a type synonym such a constraint is @@ -49,10 +63,10 @@ bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p')) -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p') bfMap f = go where - go (Var a ) = Var $ f a - go (And bfs) = And $ map (fmap go) bfs - go (Or bfs) = Or $ map (fmap go) bfs - go (Parens bf ) = Parens $ fmap go bf + go (Var x a ) = Var x $ f a + go (And x bfs) = And x $ map (fmap go) bfs + go (Or x bfs) = Or x $ map (fmap go) bfs + go (Parens x bf ) = Parens x $ fmap go bf bfTraverse :: Applicative f => (LIdP (GhcPass p) -> f (LIdP (GhcPass p'))) @@ -60,10 +74,10 @@ bfTraverse :: Applicative f -> f (BooleanFormula (GhcPass p')) bfTraverse f = go where - go (Var a ) = Var <$> f a - go (And bfs) = And <$> traverse @[] (traverse go) bfs - go (Or bfs) = Or <$> traverse @[] (traverse go) bfs - go (Parens bf ) = Parens <$> traverse go bf + go (Var x a ) = Var x <$> f a + go (And x bfs) = And x <$> traverse @[] (traverse go) bfs + go (Or x bfs) = Or x <$> traverse @[] (traverse go) bfs + go (Parens x bf ) = Parens x <$> traverse go bf @@ -106,18 +120,18 @@ We don't show a ridiculous error message like ---------------------------------------------------------------------- isFalse :: BooleanFormula (GhcPass p) -> Bool -isFalse (Or []) = True +isFalse (Or _ []) = True isFalse _ = False isTrue :: BooleanFormula (GhcPass p) -> Bool -isTrue (And []) = True +isTrue (And _ []) = True isTrue _ = False eval :: (LIdP (GhcPass p) -> Bool) -> BooleanFormula (GhcPass p) -> Bool -eval f (Var x) = f x -eval f (And xs) = all (eval f . unLoc) xs -eval f (Or xs) = any (eval f . unLoc) xs -eval f (Parens x) = eval f (unLoc x) +eval f (Var _ x) = f x +eval f (And _ xs) = all (eval f . unLoc) xs +eval f (Or _ xs) = any (eval f . unLoc) xs +eval f (Parens _ x) = eval f (unLoc x) -- Simplify a boolean formula. -- The argument function should give the truth of the atoms, or Nothing if undecided. @@ -125,12 +139,12 @@ simplify :: forall p. Eq (LIdP (GhcPass p)) => (LIdP (GhcPass p) -> Maybe Bool) -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -simplify f (Var a) = case f a of - Nothing -> Var a +simplify f (Var x a) = case f a of + Nothing -> Var x a Just b -> mkBool b -simplify f (And xs) = mkAnd (map (fmap (simplify f)) xs) -simplify f (Or xs) = mkOr (map (fmap (simplify f)) xs) -simplify f (Parens x) = simplify f (unLoc x) +simplify f (And _ xs) = mkAnd (map (fmap (simplify f)) xs) +simplify f (Or _ xs) = mkOr (map (fmap (simplify f)) xs) +simplify f (Parens _ x) = simplify f (unLoc x) -- Test if a boolean formula is satisfied when the given values are assigned to the atoms -- if it is, returns Nothing @@ -152,11 +166,11 @@ isUnsatisfied f bf -- If the boolean formula holds, does that mean that the given atom is always true? impliesAtom :: Eq (IdP (GhcPass p)) => BooleanFormula (GhcPass p) -> LIdP (GhcPass p) -> Bool -Var x `impliesAtom` y = (unLoc x) == (unLoc y) -And xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs - -- we have all of xs, so one of them implying y is enough -Or xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs -Parens x `impliesAtom` y = unLoc x `impliesAtom` y +Var _ x `impliesAtom` y = (unLoc x) == (unLoc y) +And _ xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs + -- we have all of xs, so one of them implying y is enough +Or _ xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs +Parens _ x `impliesAtom` y = unLoc x `impliesAtom` y implies :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) @@ -164,18 +178,18 @@ implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) go :: Uniquable (IdP (GhcPass p)) => Clause (GhcPass p) -> Clause (GhcPass p) -> Bool go l@Clause{ clauseExprs = hyp:hyps } r = case hyp of - Var x | memberClauseAtoms (unLoc x) r -> True - | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r - Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r - And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r - Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' + Var _ x | memberClauseAtoms (unLoc x) r -> True + | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r + Parens _ hyp' -> go l { clauseExprs = unLoc hyp':hyps } r + And _ hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r + Or _ hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' go l r@Clause{ clauseExprs = con:cons } = case con of - Var x | memberClauseAtoms (unLoc x) l -> True - | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons } - Parens con' -> go l r { clauseExprs = unLoc con':cons } - And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' - Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } + Var _ x | memberClauseAtoms (unLoc x) l -> True + | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons } + Parens _ con' -> go l r { clauseExprs = unLoc con':cons } + And _ cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' + Or _ cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } go _ _ = False -- A small sequent calculus proof engine. @@ -201,12 +215,12 @@ pprBooleanFormula' :: (Rational -> LIdP (GhcPass p) -> SDoc) -> Rational -> BooleanFormula (GhcPass p) -> SDoc pprBooleanFormula' pprVar pprAnd pprOr = go where - go p (Var x) = pprVar p x - go p (And []) = cparen (p > 0) empty - go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) - go _ (Or []) = keyword $ text "FALSE" - go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) - go p (Parens x) = go p (unLoc x) + go p (Var _ x) = pprVar p x + go p (And _ []) = cparen (p > 0) empty + go p (And _ xs) = pprAnd p (map (go 3 . unLoc) xs) + go _ (Or _ []) = keyword $ text "FALSE" + go p (Or _ xs) = pprOr p (map (go 2 . unLoc) xs) + go p (Parens _ x) = go p (unLoc x) -- Pretty print in source syntax, "a | b | c,d,e" pprBooleanFormula :: (Rational -> LIdP (GhcPass p) -> SDoc) @@ -233,8 +247,9 @@ instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc pprBooleanFormulaNormal = go where - go (Var x) = pprPrefixOcc (unLoc x) - go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) - go (Or []) = keyword $ text "FALSE" - go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) - go (Parens x) = parens (go $ unLoc x) + go (Var _ x) = pprPrefixOcc (unLoc x) + go (And _ xs) = fsep $ punctuate comma (map (go . unLoc) xs) + go (Or _ []) = keyword $ text "FALSE" + go (Or _ xs) = fsep $ intersperse vbar (map (go . unLoc) xs) + go (Parens _ x) = parens (go $ unLoc x) + go (XBooleanFormula _) = text "XBooleanFormula" ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -2083,16 +2083,16 @@ instance ToHie PendingRnSplice where instance (HiePass p, Data (IdGhcP p)) => ToHie (GenLocated SrcSpanAnnBF (BooleanFormula (GhcPass p))) where toHie (L span form) = concatM $ makeNode form (locA span) : case form of - Var a -> + Var _ a -> [ toHie $ C Use a ] - And forms -> + And _ forms -> [ toHie forms ] - Or forms -> + Or _ forms -> [ toHie forms ] - Parens f -> + Parens _ f -> [ toHie f ] ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -103,6 +103,7 @@ import GHC.Data.FastString import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue) import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) +import Language.Haskell.Syntax.Extension (noExtField) import Language.Haskell.Syntax.Text import Control.Monad @@ -1326,10 +1327,10 @@ pprIfaceDecl ss decl@(IfaceClass { ifName = clas fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula GhcRn -- `mkUnboundName` here is fine because the Name generated is only used for pretty printing and nothing else. - fromIfaceBooleanFormula (IfVar nm ) = Var $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm - fromIfaceBooleanFormula (IfAnd bfs ) = And $ map (noLocA . fromIfaceBooleanFormula) bfs - fromIfaceBooleanFormula (IfOr bfs ) = Or $ map (noLocA . fromIfaceBooleanFormula) bfs - fromIfaceBooleanFormula (IfParens bf) = Parens $ (noLocA . fromIfaceBooleanFormula) bf + fromIfaceBooleanFormula (IfVar nm ) = Var noExtField $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm + fromIfaceBooleanFormula (IfAnd bfs ) = And noExtField $ map (noLocA . fromIfaceBooleanFormula) bfs + fromIfaceBooleanFormula (IfOr bfs ) = Or noExtField $ map (noLocA . fromIfaceBooleanFormula) bfs + fromIfaceBooleanFormula (IfParens bf) = Parens noExtField $ (noLocA . fromIfaceBooleanFormula) bf -- See Note [Suppressing binder signatures] in GHC.Iface.Type ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -883,10 +883,10 @@ tc_iface_decl _parent ignore_prags return (ATI tc mb_def) tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn) - tc_boolean_formula (IfAnd ibfs ) = BF.And . map noLocA <$> traverse tc_boolean_formula ibfs - tc_boolean_formula (IfOr ibfs ) = BF.Or . map noLocA <$> traverse tc_boolean_formula ibfs - tc_boolean_formula (IfParens ibf) = BF.Parens . noLocA <$> tc_boolean_formula ibf - tc_boolean_formula (IfVar nm ) = BF.Var . noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm) + tc_boolean_formula (IfAnd ibfs ) = BF.And NoExtField . map noLocA <$> traverse tc_boolean_formula ibfs + tc_boolean_formula (IfOr ibfs ) = BF.Or NoExtField . map noLocA <$> traverse tc_boolean_formula ibfs + tc_boolean_formula (IfParens ibf) = BF.Parens NoExtField . noLocA <$> tc_boolean_formula ibf + tc_boolean_formula (IfVar nm ) = BF.Var NoExtField . noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm) mk_sc_doc pred = text "Superclass" <+> ppr pred mk_at_doc tc = text "Associated type" <+> ppr tc ===================================== compiler/GHC/Parser.y ===================================== @@ -3821,11 +3821,11 @@ name_boolformula :: { LBooleanFormula GhcPs } : name_boolformula_and { $1 } | name_boolformula_and '|' name_boolformula {% do { h <- addTrailingVbarBF $1 (epTok $2) - ; return (sLLa $1 $> (Or [h,$3])) } } + ; return (sLLa $1 $> (Or noExtField [h,$3])) } } name_boolformula_and :: { LBooleanFormula GhcPs } : name_boolformula_and_list - { sLLa (head $1) (last $1) (And (toList $1)) } + { sLLa (head $1) (last $1) (And noExtField (toList $1)) } name_boolformula_and_list :: { NonEmpty (LBooleanFormula GhcPs) } : name_boolformula_atom { NE.singleton $1 } @@ -3834,9 +3834,9 @@ name_boolformula_and_list :: { NonEmpty (LBooleanFormula GhcPs) } ; return (h NE.<| $3) } } name_boolformula_atom :: { LBooleanFormula GhcPs } - : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens $2)) + : '(' name_boolformula ')' {% amsr (sLL $1 $> (Parens noExtField $2)) (AnnBooleanFormula (epTok $1) (epTok $3) []) } - | name_var { sL1a $1 (Var $1) } + | name_var { sL1a $1 (Var noExtField $1) } namelist :: { Located [LocatedN RdrName] } namelist : name_var { sL1 $1 [$1] } ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -345,7 +345,7 @@ tcClassMinimalDef _clas sigs op_info where -- By default require all methods without a default implementation defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLocA (mkVar (noLocA name)) + defMindef = mkAnd [ noLocA (mkVar NoExtField (noLocA name)) | (name, _, Nothing) <- op_info ] instantiateMethod :: Class -> TcId -> [TcType] -> TcType ===================================== compiler/Language/Haskell/Syntax/BooleanFormula.hs ===================================== @@ -4,59 +4,78 @@ module Language.Haskell.Syntax.BooleanFormula( BooleanFormula(..), LBooleanFormula, - mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr + mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr, + BooleanFormulaDefault(..) ) where import Prelude hiding ( init, last ) import Data.List ( nub ) -import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP) +import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP, + XBFVar, XBFAnd, XBFOr, XBFParens, + XXBooleanFormula) -- types type LBooleanFormula p = XRec p (BooleanFormula p) -data BooleanFormula p = Var (LIdP p) | And [LBooleanFormula p] | Or [LBooleanFormula p] - | Parens (LBooleanFormula p) +data BooleanFormula p + = Var (XBFVar p) (LIdP p) + | And (XBFAnd p) [LBooleanFormula p] + | Or (XBFOr p) [LBooleanFormula p] + | Parens (XBFParens p) (LBooleanFormula p) + | XBooleanFormula !(XXBooleanFormula p) + +class BooleanFormulaDefault p where + bfAnnAnd :: XBFAnd p + bfAnnOr :: XBFOr p -- instances -deriving instance (Eq (LIdP p), Eq (LBooleanFormula p)) => Eq (BooleanFormula p) +deriving instance (Eq (LIdP p), Eq (LBooleanFormula p), + Eq (XBFVar p), + Eq (XBFAnd p), + Eq (XBFOr p), + Eq (XBFParens p), + Eq (XXBooleanFormula p) + ) => Eq (BooleanFormula p) -- smart constructors -- see note [Simplification of BooleanFormulas] -mkVar :: LIdP p -> BooleanFormula p +mkVar :: XBFVar p -> LIdP p -> BooleanFormula p mkVar = Var -mkFalse, mkTrue :: BooleanFormula p -mkFalse = Or [] -mkTrue = And [] +mkFalse, mkTrue :: forall p. BooleanFormulaDefault p => BooleanFormula p +mkFalse = Or (bfAnnOr @p) [] +mkTrue = And (bfAnnAnd @p) [] -- Convert a Bool to a BooleanFormula -mkBool :: Bool -> BooleanFormula p +mkBool :: BooleanFormulaDefault p => Bool -> BooleanFormula p mkBool False = mkFalse mkBool True = mkTrue -- Make a conjunction, and try to simplify -mkAnd :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p +mkAnd :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p), BooleanFormulaDefault p) + => [LBooleanFormula p] -> BooleanFormula p mkAnd = maybe mkFalse (mkAnd' . nub . concat) . mapM fromAnd where -- See Note [Simplification of BooleanFormulas] fromAnd :: LBooleanFormula p -> Maybe [LBooleanFormula p] fromAnd bf = case unXRec @p bf of - (And xs) -> Just xs + (And _ xs) -> Just xs -- assume that xs are already simplified -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs - (Or []) -> Nothing + (Or _ []) -> Nothing -- in case of False we bail out, And [..,mkFalse,..] == mkFalse _ -> Just [bf] mkAnd' [x] = unXRec @p x - mkAnd' xs = And xs + mkAnd' xs = And (bfAnnAnd @p) xs -mkOr :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p +mkOr :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p), BooleanFormulaDefault p) + => [LBooleanFormula p] -> BooleanFormula p mkOr = maybe mkTrue (mkOr' . nub . concat) . mapM fromOr where -- See Note [Simplification of BooleanFormulas] fromOr bf = case unXRec @p bf of - (Or xs) -> Just xs - (And []) -> Nothing - _ -> Just [bf] + (Or _ xs) -> Just xs + (And _ []) -> Nothing + _ -> Just [bf] mkOr' [x] = unXRec @p x - mkOr' xs = Or xs + mkOr' xs = Or (bfAnnOr @p) xs ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -841,6 +841,14 @@ type family XXIntegralLit x type family XStringLit x type family XXStringLit x +-- ===================================================================== +-- BooleanFormula type families + +type family XBFVar p +type family XBFAnd p +type family XBFOr p +type family XBFParens p +type family XXBooleanFormula p -- ===================================================================== -- Misc ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -2722,18 +2722,18 @@ instance ExactPrint (BF.BooleanFormula GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (BF.Var x) = do + exact (BF.Var e x) = do x' <- markAnnotated x - return (BF.Var x') - exact (BF.Or ls) = do + return (BF.Var e x') + exact (BF.Or e ls) = do ls' <- mapM markAnnotated ls - return (BF.Or ls') - exact (BF.And ls) = do + return (BF.Or e ls') + exact (BF.And e ls) = do ls' <- mapM markAnnotated ls - return (BF.And ls') - exact (BF.Parens x) = do + return (BF.And e ls') + exact (BF.Parens e x) = do x' <- markAnnotated x - return (BF.Parens x') + return (BF.Parens e x') -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -998,26 +998,26 @@ ppClassDecl -- Minimal complete definition minimalBit = case [s | MinimalSig _ (L _ s) <- sigs] of -- Miminal complete definition = every shown method - And xs : _ - | sort [getName n | L _ (Var (L _ n)) <- xs] + And _ xs : _ + | sort [getName n | L _ (Var _ (L _ n)) <- xs] == sort [getName n | ClassOpSig _ _ ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method - Var (L _ n) : _ + Var _ (L _ n) : _ | [getName n] == [getName n' | ClassOpSig _ _ ns _ <- sigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing - And [] : _ -> subMinimal $ toHtml ("Nothing" :: LText) + And _ [] : _ -> subMinimal $ toHtml ("Nothing" :: LText) m : _ -> subMinimal $ ppMinimal False m _ -> noHtml - ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n - ppMinimal _ (And fs) = foldr1 (\a b -> a +++ (", " :: LText) +++ b) $ map (ppMinimal True . unLoc) fs - ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a +++ (" | " :: LText) +++ b) $ map (ppMinimal False . unLoc) fs + ppMinimal _ (Var _ (L _ n)) = ppDocName qual Prefix True n + ppMinimal _ (And _ fs) = foldr1 (\a b -> a +++ (", " :: LText) +++ b) $ map (ppMinimal True . unLoc) fs + ppMinimal p (Or _ fs) = wrap $ foldr1 (\a b -> a +++ (" | " :: LText) +++ b) $ map (ppMinimal False . unLoc) fs where wrap | p = parens | otherwise = id - ppMinimal p (Parens x) = ppMinimal p (unLoc x) + ppMinimal p (Parens _ x) = ppMinimal p (unLoc x) -- Instances instancesBit = ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -858,10 +858,10 @@ bfTraverse :: Applicative f -> f (BooleanFormula DocNameI) bfTraverse f = go where - go (Var a ) = Var <$> f a - go (And bfs) = And <$> traverse @[] (traverse go) bfs - go (Or bfs) = Or <$> traverse @[] (traverse go) bfs - go (Parens bf ) = Parens <$> traverse go bf + go (Var x a ) = Var x <$> f a + go (And x bfs) = And x <$> traverse @[] (traverse go) bfs + go (Or x bfs) = Or x <$> traverse @[] (traverse go) bfs + go (Parens x bf ) = Parens x <$> traverse go bf renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport _ modifiers lname ltype x) = do ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -1038,6 +1038,12 @@ type instance XCTyFamInstDecl DocNameI = NoExtField type instance XHsContext DocNameI = NoExtField type instance XXHsContextDetails DocNameI = DataConCantHappen +type instance XBFVar DocNameI = NoExtField +type instance XBFAnd DocNameI = NoExtField +type instance XBFOr DocNameI = NoExtField +type instance XBFParens DocNameI = NoExtField +type instance XXBooleanFormula DocNameI = DataConCantHappen + ----------------------------------------------------------------------------- -- * NFData instances for GHC types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8f1a2a3a6507d9b8a8e556e6afdeec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8f1a2a3a6507d9b8a8e556e6afdeec… 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] Simplify comparison in DFM.hs
by Marge Bot (＠marge-bot) 17 Aug '26

17 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 574c875f by Andreas Klebinger at 2026-08-17T12:12:39-04:00 Simplify comparison in DFM.hs Fixes #27669 - - - - - 5 changed files: - compiler/GHC/Data/Word64Map/Internal.hs - compiler/GHC/Data/Word64Map/Lazy.hs - compiler/GHC/Data/Word64Map/Strict.hs - compiler/GHC/Data/Word64Map/Strict/Internal.hs - compiler/GHC/Types/Unique/DFM.hs Changes: ===================================== compiler/GHC/Data/Word64Map/Internal.hs ===================================== @@ -72,6 +72,7 @@ module GHC.Data.Word64Map.Internal ( -- * Query , null , size + , sizeAtMost , compareSize , member , notMember @@ -533,6 +534,10 @@ size = go 0 go acc (Tip _ _) = 1 + acc go acc Nil = acc +-- | Check if the map is <= n in O(min(|map|,n)) +sizeAtMost :: Word64Map a -> Int -> Bool +sizeAtMost map n = compareSize map n /= GT + -- | $O(\min(n,c))$. Compare the number of entries in the map to an @Int@. -- -- @compareSize m c@ returns the same result as @compare ('size' m) c@ but is ===================================== compiler/GHC/Data/Word64Map/Lazy.hs ===================================== @@ -113,6 +113,7 @@ module GHC.Data.Word64Map.Lazy ( -- ** Size , WM.null , size + , sizeAtMost , compareSize -- * Combine ===================================== compiler/GHC/Data/Word64Map/Strict.hs ===================================== @@ -130,6 +130,7 @@ module GHC.Data.Word64Map.Strict ( -- ** Size , null , size + , sizeAtMost , compareSize -- * Combine ===================================== compiler/GHC/Data/Word64Map/Strict/Internal.hs ===================================== @@ -132,6 +132,7 @@ module GHC.Data.Word64Map.Strict.Internal ( -- ** Size , null , size + , sizeAtMost , compareSize -- * Combine @@ -324,6 +325,7 @@ import GHC.Data.Word64Map.Internal , spanAntitone , restrictKeys , size + , sizeAtMost , compareSize , split , splitLookup ===================================== compiler/GHC/Types/Unique/DFM.hs ===================================== @@ -351,8 +351,8 @@ foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a {-# INLINE foldUDFM #-} -- Specialises k and z into M.foldr on the small-map path. foldUDFM k z (UDFM m ub) - | M.compareSize m 1 /= GT = M.foldr (k . taggedFst) z m - | otherwise = fold_udfm k z m ub + | M.sizeAtMost m 1 = M.foldr (k . taggedFst) z m + | otherwise = fold_udfm k z m ub fold_udfm :: (elt -> a -> a) -> a -> M.Word64Map (TaggedVal elt) -> Int -> a {-# NOINLINE fold_udfm #-} @@ -402,8 +402,8 @@ eltsUDFM :: UniqDFM key elt -> [elt] {-# INLINE eltsUDFM #-} -- so the small case is a good producer -- This matters for T13719. eltsUDFM (UDFM m ub) - | M.compareSize m 1 /= GT = build (\c n -> M.foldr (c . taggedFst) n m) - | otherwise = elts_udfm m ub + | M.sizeAtMost m 1 = build (\c n -> M.foldr (c . taggedFst) n m) + | otherwise = elts_udfm m ub elts_udfm :: M.Word64Map (TaggedVal elt) -> Int -> [elt] {-# NOINLINE elts_udfm #-} @@ -511,7 +511,7 @@ udfmToList :: UniqDFM key elt -> [(Unique, elt)] -- traverseUSDFM in the pattern-match checker, which doesn't fuse. Inlining -- the size dispatch into it regresses T17836. udfmToList (UDFM m ub) - | M.compareSize m 1 /= GT = + | M.sizeAtMost m 1 = M.foldrWithKey (\k tv r -> (mkUniqueGrimily k, taggedFst tv) : r) [] m | usePigeonholeSort m ub = pigeonholeSort ub (\k tv -> TaggedVal (mkUniqueGrimily k, taggedFst tv) (taggedSnd tv)) m View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/574c875f0701e8cc86511cd5df63262… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/574c875f0701e8cc86511cd5df63262… 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] testsuite: Use sigkill in process009.
by Marge Bot (＠marge-bot) 17 Aug '26

17 Aug '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fed942ac by Andreas Klebinger at 2026-08-17T12:11:57-04:00 testsuite: Use sigkill in process009. SIGHUB might have been blocked by a (grand)*parent of the test. In such cases the test would fail as the python process would simply exist gracefully instead of committing to a premature end. By using SIGKILL we can rely on the signal not being blocked, fixing #27578 in the process. - - - - - 2 changed files: - testsuite/tests/process/process009.hs - testsuite/tests/process/process009.stdout Changes: ===================================== testsuite/tests/process/process009.hs ===================================== @@ -11,7 +11,7 @@ main = do let script = intercalate " " [ "exec python3 2>/dev/null" , "-c" - , "'import os; os.kill(os.getpid(), 1)'" + , "'import os; os.kill(os.getpid(), 9)'" -- SIGKILL ] (_,_,_,p) <- createProcess (shell script) waitForProcess p >>= print ===================================== testsuite/tests/process/process009.stdout ===================================== @@ -1,3 +1,3 @@ -ExitFailure (-1) -Just (ExitFailure (-1)) -Just (ExitFailure (-1)) +ExitFailure (-9) +Just (ExitFailure (-9)) +Just (ExitFailure (-9)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fed942ac50666b18232b5670752858a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fed942ac50666b18232b5670752858a… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/stack-hadrian-build-full-ci
by Simon Jakobi (＠sjakobi) 17 Aug '26

17 Aug '26

Simon Jakobi pushed new branch wip/sjakobi/stack-hadrian-build-full-ci at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/stack-hadrian-build-f… 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