Florian Ragwitz pushed to branch wip/rafl/viewLExprEq at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • changelog.d/viewpat-commoning
    1 
    +section: compiler
    2 
    +issues: #28084
    3 
    +mrs: !16937
    4 
    +synopsis: ViewPatterns commoning improvements
    5 
    +description:
    6 
    +
    7 
    +  When using :extension:`ViewPatterns`, GHC attempts to group occurrences of the
    8 
    +  same view expression in multiple branches of a function definition or case
    9 
    +  expression, e.g. ::
    10 
    +
    11 
    +    f (expensive -> False) = ...
    12 
    +    f (expensive -> True) = ...
    13 
    +
    14 
    +  This avoids applying the ``expensive`` expression more than once. This
    15 
    +  optimisation has been broken for most view expressions, including the above
    16 
    +  example, since GHC 8.0.1, and has been restored in this release.
    17 
    +
    18 
    +  Note that :ghc-flag:`common subexpression elimination <-fcse>`, which is
    19 
    +  enabled under :ghc-flag:`-O`, could often recover this optimisation, limiting
    20 
    +  the impact of the bug on optimised programs.
    21 
    +
    22 
    +  The limited notion of when two view pattern expressions are "the same" has
    23 
    +  also been extended to support type applications and expressions with a type
    24 
    +  signature. See the "Efficiency" section of :extension:`ViewPatterns` for more
    25 
    +  details.

  • compiler/GHC/HsToCore/Match.hs
    ... ... @@ -1158,10 +1158,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
    1158 1158 
           wrap h h' && exp e e'
    1159 1159 
         exp (XExpr (ExpandedThingTc (HSE _ x))) (XExpr (ExpandedThingTc (HSE _ x')))
    1160 1160 
           = lexp x x'
    1161 
    -    exp (HsVar _ i) (HsVar _ i') = i == i'
    1162 
    -    exp (HsIPVar _ i) (HsIPVar _ i') =
    1163 
    -      -- the instance for IPName derives using the id, so follow the HsVar case
    1164 
    -      i == i'
    1161 
    +    exp (HsVar _ i) (HsVar _ i') = i `eqLocated` i'
    1165 1162 
         exp (XExpr (ConLikeTc c)) (XExpr (ConLikeTc c')) = c == c'
    1166 1163 
         exp (HsOverLit _ l) (HsOverLit _ l') =
    1167 1164 
             -- Overloaded lits are equal if they have the same type
    ... ... @@ -1172,25 +1169,19 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
    1172 1169 
             -- (presumably to improve sharing)
    1173 1170 
             eqType (overLitType l) (overLitType l') && l == l'
    1174 1171 
         exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
    1175 
    -    -- the fixities have been straightened out by now, so it's safe
    1176 
    -    -- to ignore them?
    1177 
    -    exp (OpApp _ l g ri) (OpApp _ l' o' ri') =
    1178 
    -        lexp l l' && lexp g o' && lexp ri ri'
    1179 1172 
         exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
    1180 
    -    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
    1181 
    -        lexp e1 e1' && lexp e2 e2'
    1182 
    -    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
    1183 
    -        lexp e1 e1' && lexp e2 e2'
    1184 1173 
         exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
    1185 1174 
             eq_list tup_arg es1 es2
    1186 1175 
         exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
    1187 1176 
         exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
    1188 1177 
             lexp e e' && lexp e1 e1' && lexp e2 e2'
    1178 
    +    exp (HsAppType t e _) (HsAppType t' e' _) = t `eqType` t' && lexp e e'
    1179 
    +    exp (ExprWithTySig _ (L _ e) _) e' = exp e e'
    1180 
    +    exp e (ExprWithTySig _ (L _ e') _) = exp e e'
    1189 1181
    1190 1182 
         -- Enhancement: could implement equality for more expressions
    1191 1183 
         --   if it seems useful
    1192 
    -    -- But no need for HsLit, ExplicitList, ExplicitTuple,
    1193 
    -    -- because they cannot be functions
    1184 
    +    -- But no need for HsLit, ExplicitList because they cannot be functions
    1194 1185 
         exp _ _  = False
    1195 1186
    1196 1187 
         ---------

  • docs/users_guide/exts/view_patterns.rst
    ... ... @@ -133,10 +133,10 @@ follows:
    133 133
    134 134 
        The current notion of when two view pattern expressions are "the
    135 135 
        same" is very restricted: it is not even full syntactic equality.
    136 
    -   However, it does include variables, literals, applications, and
    137 
    -   tuples; e.g., two instances of ``view ("hi", "there")`` will be
    138 
    -   collected. However, the current implementation does not compare up to
    139 
    -   alpha-equivalence, so two instances of ``(x, view x -> y)`` will not
    140 
    -   be coalesced.
    136 
    +   However, it does include variables, literals, applications, type
    137 
    +   applications, expressions with a type signature, and tuples; e.g.,
    138 
    +   two instances of ``view ("hi", "there")`` will be collected. However,
    139 
    +   the current implementation does not compare up to alpha-equivalence,
    140 
    +   so two instances of ``(x, view x -> y)`` will not be coalesced.
    141 141
    142 142

  • testsuite/tests/deSugar/should_run/all.T
    ... ... @@ -78,3 +78,5 @@ test('T25065b', normal, compile_and_run, [''])
    78 78 
     test('Or5', exit_code(1), compile_and_run, [''])
    79 79
    80 80 
     test('LazyFieldAnnotationsSemantics', normal, compile_and_run, [''])
    81 
    +
    82 
    +test('viewpat-commoning', normal, compile_and_run, [''])

  • testsuite/tests/deSugar/should_run/viewpat-commoning.hs
    1 
    +-- regression test for viewLExprEq in GHC.HsToCore.Match, which wants to group
    2 
    +-- together certain view patterns if they're "equal" in order to avoid multiple
    3 
    +-- evaluations of the same expression.
    4 
    +
    5 
    +-- CSE might perform the same optimisation later, so we disable optimisations
    6 
    +{-# OPTIONS_GHC -Wall -O0 #-}
    7 
    +{-# LANGUAGE ViewPatterns #-}
    8 
    +
    9 
    +module Main where
    10 
    +
    11 
    +import Control.Exception
    12 
    +import Control.Monad
    13 
    +import Data.IORef
    14 
    +import System.IO.Unsafe
    15 
    +import Data.Functor
    16 
    +
    17 
    +{-# NOINLINE calls #-}
    18 
    +calls :: IORef Int
    19 
    +calls = unsafePerformIO (newIORef 0)
    20 
    +
    21 
    +{-# NOINLINE count #-}
    22 
    +count :: a -> a
    23 
    +count x = unsafePerformIO $ modifyIORef' calls (+1) $> x
    24 
    +
    25 
    +data X = A | B
    26 
    +
    27 
    +{-# NOINLINE view #-}
    28 
    +view :: a -> X
    29 
    +view x = count x `seq` B
    30 
    +
    31 
    +{-# NOINLINE viewX #-}
    32 
    +viewX :: a -> Int -> X
    33 
    +viewX = const view
    34 
    +
    35 
    +var, par, app, neg, neg', cond, tup :: Int -> Int
    36 
    +
    37 
    +var (view -> A) = 1
    38 
    +var (view -> B) = 2
    39 
    +
    40 
    +par (((view)) -> A) = 1
    41 
    +par (view -> B) = 2
    42 
    +
    43 
    +app (viewX True -> A) = 1
    44 
    +app (viewX True -> B) = 2
    45 
    +
    46 
    +neg (viewX @Int (-1) -> A) = 1
    47 
    +neg (viewX @Int (-1) -> B) = 2
    48 
    +
    49 
    +type Int' = Int
    50 
    +neg' (viewX (-1 :: Int) -> A) = 1
    51 
    +neg' (viewX (-1 :: Int') -> B) = 2
    52 
    +
    53 
    +cond (if True then view else undefined -> A) = 1
    54 
    +cond (if True then view else undefined -> B) = 2
    55 
    +
    56 
    +tup (viewX (True, False) -> A) = 1
    57 
    +tup (viewX (True, False) -> B) = 2
    58 
    +
    59 
    +check :: String -> Int -> IO ()
    60 
    +check name action = do
    61 
    +  writeIORef calls 0
    62 
    +  _ <- evaluate action
    63 
    +  got <- readIORef calls
    64 
    +  unless (got == 1) $ putStrLn $ name ++ ": got " ++ show got ++ ", expected 1"
    65 
    +
    66 
    +main :: IO ()
    67 
    +main = do
    68 
    +  check "var" (var 0)
    69 
    +  check "par" (par 0)
    70 
    +  check "app" (app 0)
    71 
    +  check "neg" (neg 0)
    72 
    +  check "neg'" (neg' 0)
    73 
    +  check "cond" (cond 0)
    74 
    +  check "tup" (tup 0)

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/fa10f2dd0a230c4d1fd6126b152564a799e1ad59 at 1793842078