Simon Peyton Jones pushed to branch wip/T27862 at Glasgow Haskell Compiler / GHC Commits: 230d0a85 by Simon Peyton Jones at 2026-11-01T22:16:11+00:00 Better desugaring for bang patterns Ticket #27862 showed that we were desugaring bang patterns in a silly way, which led to bad code. This small fix makes it much better. See (GE1) in new Note [Grouping equations] in GHc.HsToCore.Match - - - - - 5 changed files: - + changelog.d/T27862 - compiler/GHC/HsToCore/Match.hs - + testsuite/tests/deSugar/should_compile/T27862.hs - + testsuite/tests/deSugar/should_compile/T27862.stderr - testsuite/tests/deSugar/should_compile/all.T Changes: ===================================== changelog.d/T27862 ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27862 +mrs: !16899 +synopsis: + Improve desugaring for pattern matching involving bang patterns. +description: + We were generating poor code for pattern matching that used bang-patterns. + 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 un}mixes the equations], producing a list of equation-info blocks, each block having as its first column patterns compatible with each other. + +Note [Grouping equations] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a bunch of equations, `groupEquations` makes groups of consecutive equations, +in which the first patern of each member of a group shares the same `PatGroup` +category. + groupEquations :: [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)] +Generally, in each NonEmpty (PatGroup, EquationInfoNE) element of the result list, +all the PatGroup's will be the same (e.g. all PgCon or all PgAny). But see (GE1) +for an exception. + +We will match each group in turn, with failure falling through into the +next group. For example + f x 0 = ... -- (E1) + f !y 1 = ... -- (E2) + f y 2 = ... -- (E3) + f (Just True) _ = ... -- (E4) + f Nothing _ = ... -- (E5) + f x 4 = ... -- (E6) + f _ 5 = ... -- (E7) + +The initial groups are + [E1] + [E2,E3, .. E7] +because the bang dominates all the the equations that follow; see (GE1) below. Once we +get inside the bang we'll again do a `groupEquations` and get groups + [E2,E3] -- PgAny + [E4,E5] -- PgCon + [E6,E6] -- PgAny + +Wrinkles + +(GE1) A bang pattern captures all the equations that follow. For example, given + g !x (p,True) = ...(E1)... + g x (p,False) = ...(E2)... + g True v = ...(E3)... + we want to get the (p,True) and (p,False) patterns in a single group so we can share + the matching on the pair, and we can't do that if we make two groups for the top + level match. See #27862. So we want these groups: + + Group 1: !x (p,True) -> ..E1.. + x (p,False) -> ..E2.. + + Group 2: True v -> ..E3.. + + A consequence is that in a group with a `PgBang` category, such as Group 1 above, + the second and subsequent equations may not be headed with a bang-pattern. Hence + in `matchBangs`, the function `getBangPat` is not surprised to see a non-bang pattern. + +(GE2) Overloaded literals: see Note [Grouping overloaded literal patterns] -} 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 match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty = assertPpr (all (isInternalName . idName . matchId) vars) (ppr vars) $ do { dflags <- getDynFlags + + -- Tidy the first pattern, to remove unnecessary diversity, + -- generating auxiliary bindings if necessary ; let platform = targetPlatform dflags - -- Tidy the first pattern, generating - -- auxiliary bindings if necessary ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + -- Group the equations and match each group in turn + -- See Note [Grouping equations] ; let grouped = groupEquations platform tidy_eqns -- 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 match_groups (g:gs) = mapM match_group $ g :| gs match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr) + -- See Note [Grouping equations] match_group eqns@((group,_) :| _) = case group of PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) @@ -246,6 +300,7 @@ matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (Ma matchVariables (_ :| vars) ty eqns = match vars ty $ NE.toList $ shiftEqns eqns matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) +-- See (GE1) in Note [Grouping equations] matchBangs (var :| vars) ty eqns = do { match_result <- match (var:vars) ty $ NE.toList $ decomposeFirstPat getBangPat <$> eqns @@ -290,14 +345,20 @@ decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoN decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat} decomposeFirstPat _ (EqnDone {}) = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc +getCoPat :: Pat GhcTc -> Pat GhcTc getCoPat (XPat (CoPat _ pat _)) = pat getCoPat _ = panic "getCoPat" -getBangPat (BangPat _ pat ) = unLoc pat -getBangPat _ = panic "getBangPat" + +getViewPat :: Pat GhcTc -> Pat GhcTc getViewPat (TcViewPat _ pat) = pat getViewPat _ = panic "getViewPat" +getBangPat :: Pat GhcTc -> Pat GhcTc +-- See (GE1) in Note [Grouping equations] +getBangPat (BangPat _ pat ) = unLoc pat +getBangPat pat = pat + + -- | Use this pattern synonym to match on a 'ViewPat'. -- -- N.B.: View patterns can occur inside HsExpansions. @@ -527,12 +588,10 @@ tidy1 _ non_interesting_pat tidy_bang_pat :: MatchId -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) --- Discard par/sig under a bang -tidy_bang_pat v _ (ParPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p -tidy_bang_pat v _ (SigPat _ (L l p) _) = putSrcSpanDsA l $ tidy_bang_pat v l p - --- Push the bang-pattern inwards, in the hope that --- it may disappear next time +-- Push the bang-pattern inwards, in the hope that it may disappear next time +-- AsPat !(x@p) --> x@(!p) +-- CoPat !(p |> co) --> (!p) |> co +-- OrPat !(p || q) --> (!p || !q) tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExtField p))) tidy_bang_pat v l (XPat (CoPat w p t)) @@ -540,7 +599,16 @@ tidy_bang_pat v l (XPat (CoPat w p t)) tidy_bang_pat v l (OrPat x (p:|ps)) -- push bang into first pat alt = tidy1 v (OrPat x (L l (BangPat noExtField p) :| ps)) +-- Discard par/sig/bang under a bang +-- !(p) --> !p +-- !(p::ty) --> !p +-- !(!p) --> !p +tidy_bang_pat v _ (ParPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p +tidy_bang_pat v _ (SigPat _ (L l p) _) = putSrcSpanDsA l $ tidy_bang_pat v l p +tidy_bang_pat v _ (BangPat _ (L l p)) = putSrcSpanDsA l $ tidy_bang_pat v l p + -- Discard bang around strict pattern +-- e.g. !(Just p) --> Just p tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p 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) } }) -- Newtypes: push bang inwards (#9844) - = - if isNewTyCon (dataConTyCon dc) - then tidy1 v (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) - else tidy1 v p -- Data types: discard the bang - where - (ty:_) = dataConInstArgTys dc arg_tys + | isNewTyCon (dataConTyCon dc) + , (ty:_) <- dataConInstArgTys dc arg_tys + = tidy1 v (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) + + -- Discard bang around non-newtype data constructors + | otherwise + = tidy1 v p ------------------- -- Default case, leave the bang there: @@ -1036,11 +1105,21 @@ groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationI -- (b) none of the gi are empty -- The ordering of equations is unchanged groupEquations platform eqns - = NE.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns] - -- comprehension on NonEmpty + = group_eqns $ map add_gp eqns where - same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool - (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 + add_gp :: EquationInfoNE -> (PatGroup, EquationInfoNE) + add_gp eqn = (patGroup platform (firstPat eqn), eqn) + + group_eqns :: [(PatGroup,EquationInfoNE)] -> [NonEmpty (PatGroup, EquationInfoNE)] + -- See Note [Grouping equations] + group_eqns [] = [] + group_eqns ((PgBang,e) : pges) = [ (PgBang,e) :| pges ] -- See (GE1) + group_eqns ((pg1,e) : pges) = ((pg1,e) :| pges1) : group_eqns pges2 + where + (pges1, pges2) = span same_gp pges + + same_gp :: (PatGroup,EquationInfo) -> Bool + same_gp (pg2,_) = pg1 `sameGroup` pg2 -- TODO Make subGroup1 using a NonEmptyMap subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems ===================================== testsuite/tests/deSugar/should_compile/T27862.hs ===================================== @@ -0,0 +1,48 @@ +{-# LANGUAGE BangPatterns #-} +module T27862 (allBangs, firstBang, lastLazy) where + +data Axis = Axis !Int !Int + +-- The axes of extent other than 1, their strides made positive, and +-- the offset moved by each negative stride. The three functions are +-- the same, except for the bangs on 'off'. + +{- With GHC 10.0 +* allBangs has a bang on all three equations. + The flag reports the bangs on equations 2 and 3. + +* firstBang keeps only the bang that the flag does not report. Its + worker matches both lists two times: the second match is in a join point fail, and + the first match jumps to it. In the second match, GHC does not know that n is + evaluated. Thus it builds the strict-field constructor Axis x n inside case n + of I#, and in STG this is an updatable thunk, one for each axis with an extent + other than 1 and a non-negative stride. allBangs allocates no thunk. + +* lastLazy removes only the bang on equation 3. Its worker is better than + the worker of allBangs. allBangs keeps a join point fail _ = (# axes, ww #), + and its two [] alternatives jump to it. In lastLazy, the two [] alternatives + return (# axes, ww #) directly. +-} + +allBangs :: [Axis] -> Int -> [Int] -> [Int] -> ([Axis], Int) +allBangs axes !off (_ : sts) (1 : ns) = allBangs axes off sts ns +allBangs axes !off (st : sts) (n : ns) + | st < 0 = allBangs (Axis (negate st) n : axes) (off + (n - 1) * st) sts ns + | otherwise = allBangs (Axis st n : axes) off sts ns +allBangs axes !off _ _ = (axes, off) + +-- Both bangs that the flag reports are removed. +firstBang :: [Axis] -> Int -> [Int] -> [Int] -> ([Axis], Int) +firstBang axes !off (_ : sts) (1 : ns) = firstBang axes off sts ns +firstBang axes off (st : sts) (n : ns) + | st < 0 = firstBang (Axis (negate st) n : axes) (off + (n - 1) * st) sts ns + | otherwise = firstBang (Axis st n : axes) off sts ns +firstBang axes off _ _ = (axes, off) + +-- Only the last bang that the flag reports is removed. +lastLazy :: [Axis] -> Int -> [Int] -> [Int] -> ([Axis], Int) +lastLazy axes !off (_ : sts) (1 : ns) = lastLazy axes off sts ns +lastLazy axes !off (st : sts) (n : ns) + | st < 0 = lastLazy (Axis (negate st) n : axes) (off + (n - 1) * st) sts ns + | otherwise = lastLazy (Axis st n : axes) off sts ns +lastLazy axes off _ _ = (axes, off) ===================================== testsuite/tests/deSugar/should_compile/T27862.stderr ===================================== @@ -0,0 +1,2 @@ +firstBang = lastLazy +allBangs = lastLazy ===================================== testsuite/tests/deSugar/should_compile/all.T ===================================== @@ -121,3 +121,8 @@ test('T27383', [collect_compiler_stats('bytes allocated', 10)], compile, ['-Wincomplete-patterns']) + +# T27862. Expecting to see +# allBangs = lastLazy, and firstBang = lastLazy, +# so they have identical code +test('T27862', [grep_errmsg(' lastLazy')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/230d0a85fb6d77d974d03c4e7ecdd5de... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/230d0a85fb6d77d974d03c4e7ecdd5de... 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