Florian Ragwitz pushed to branch wip/rafl/viewLExprEq at Glasgow Haskell Compiler / GHC Commits: fa10f2dd by Florian Ragwitz at 2026-11-04T17:25:52-08:00 Fix view pattern commoning HsVar used to contain a plain Id, and this broke when it changed to contain a located Id. While we're in there, we also add support for type applications and expression type signatures. Fixes #28084. - - - - - 5 changed files: - + changelog.d/viewpat-commoning - compiler/GHC/HsToCore/Match.hs - docs/users_guide/exts/view_patterns.rst - testsuite/tests/deSugar/should_run/all.T - + testsuite/tests/deSugar/should_run/viewpat-commoning.hs Changes: ===================================== changelog.d/viewpat-commoning ===================================== @@ -0,0 +1,25 @@ +section: compiler +issues: #28084 +mrs: !16937 +synopsis: ViewPatterns commoning improvements +description: + + When using :extension:`ViewPatterns`, GHC attempts to group occurrences of the + same view expression in multiple branches of a function definition or case + expression, e.g. :: + + f (expensive -> False) = ... + f (expensive -> True) = ... + + This avoids applying the ``expensive`` expression more than once. This + optimisation has been broken for most view expressions, including the above + example, since GHC 8.0.1, and has been restored in this release. + + Note that :ghc-flag:`common subexpression elimination <-fcse>`, which is + enabled under :ghc-flag:`-O`, could often recover this optimisation, limiting + the impact of the bug on optimised programs. + + The limited notion of when two view pattern expressions are "the same" has + also been extended to support type applications and expressions with a type + signature. See the "Efficiency" section of :extension:`ViewPatterns` for more + details. ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -1158,10 +1158,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 wrap h h' && exp e e' exp (XExpr (ExpandedThingTc (HSE _ x))) (XExpr (ExpandedThingTc (HSE _ x'))) = lexp x x' - exp (HsVar _ i) (HsVar _ i') = i == i' - exp (HsIPVar _ i) (HsIPVar _ i') = - -- the instance for IPName derives using the id, so follow the HsVar case - i == i' + exp (HsVar _ i) (HsVar _ i') = i `eqLocated` i' exp (XExpr (ConLikeTc c)) (XExpr (ConLikeTc c')) = c == c' exp (HsOverLit _ l) (HsOverLit _ l') = -- Overloaded lits are equal if they have the same type @@ -1172,25 +1169,19 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- (presumably to improve sharing) eqType (overLitType l) (overLitType l') && l == l' exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' - -- the fixities have been straightened out by now, so it's safe - -- to ignore them? - exp (OpApp _ l g ri) (OpApp _ l' o' ri') = - lexp l l' && lexp g o' && lexp ri ri' exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' - exp (SectionL _ e1 e2) (SectionL _ e1' e2') = - lexp e1 e1' && lexp e2 e2' - exp (SectionR _ e1 e2) (SectionR _ e1' e2') = - lexp e1 e1' && lexp e2 e2' exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) = eq_list tup_arg es1 es2 exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e' exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') = lexp e e' && lexp e1 e1' && lexp e2 e2' + exp (HsAppType t e _) (HsAppType t' e' _) = t `eqType` t' && lexp e e' + exp (ExprWithTySig _ (L _ e) _) e' = exp e e' + exp e (ExprWithTySig _ (L _ e') _) = exp e e' -- Enhancement: could implement equality for more expressions -- if it seems useful - -- But no need for HsLit, ExplicitList, ExplicitTuple, - -- because they cannot be functions + -- But no need for HsLit, ExplicitList because they cannot be functions exp _ _ = False --------- ===================================== docs/users_guide/exts/view_patterns.rst ===================================== @@ -133,10 +133,10 @@ follows: The current notion of when two view pattern expressions are "the same" is very restricted: it is not even full syntactic equality. - However, it does include variables, literals, applications, and - tuples; e.g., two instances of ``view ("hi", "there")`` will be - collected. However, the current implementation does not compare up to - alpha-equivalence, so two instances of ``(x, view x -> y)`` will not - be coalesced. + However, it does include variables, literals, applications, type + applications, expressions with a type signature, and tuples; e.g., + two instances of ``view ("hi", "there")`` will be collected. However, + the current implementation does not compare up to alpha-equivalence, + so two instances of ``(x, view x -> y)`` will not be coalesced. ===================================== testsuite/tests/deSugar/should_run/all.T ===================================== @@ -78,3 +78,5 @@ test('T25065b', normal, compile_and_run, ['']) test('Or5', exit_code(1), compile_and_run, ['']) test('LazyFieldAnnotationsSemantics', normal, compile_and_run, ['']) + +test('viewpat-commoning', normal, compile_and_run, ['']) ===================================== testsuite/tests/deSugar/should_run/viewpat-commoning.hs ===================================== @@ -0,0 +1,74 @@ +-- regression test for viewLExprEq in GHC.HsToCore.Match, which wants to group +-- together certain view patterns if they're "equal" in order to avoid multiple +-- evaluations of the same expression. + +-- CSE might perform the same optimisation later, so we disable optimisations +{-# OPTIONS_GHC -Wall -O0 #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where + +import Control.Exception +import Control.Monad +import Data.IORef +import System.IO.Unsafe +import Data.Functor + +{-# NOINLINE calls #-} +calls :: IORef Int +calls = unsafePerformIO (newIORef 0) + +{-# NOINLINE count #-} +count :: a -> a +count x = unsafePerformIO $ modifyIORef' calls (+1) $> x + +data X = A | B + +{-# NOINLINE view #-} +view :: a -> X +view x = count x `seq` B + +{-# NOINLINE viewX #-} +viewX :: a -> Int -> X +viewX = const view + +var, par, app, neg, neg', cond, tup :: Int -> Int + +var (view -> A) = 1 +var (view -> B) = 2 + +par (((view)) -> A) = 1 +par (view -> B) = 2 + +app (viewX True -> A) = 1 +app (viewX True -> B) = 2 + +neg (viewX @Int (-1) -> A) = 1 +neg (viewX @Int (-1) -> B) = 2 + +type Int' = Int +neg' (viewX (-1 :: Int) -> A) = 1 +neg' (viewX (-1 :: Int') -> B) = 2 + +cond (if True then view else undefined -> A) = 1 +cond (if True then view else undefined -> B) = 2 + +tup (viewX (True, False) -> A) = 1 +tup (viewX (True, False) -> B) = 2 + +check :: String -> Int -> IO () +check name action = do + writeIORef calls 0 + _ <- evaluate action + got <- readIORef calls + unless (got == 1) $ putStrLn $ name ++ ": got " ++ show got ++ ", expected 1" + +main :: IO () +main = do + check "var" (var 0) + check "par" (par 0) + check "app" (app 0) + check "neg" (neg 0) + check "neg'" (neg' 0) + check "cond" (cond 0) + check "tup" (tup 0) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa10f2dd0a230c4d1fd6126b152564a7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fa10f2dd0a230c4d1fd6126b152564a7... 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