Simon Peyton Jones pushed to branch wip/T27862 at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • changelog.d/T27862
    1 
    +section: compiler
    2 
    +issues: #27862
    3 
    +mrs: !16899
    4 
    +synopsis:
    5 
    +  Improve desugaring for pattern matching involving bang patterns.
    6 
    +description:
    7 
    +  We were generating poor code for pattern matching that used bang-patterns.
    8 
    +  There should be no user-visible changes except more efficient code.

  • compiler/GHC/HsToCore/Match.hs
    ... ... @@ -164,6 +164,56 @@ applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
    164 164 
     un}mixes the equations], producing a list of equation-info
    165 165 
     blocks, each block having as its first column patterns compatible with each other.
    166 166
    167 
    +
    168 
    +Note [Grouping equations]
    169 
    +~~~~~~~~~~~~~~~~~~~~~~~~~
    170 
    +Given a bunch of equations, `groupEquations` makes groups of consecutive equations,
    171 
    +in which the first patern of each member of a group shares the same `PatGroup`
    172 
    +category.
    173 
    +   groupEquations :: [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
    174 
    +Generally, in each NonEmpty (PatGroup, EquationInfoNE) element of the result list,
    175 
    +all the PatGroup's will be the same (e.g. all PgCon or all PgAny). But see (GE1)
    176 
    +for an exception.
    177 
    +
    178 
    +We will match each group in turn, with failure falling through into the
    179 
    +next group.  For example
    180 
    +   f x           0 = ...  -- (E1)
    181 
    +   f !y          1 = ...  -- (E2)
    182 
    +   f y           2 = ...  -- (E3)
    183 
    +   f (Just True) _ = ...  -- (E4)
    184 
    +   f Nothing     _ = ...  -- (E5)
    185 
    +   f x           4 = ...  -- (E6)
    186 
    +   f _           5 = ...  -- (E7)
    187 
    +
    188 
    +The initial groups are
    189 
    +   [E1]
    190 
    +   [E2,E3, .. E7]
    191 
    +because the bang dominates all the the equations that follow; see (GE1) below.   Once we
    192 
    +get inside the bang we'll again do a `groupEquations` and get groups
    193 
    +   [E2,E3]   -- PgAny
    194 
    +   [E4,E5]   -- PgCon
    195 
    +   [E6,E6]   -- PgAny
    196 
    +
    197 
    +Wrinkles
    198 
    +
    199 
    +(GE1) A bang pattern captures all the equations that follow.  For example, given
    200 
    +    g !x   (p,True)  = ...(E1)...
    201 
    +    g x    (p,False) = ...(E2)...
    202 
    +    g True v         = ...(E3)...
    203 
    +  we want to get the (p,True) and (p,False) patterns in a single group so we can share
    204 
    +  the matching on the pair, and we can't do that if we make two groups for the top
    205 
    +  level match.  See #27862.  So we want these groups:
    206 
    +
    207 
    +       Group 1:   !x (p,True)  -> ..E1..
    208 
    +                  x  (p,False) -> ..E2..
    209 
    +
    210 
    +       Group 2:   True v       -> ..E3..
    211 
    +
    212 
    +  A consequence is that in a group with a `PgBang` category, such as Group 1 above,
    213 
    +  the second and subsequent equations may not be headed with a bang-pattern.  Hence
    214 
    +  in `matchBangs`, the function `getBangPat` is not surprised to see a non-bang pattern.
    215 
    +
    216 
    +(GE2) Overloaded literals: see Note [Grouping overloaded literal patterns]
    167 217 
     -}
    168 218
    169 219 
     match :: [MatchId]        -- ^ Variables rep\'ing the exprs we\'re matching with
    ... ... @@ -176,11 +226,14 @@ match [] ty eqns = maybe (assertPprPanic (ppr ty)) combineEqnRhss $ nonEmpty eqn
    176 226 
     match (v:vs) ty eqns    -- Eqns can be empty, but each equation is nonempty
    177 227 
       = assertPpr (all (isInternalName . idName . matchId) vars) (ppr vars) $
    178 228 
         do  { dflags <- getDynFlags
    229 
    +
    230 
    +                -- Tidy the first pattern, to remove unnecessary diversity,
    231 
    +                -- generating auxiliary bindings if necessary
    179 232 
             ; let platform = targetPlatform dflags
    180 
    -                -- Tidy the first pattern, generating
    181 
    -                -- auxiliary bindings if necessary
    182 233 
             ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
    234 
    +
    183 235 
                     -- Group the equations and match each group in turn
    236 
    +                -- See Note [Grouping equations]
    184 237 
             ; let grouped = groupEquations platform tidy_eqns
    185 238
    186 239 
              -- print the view patterns that are commoned up to help debug
    ... ... @@ -201,6 +254,7 @@ match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty
    201 254 
         match_groups (g:gs) = mapM match_group $ g :| gs
    202 255
    203 256 
         match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr)
    257 
    +    -- See Note [Grouping equations]
    204 258 
         match_group eqns@((group,_) :| _)
    205 259 
             = case group of
    206 260 
                 PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
    ... ... @@ -246,6 +300,7 @@ matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (Ma
    246 300 
     matchVariables (_ :| vars) ty eqns = match vars ty $ NE.toList $ shiftEqns eqns
    247 301
    248 302 
     matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
    303 
    +-- See (GE1) in Note [Grouping equations]
    249 304 
     matchBangs (var :| vars) ty eqns
    250 305 
       = do  { match_result <- match (var:vars) ty $ NE.toList $
    251 306 
                 decomposeFirstPat getBangPat <$> eqns
    ... ... @@ -290,14 +345,20 @@ decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoN
    290 345 
     decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat}
    291 346 
     decomposeFirstPat _ (EqnDone {}) = panic "decomposeFirstPat"
    292 347
    293 
    -getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
    348 
    +getCoPat :: Pat GhcTc -> Pat GhcTc
    294 349 
     getCoPat (XPat (CoPat _ pat _)) = pat
    295 350 
     getCoPat _                   = panic "getCoPat"
    296 
    -getBangPat (BangPat _ pat  ) = unLoc pat
    297 
    -getBangPat _                 = panic "getBangPat"
    351 
    +
    352 
    +getViewPat :: Pat GhcTc -> Pat GhcTc
    298 353 
     getViewPat (TcViewPat _ pat) = pat
    299 354 
     getViewPat _                 = panic "getViewPat"
    300 355
    356 
    +getBangPat :: Pat GhcTc -> Pat GhcTc
    357 
    +-- See (GE1) in Note [Grouping equations]
    358 
    +getBangPat (BangPat _ pat  ) = unLoc pat
    359 
    +getBangPat pat               = pat
    360 
    +
    361 
    +
    301 362 
     -- | Use this pattern synonym to match on a 'ViewPat'.
    302 363 
     --
    303 364 
     -- N.B.: View patterns can occur inside HsExpansions.
    ... ... @@ -527,12 +588,10 @@ tidy1 _ non_interesting_pat
    527 588 
     tidy_bang_pat :: MatchId -> SrcSpanAnnA -> Pat GhcTc
    528 589 
                   -> DsM (DsWrapper, Pat GhcTc)
    529 590
    530 
    --- Discard par/sig under a bang
    531 
    -tidy_bang_pat v _ (ParPat _ (L l p))   = putSrcSpanDsA l $ tidy_bang_pat v l p
    532 
    -tidy_bang_pat v _ (SigPat _ (L l p) _) = putSrcSpanDsA l $ tidy_bang_pat v l p
    533 
    -
    534 
    --- Push the bang-pattern inwards, in the hope that
    535 
    --- it may disappear next time
    591 
    +-- Push the bang-pattern inwards, in the hope that it may disappear next time
    592 
    +--   AsPat  !(x@p)     -->  x@(!p)
    593 
    +--   CoPat  !(p |> co) -->  (!p) |> co
    594 
    +--   OrPat  !(p || q)  -->  (!p || !q)
    536 595 
     tidy_bang_pat v l (AsPat x v' p)
    537 596 
       = tidy1 v (AsPat x v' (L l (BangPat noExtField p)))
    538 597 
     tidy_bang_pat v l (XPat (CoPat w p t))
    ... ... @@ -540,7 +599,16 @@ tidy_bang_pat v l (XPat (CoPat w p t))
    540 599 
     tidy_bang_pat v l (OrPat x (p:|ps)) -- push bang into first pat alt
    541 600 
       = tidy1 v (OrPat x (L l (BangPat noExtField p) :| ps))
    542 601
    602 
    +-- Discard par/sig/bang under a bang
    603 
    +--    !(p)      -->   !p
    604 
    +--    !(p::ty)  -->   !p
    605 
    +--    !(!p)     -->   !p
    606 
    +tidy_bang_pat v _ (ParPat _ (L l p))   = putSrcSpanDsA l $ tidy_bang_pat v l p
    607 
    +tidy_bang_pat v _ (SigPat _ (L l p) _) = putSrcSpanDsA l $ tidy_bang_pat v l p
    608 
    +tidy_bang_pat v _ (BangPat _ (L l p))  = putSrcSpanDsA l $ tidy_bang_pat v l p
    609 
    +
    543 610 
     -- Discard bang around strict pattern
    611 
    +--    e.g.  !(Just p)  -->  Just p
    544 612 
     tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
    545 613 
     tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
    546 614 
     tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
    ... ... @@ -554,12 +622,13 @@ tidy_bang_pat v l p@(ConPat { pat_con = L _ (RealDataCon dc)
    554 622 
                                   }
    555 623 
                                 })
    556 624 
       -- Newtypes: push bang inwards (#9844)
    557 
    -  =
    558 
    -    if isNewTyCon (dataConTyCon dc)
    559 
    -      then tidy1 v (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
    560 
    -      else tidy1 v p  -- Data types: discard the bang
    561 
    -    where
    562 
    -      (ty:_) = dataConInstArgTys dc arg_tys
    625 
    +  | isNewTyCon (dataConTyCon dc)
    626 
    +  , (ty:_) <- dataConInstArgTys dc arg_tys
    627 
    +  = tidy1 v (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
    628 
    +
    629 
    +  -- Discard bang around non-newtype data constructors
    630 
    +  | otherwise
    631 
    +  = tidy1 v p
    563 632
    564 633 
     -------------------
    565 634 
     -- Default case, leave the bang there:
    ... ... @@ -1036,11 +1105,21 @@ groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationI
    1036 1105 
     -- (b) none of the gi are empty
    1037 1106 
     -- The ordering of equations is unchanged
    1038 1107 
     groupEquations platform eqns
    1039 
    -  = NE.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
    1040 
    -  -- comprehension on NonEmpty
    1108 
    +  = group_eqns $ map add_gp eqns
    1041 1109 
       where
    1042 
    -    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
    1043 
    -    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
    1110 
    +    add_gp :: EquationInfoNE -> (PatGroup, EquationInfoNE)
    1111 
    +    add_gp eqn = (patGroup platform (firstPat eqn), eqn)
    1112 
    +
    1113 
    +    group_eqns :: [(PatGroup,EquationInfoNE)] -> [NonEmpty (PatGroup, EquationInfoNE)]
    1114 
    +    -- See Note [Grouping equations]
    1115 
    +    group_eqns [] = []
    1116 
    +    group_eqns ((PgBang,e) : pges) = [ (PgBang,e) :| pges ]  -- See (GE1)
    1117 
    +    group_eqns ((pg1,e)    : pges) = ((pg1,e) :| pges1) : group_eqns pges2
    1118 
    +      where
    1119 
    +        (pges1, pges2) = span same_gp pges
    1120 
    +
    1121 
    +        same_gp :: (PatGroup,EquationInfo) -> Bool
    1122 
    +        same_gp (pg2,_) = pg1 `sameGroup` pg2
    1044 1123
    1045 1124 
     -- TODO Make subGroup1 using a NonEmptyMap
    1046 1125 
     subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems

  • testsuite/tests/deSugar/should_compile/T27862.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    2 
    +module T27862 (allBangs, firstBang, lastLazy) where
    3 
    +
    4 
    +data Axis = Axis !Int !Int
    5 
    +
    6 
    +-- The axes of extent other than 1, their strides made positive, and
    7 
    +-- the offset moved by each negative stride. The three functions are
    8 
    +-- the same, except for the bangs on 'off'.
    9 
    +
    10 
    +{- With GHC 10.0
    11 
    +* allBangs has a bang on all three equations.
    12 
    +  The flag reports the bangs on equations 2 and 3.
    13 
    +
    14 
    +* firstBang keeps only the bang that the flag does not report. Its
    15 
    +  worker matches both lists two times: the second match is in a join point fail, and
    16 
    +  the first match jumps to it. In the second match, GHC does not know that n is
    17 
    +  evaluated. Thus it builds the strict-field constructor Axis x n inside case n
    18 
    +  of I#, and in STG this is an updatable thunk, one for each axis with an extent
    19 
    +  other than 1 and a non-negative stride. allBangs allocates no thunk.
    20 
    +
    21 
    +* lastLazy removes only the bang on equation 3. Its worker is better than
    22 
    +  the worker of allBangs. allBangs keeps a join point fail _ = (# axes, ww #),
    23 
    +  and its two [] alternatives jump to it. In lastLazy, the two [] alternatives
    24 
    +  return (# axes, ww #) directly.
    25 
    +-}
    26 
    +
    27 
    +allBangs :: [Axis] -> Int -> [Int] -> [Int] -> ([Axis], Int)
    28 
    +allBangs axes !off (_ : sts) (1 : ns) = allBangs axes off sts ns
    29 
    +allBangs axes !off (st : sts) (n : ns)
    30 
    +  | st < 0 = allBangs (Axis (negate st) n : axes) (off + (n - 1) * st) sts ns
    31 
    +  | otherwise = allBangs (Axis st n : axes) off sts ns
    32 
    +allBangs axes !off _ _ = (axes, off)
    33 
    +
    34 
    +-- Both bangs that the flag reports are removed.
    35 
    +firstBang :: [Axis] -> Int -> [Int] -> [Int] -> ([Axis], Int)
    36 
    +firstBang axes !off (_ : sts) (1 : ns) = firstBang axes off sts ns
    37 
    +firstBang axes off (st : sts) (n : ns)
    38 
    +  | st < 0 = firstBang (Axis (negate st) n : axes) (off + (n - 1) * st) sts ns
    39 
    +  | otherwise = firstBang (Axis st n : axes) off sts ns
    40 
    +firstBang axes off _ _ = (axes, off)
    41 
    +
    42 
    +-- Only the last bang that the flag reports is removed.
    43 
    +lastLazy :: [Axis] -> Int -> [Int] -> [Int] -> ([Axis], Int)
    44 
    +lastLazy axes !off (_ : sts) (1 : ns) = lastLazy axes off sts ns
    45 
    +lastLazy axes !off (st : sts) (n : ns)
    46 
    +  | st < 0 = lastLazy (Axis (negate st) n : axes) (off + (n - 1) * st) sts ns
    47 
    +  | otherwise = lastLazy (Axis st n : axes) off sts ns
    48 
    +lastLazy axes off _ _ = (axes, off)

  • testsuite/tests/deSugar/should_compile/T27862.stderr
    1 
    +firstBang = lastLazy
    2 
    +allBangs = lastLazy

  • testsuite/tests/deSugar/should_compile/all.T
    ... ... @@ -121,3 +121,8 @@ test('T27383',
    121 121 
          [collect_compiler_stats('bytes allocated', 10)],
    122 122 
          compile,
    123 123 
          ['-Wincomplete-patterns'])
    124 
    +
    125 
    +# T27862.  Expecting to see
    126 
    +#   allBangs = lastLazy, and firstBang = lastLazy,
    127 
    +# so they have identical code
    128 
    +test('T27862', [grep_errmsg(' lastLazy')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])

    • —
    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/230d0a85fb6d77d974d03c4e7ecdd5dea0238275 at 1793571392