Magnus pushed to branch wip/mangoiv/ghc-9.12-bp at Glasgow Haskell Compiler / GHC Commits: 9ba34598 by Brian J. Cardiff at 2026-05-20T15:17:39+02:00 configure: Accept happy-2.2 In Jan 2026 happy-2.2 was released. The most sensible change is https://github.com/haskell/happy/issues/335 which didn't trigger in a fresh build (cherry picked from commit 4f2840f2bb729ef1a6660f9f5c46906b7b838147) - - - - - 4a9baf14 by sheaf at 2026-05-20T15:28:16+02:00 Careful with ticked join points in mergeCaseAlts This commit backports the fix to GHC.Core.Utils.mergeCaseAlts that was carried out in f726fcc4fb0b59f8ad2e2fa80f1b03efdaf73c30. That is, this commit addresses the regression that was introduced by e026bdf275e287005f2c2e534d3ba034ebf11c01, which allowed mergeCaseAlts to move ticks in between a join point and one of its jumps, which results in disaster (see #26929 but also #26642, #26693). See (MC6) in Note [Merge Nested Cases] for a detailed explanation. (cherry picked from commit 08bc245be70d95801bc1138804ed1de9474fbdc0) (cherry picked from commit 974586eb5b6a924e8ce3ea8c4b2180ea9c0f3801) - - - - - 4 changed files: - compiler/GHC/Core/Utils.hs - m4/fptools_happy.m4 - + testsuite/tests/simplCore/should_compile/T26642.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -709,11 +709,16 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) | otherwise = Nothing - -- We don't want ticks to get in the way; just push them inwards. - -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#) + -- Push ticks **inwards** (when possible). + -- See (MC5) in Note [Merge Nested Cases]. go (Tick t body) - = do { (joins, alts) <- go body - ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) } + = do { (joins, alts) <- go body -- (MC4): any join points inside are floated out of the tick. + + -- Abort if this would put a non-soft-scope tick in between + -- a join point binding and its jumps. See (MC6). + ; guard $ null joins || t `tickishScopesLike` SoftScope + ; return (joins, [Alt con bs (mkTick t rhs) | Alt con bs rhs <- alts]) + } go _ = Nothing @@ -924,9 +929,70 @@ Wrinkles So `mergeCaseAlts` floats out any join points. It doesn't float out non-join-points unless the /outer/ case has just one alternative; doing - so would risk more allocation + so would risk more allocation. + + Note also that `mergeCaseAlts` floats join points out of ticks, for which + we need to be extra careful; see (MC6). + +(MC5) We want to move ticks out of the way if possible, to prevent them from + inhibiting optimisation. For example, say we have: + + case expensive of r { + C1 -> rhs1; -- happy path + _ -> scctick<doEdgeCase> (case r of { C2 -> rhs2; C3 -> rhs3 }) + } + + In this situation, we push the "doEdgeCase" tick **inwards** and proceed + to merge cases, like so: + + case expensive of + C1 -> rhs1 + C2 -> scctick<doEdgeCase> rhs2 + C3 -> scctick<doEdgeCase> rhs3 + + This preserves the tick semantics, because this transformation: + + 1. preserves counts, + 2. does not move cost in or out of the tick scope. + + (1) is clear: we will tick 'doEdgeCase' exactly in the C2/C3 alternatives, + and we won't otherwise. + For (2), recall that case is strict in Core. We already evaluated 'expensive', + so re-scrutinising 'r' is free. + + This means that, perhaps surprisingly, this transformation is valid for + **all** ticks, including non-floatable ones. + + In contrast, we would not want to move the tick outwards, because this: + + - will lead to additional counting of 'doEdgeCase' in the 'C1' (happy path) case, + - risks attributing the cost of evaluating 'expensive' to 'doEdgeCase'. + +(MC6) There is a dangerous interaction between (MC4) and (MC5), which can lead + to invalid Core (as reported in #26642, #26929). Suppose we have: + + case f x of r -> + scctick<foo> + join j y = rhs in + case r of { C1 -> j 1; C2 -> bar } + + If we naively carried out (MC4) and (MC5) together, this would result in: + + join j y = rhs in + case f x of + C1 -> scctick<foo> (j 1) + C2 -> scctick<foo> bar + + This has moved the tick in between the join point binding 'j' and the + join point jump, which is invalid. The simplifier cannot deal with such + Core, resulting in #26642. + + The solution: abort whenever we would position a non-soft-scope tick + inside a join point in this manner. + An alternative would be to float the tick outwards, but as we saw in (MC5) + this risks a grave misattribution of profiling costs, so we don't do that. -(MC5) See Note [Cascading case merge] +(MC7) See Note [Cascading case merge] See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils ===================================== m4/fptools_happy.m4 ===================================== @@ -24,13 +24,18 @@ changequote([, ])dnl ]) if test ! -f compiler/GHC/Parser.hs || test ! -f compiler/GHC/Cmm/Parser.hs then - failure_msg="Happy version == 1.20.* || >= 2.0.2 && < 2.2 is required to compile GHC" + if test x"$fptools_cv_happy_version" != x; then + fptools_cv_happy_version_display="version $fptools_cv_happy_version"; + else + fptools_cv_happy_version_display="none"; + fi; + failure_msg="Happy version == 1.20.* || >= 2.0.2 && < 2.3 is required to compile GHC. (Found: $fptools_cv_happy_version_display)" FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.20.0], [AC_MSG_ERROR([$failure_msg])])[] FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[1.21.0], FP_COMPARE_VERSIONS([$fptools_cv_happy_version], [-le], [2.0.1], [AC_MSG_ERROR([$failure_msg])])[])[] - FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[2.2.0], + FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-ge],[2.3.0], [AC_MSG_ERROR([$failure_msg])])[] fi ===================================== testsuite/tests/simplCore/should_compile/T26642.hs ===================================== @@ -0,0 +1,46 @@ +module T26642 ( saveClobberedTemps ) where + +import Prelude ( IO, Bool(..), Int, (>>=), (==), return ) +import Data.Word ( Word64 ) + +------------------------------------------------------------------------------- + +data Word64Map a + = Bin (Word64Map a) (Word64Map a) + | Tip a + | Nil + +{-# NOINLINE myFoldr #-} +myFoldr :: (a -> b -> b) -> b -> Word64Map a -> b +myFoldr f = go + where + {-# NOINLINE go #-} + go z' Nil = z' + go z' (Tip x) = f x z' + go z' (Bin l r) = go (go z' r) l + +{-# NOINLINE nonDetFold #-} +nonDetFold :: (b -> elt -> IO b) -> b -> Word64Map elt -> IO b +nonDetFold f z0 xs = myFoldr c return xs z0 + where + {-# NOINLINE c #-} + c x k z = f z x >>= k + +{-# NOINLINE myFalse #-} +myFalse :: Bool +myFalse = False + +type RealReg = Int +data Loc = InReg RealReg | InMem + +saveClobberedTemps :: forall instr. [RealReg] -> IO [instr] +saveClobberedTemps clobbered = nonDetFold maybe_spill [] Nil + where + {-# NOINLINE maybe_spill #-} + maybe_spill :: [instr] -> Loc -> IO [instr] + maybe_spill instrs !loc = + case loc of + InReg reg + | myFalse + -> return [] + _ -> return instrs ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -470,6 +470,8 @@ test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings # go should become a join point test('T22428', [grep_errmsg(r'jump go') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds -dsuppress-unfoldings']) +test('T26642', [unless(have_profiling(), skip)], compile, ['-O -prof -fprof-auto-calls']) + test('T22459', normal, compile, ['']) test('T22623', normal, multimod_compile, ['T22623', '-O -v0']) test('T22662', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3319b7da62b0665b4425dbac3c060e2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3319b7da62b0665b4425dbac3c060e2... You're receiving this email because of your account on gitlab.haskell.org.