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

Commits:

9 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
    ... ... @@ -32,6 +32,9 @@ import GHC.Hs
    32 32 
     import GHC.Hs.Syn.Type
    33 33 
     import GHC.Tc.Types.Evidence
    34 34 
     import GHC.Tc.Utils.Monad
    35 
    +
    36 
    +import GHC.Rename.Utils (wrapGenSpan)
    37 
    +
    35 38 
     import GHC.HsToCore.Pmc
    36 39 
     import GHC.HsToCore.Pmc.Utils
    37 40 
     import GHC.HsToCore.Types ( LdiNablas )
    ... ... @@ -164,6 +167,57 @@ applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
    164 167 
     un}mixes the equations], producing a list of equation-info
    165 168 
     blocks, each block having as its first column patterns compatible with each other.
    166 169
    170 
    +
    171 
    +Note [Grouping equations]
    172 
    +~~~~~~~~~~~~~~~~~~~~~~~~~
    173 
    +Given a bunch of equations, `groupEquations` makes groups of consecutive equations,
    174 
    +in which the first patern of each member of a group shares the same `PatGroup`
    175 
    +category.
    176 
    +   groupEquations :: [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
    177 
    +Generally, in each NonEmpty (PatGroup, EquationInfoNE) element of the result list,
    178 
    +all the PatGroup's will be the same (e.g. all PgCon or all PgAny). But see (GE1)
    179 
    +for an exception.
    180 
    +
    181 
    +We will match each group in turn, with failure falling through into the
    182 
    +next group.  For example
    183 
    +   f x           0 = ...  -- (E1)
    184 
    +   f !y          1 = ...  -- (E2)
    185 
    +   f y           2 = ...  -- (E3)
    186 
    +   f (Just True) _ = ...  -- (E4)
    187 
    +   f Nothing     _ = ...  -- (E5)
    188 
    +   f x           4 = ...  -- (E6)
    189 
    +   f _           5 = ...  -- (E7)
    190 
    +
    191 
    +The initial groups are
    192 
    +   [E1]
    193 
    +   [E2,E3, .. E7]
    194 
    +because the bang dominates all the the equations that follow; see (GE1) below.   Once we
    195 
    +get inside the bang we'll again do a `groupEquations` and get groups
    196 
    +   [E2,E3]   -- PgAny
    197 
    +   [E4,E5]   -- PgCon
    198 
    +   [E6,E6]   -- PgAny
    199 
    +
    200 
    +Wrinkles
    201 
    +
    202 
    +(GE1) A bang pattern captures all the equations that follow.  For example, given
    203 
    +    g !x   (p,True)  = ...(E1)...
    204 
    +    g x    (p,False) = ...(E2)...
    205 
    +    g True v         = ...(E3)...
    206 
    +  we want to get the (p,True) and (p,False) patterns in a single group so we can share
    207 
    +  the matching on the pair, and we can't do that if we make two groups for the top
    208 
    +  level match.  See #27862.  So we want these groups:
    209 
    +
    210 
    +       Group 1:   !x (p,True)  -> ..E1..
    211 
    +                  x  (p,False) -> ..E2..
    212 
    +
    213 
    +       Group 2:   True v       -> ..E3..
    214 
    +
    215 
    +  A consequence is that in a group with a `PgBang` category, such as Group 1 above,
    216 
    +  the second and subsequent equations may not be headed with a bang-pattern; indeed
    217 
    +  their PatGroup classifiers may differ from each other.  Hence in `matchBangs`, the
    218 
    +  function `getBangPat` is not surprised to see a non-bang pattern.
    219 
    +
    220 
    +(GE2) Overloaded literals: see Note [Grouping overloaded literal patterns]
    167 221 
     -}
    168 222
    169 223 
     match :: [MatchId]        -- ^ Variables rep\'ing the exprs we\'re matching with
    ... ... @@ -176,17 +230,25 @@ match [] ty eqns = maybe (assertPprPanic (ppr ty)) combineEqnRhss $ nonEmpty eqn
    176 230 
     match (v:vs) ty eqns    -- Eqns can be empty, but each equation is nonempty
    177 231 
       = assertPpr (all (isInternalName . idName . matchId) vars) (ppr vars) $
    178 232 
         do  { dflags <- getDynFlags
    233 
    +
    234 
    +        -- Tidy the first pattern, to remove unnecessary diversity,
    235 
    +        -- generating auxiliary bindings if necessary
    236 
    +        -- See Note [Tidying patterns]
    179 237 
             ; let platform = targetPlatform dflags
    180 
    -                -- Tidy the first pattern, generating
    181 
    -                -- auxiliary bindings if necessary
    182 238 
             ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
    183 
    -                -- Group the equations and match each group in turn
    184 
    -        ; let grouped = groupEquations platform tidy_eqns
    185 239
    186 
    -         -- print the view patterns that are commoned up to help debug
    187 
    -        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
    240 
    +        -- Group the equations and match each group in turn
    241 
    +        -- See Note [Grouping equations]
    242 
    +        ; let grouped ::  [NonEmpty (PatGroup, EquationInfoNE)]
    243 
    +              grouped = groupEquations platform tidy_eqns
    244 
    +
    245 
    +         -- Print the view patterns that are commoned up to help debug
    246 
    +        ; whenDOptM Opt_D_dump_view_pattern_commoning (debugViewPats grouped)
    188 247
    248 
    +        -- Match each group separately
    189 249 
             ; match_results <- match_groups grouped
    250 
    +
    251 
    +        -- And combine the results
    190 252 
             ; return $ foldr (.) id aux_binds <$>
    191 253 
                 foldr1 combineMatchResults match_results
    192 254 
             }
    ... ... @@ -197,10 +259,11 @@ match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty
    197 259 
         dropGroup = fmap snd
    198 260
    199 261 
         match_groups :: [NonEmpty (PatGroup,EquationInfoNE)] -> DsM (NonEmpty (MatchResult CoreExpr))
    200 
    -    match_groups [] = matchEmpty v ty
    262 
    +    match_groups []     = matchEmpty v ty
    201 263 
         match_groups (g:gs) = mapM match_group $ g :| gs
    202 264
    203 265 
         match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr)
    266 
    +    -- See Note [Grouping equations]
    204 267 
         match_group eqns@((group,_) :| _)
    205 268 
             = case group of
    206 269 
                 PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
    ... ... @@ -218,19 +281,23 @@ match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty
    218 281 
                   Just nel -> nel
    219 282 
                   Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"
    220 283
    221 
    -    -- FIXME: we should also warn about view patterns that should be
    222 
    -    -- commoned up but are not
    223 284
    224 
    -    -- print some stuff to see what's getting grouped
    225 
    -    -- use -dppr-debug to see the resolution of overloaded literals
    226 
    -    debug eqns =
    227 
    -        let gs = map (\group -> foldr (\ (p,_) -> \acc ->
    228 
    -                                           case p of PgView e _ -> e:acc
    229 
    -                                                     _ -> acc) [] group) eqns
    230 
    -            maybeWarn [] = return ()
    231 
    -            maybeWarn l  = diagnosticDs (DsAggregatedViewExpressions l)
    232 
    -        in
    233 
    -          maybeWarn $ filter (not . null) gs
    285 
    +debugViewPats :: [NonEmpty (PatGroup, EquationInfoNE)] -> DsM ()
    286 
    +-- print some stuff to see what's getting grouped
    287 
    +-- use -dppr-debug to see the resolution of overloaded literals
    288 
    +--
    289 
    +-- FIXME: we should also warn about view patterns that should be
    290 
    +-- commoned up but are not
    291 
    +debugViewPats eqns
    292 
    +  | null gs   = return ()
    293 
    +  | otherwise = diagnosticDs (DsAggregatedViewExpressions gs)
    294 
    +  where
    295 
    +    gs :: [[LHsExpr GhcTc]]
    296 
    +    gs = mapMaybe gather_views eqns
    297 
    +
    298 
    +    gather_views :: NonEmpty (PatGroup, EquationInfoNE) -> Maybe [LHsExpr GhcTc]
    299 
    +    gather_views ((PgView e _, _) :| vs) = Just (e : [ e' | (PgView e' _, _) <- vs ])
    300 
    +    gather_views _                       = Nothing
    234 301
    235 302 
     matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
    236 303 
     -- See Note [Empty case alternatives]
    ... ... @@ -246,6 +313,7 @@ matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (Ma
    246 313 
     matchVariables (_ :| vars) ty eqns = match vars ty $ NE.toList $ shiftEqns eqns
    247 314
    248 315 
     matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
    316 
    +-- See (GE1) in Note [Grouping equations]
    249 317 
     matchBangs (var :| vars) ty eqns
    250 318 
       = do  { match_result <- match (var:vars) ty $ NE.toList $
    251 319 
                 decomposeFirstPat getBangPat <$> eqns
    ... ... @@ -290,14 +358,20 @@ decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoN
    290 358 
     decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat}
    291 359 
     decomposeFirstPat _ (EqnDone {}) = panic "decomposeFirstPat"
    292 360
    293 
    -getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
    361 
    +getCoPat :: Pat GhcTc -> Pat GhcTc
    294 362 
     getCoPat (XPat (CoPat _ pat _)) = pat
    295 363 
     getCoPat _                   = panic "getCoPat"
    296 
    -getBangPat (BangPat _ pat  ) = unLoc pat
    297 
    -getBangPat _                 = panic "getBangPat"
    364 
    +
    365 
    +getViewPat :: Pat GhcTc -> Pat GhcTc
    298 366 
     getViewPat (TcViewPat _ pat) = pat
    299 367 
     getViewPat _                 = panic "getViewPat"
    300 368
    369 
    +getBangPat :: Pat GhcTc -> Pat GhcTc
    370 
    +-- See (GE1) in Note [Grouping equations]
    371 
    +getBangPat (BangPat _ pat  ) = unLoc pat
    372 
    +getBangPat pat               = pat
    373 
    +
    374 
    +
    301 375 
     -- | Use this pattern synonym to match on a 'ViewPat'.
    302 376 
     --
    303 377 
     -- N.B.: View patterns can occur inside HsExpansions.
    ... ... @@ -334,41 +408,46 @@ See also the "lifted case" discussion in Note [Case elimination] in GHC.Core.Opt
    334 408 
     *                                                                      *
    335 409 
     ************************************************************************
    336 410
    337 
    -Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
    338 
    -which will be scrutinised.
    339 
    -
    340 
    -This makes desugaring the pattern match simpler by transforming some of
    341 
    -the patterns to simpler forms. (Tuples to Constructor Patterns)
    411 
    +Note [Tidying patterns]
    412 
    +~~~~~~~~~~~~~~~~~~~~~~~
    413 
    +`tidyEqninfo` tidies up the leftmost pattern in an `EquationInfo`, given the
    414 
    +variable `v` which will be scrutinised. This makes desugaring the pattern match
    415 
    +simpler by transforming some of the patterns to simpler forms. (Tuples to
    416 
    +Constructor Patterns)
    342 417
    343 418 
     Among other things in the resulting Pattern:
    344 419 
     * Variables and irrefutable(lazy) patterns are replaced by Wildcards
    345 420 
     * As patterns are replaced by the patterns they wrap.
    346 421
    347 422 
     The bindings created by the above patterns are put into the returned wrapper
    348 
    -instead.
    349 
    -
    350 
    -This means a definition of the form:
    423 
    +instead.  This means a definition of the form:
    351 424 
       f x = rhs
    352 425 
     when called with v get's desugared to the equivalent of:
    353 426 
       let x = v
    354 427 
       in
    355 428 
       f _ = rhs
    356 429
    357 
    -The same principle holds for as patterns (@) and
    358 
    -irrefutable/lazy patterns (~).
    359 
    -In the case of irrefutable patterns the irrefutable pattern is pushed into
    360 
    -the binding.
    430 
    +The same principle holds for as patterns (@) and irrefutable/lazy patterns (~).  In
    431 
    +the case of irrefutable patterns the irrefutable pattern is pushed into the binding.
    361 432
    362 
    -Pattern Constructors which only represent syntactic sugar are converted into
    363 
    -their desugared representation.
    364 
    -This usually means converting them to Constructor patterns but for some
    365 
    -depends on enabled extensions. (Eg OverloadedLists)
    433 
    +Pattern Constructors which only represent syntactic sugar are converted into their
    434 
    +desugared representation.  This usually means converting them to Constructor
    435 
    +patterns but for some depends on enabled extensions. (Eg OverloadedLists)
    366 436
    367 437 
     GHC also tries to convert overloaded Literals into regular ones.
    368 438
    369 439 
     The result of this tidying is that the column of patterns will include
    370 440 
     only these which can be assigned a PatternGroup (see patGroup).
    371 441
    442 
    +(TP1) We may call `tidyPat` on the same pattern more than once, principally because
    443 
    +   of the treatment of bang-patterns; see (GE1) in Note [Grouping equations].
    444 
    +   So (slightly hackily) we wrap tidied patterns in GeneratedSrcSpan to signal this.
    445 
    +   See `wrapGenSpan` in `tidyLPat`.
    446 
    +
    447 
    +(TP2) Tidying is a convenient place to warn about overflowed literal values. We
    448 
    +  can't do it in the typechecker because the types are not settled.  See the
    449 
    +  `tidyPat1` equations for `LitPat`, `NPat`, `NPlusKPat`.  But we only want to
    450 
    +  want /once/; hence the `unlessInGenCode` check, in turn relying on (TP1).
    372 451 
     -}
    373 452
    374 453 
     tidyEqnInfo :: MatchId -> EquationInfo
    ... ... @@ -383,14 +462,19 @@ tidyEqnInfo :: MatchId -> EquationInfo
    383 462
    384 463 
     tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn)
    385 464
    386 
    -tidyEqnInfo v eqn@(EqnMatch { eqn_pat = p@(L loc _) }) = do
    387 
    -  (wrap, pat') <- tidyLPat v p
    388 
    -  return (wrap, eqn{eqn_pat = L loc pat' })
    465 
    +tidyEqnInfo v eqn@(EqnMatch { eqn_pat = pat })
    466 
    +  = do { (wrap, pat') <- tidyLPat v pat
    467 
    +         -- Always return a patten wrapped in `generatedSrcSpan`,
    468 
    +         -- which simply records that this pattern has been tidied,
    469 
    +         -- and perhaps transformed from its original source form
    470 
    +         -- See (TP1) in Note [Tidying patterns]
    471 
    +       ; return (wrap, eqn{ eqn_pat =  wrapGenSpan pat' }) }
    389 472
    390 473 
     tidyLPat :: MatchId -> LPat GhcTc -> DsM (DsWrapper, Pat GhcTc)
    391 
    -tidyLPat v (L loc pat) = putSrcSpanDsA loc (tidy1 v pat)
    474 
    +tidyLPat v (L loc pat) = tidy1 v loc pat
    392 475
    393 476 
     tidy1 :: MatchId             -- The scrutinee
    477 
    +      -> SrcSpanAnnA
    394 478 
           -> Pat GhcTc           -- The pattern against which it is to be matched
    395 479 
           -> DsM (DsWrapper,     -- Extra bindings to do before the match
    396 480 
                   Pat GhcTc)     -- Equivalent pattern
    ... ... @@ -401,21 +485,20 @@ tidy1 :: MatchId -- The scrutinee
    401 485 
     -- It eliminates many pattern forms (as-patterns, variable patterns,
    402 486 
     -- list patterns, etc) and returns any created bindings in the wrapper.
    403 487
    404 
    -tidy1 v (ParPat _ pat)        = tidyLPat v pat
    405 
    -tidy1 v (SigPat _ pat _)      = tidyLPat v pat
    406 
    -tidy1 _ (WildPat ty)          = return (idDsWrapper, WildPat ty)
    407 
    -tidy1 v (BangPat _ (L l p))   = putSrcSpanDsA l $ tidy_bang_pat v l p
    408 
    -tidy1 v (ModifiedPat _ _ pat) = tidyLPat v pat
    488 
    +tidy1 v _ (ParPat _ pat)        = tidyLPat v pat
    489 
    +tidy1 v _ (SigPat _ pat _)      = tidyLPat v pat
    490 
    +tidy1 _ _ (WildPat ty)          = return (idDsWrapper, WildPat ty)
    491 
    +tidy1 v _ (BangPat _ (L l p))   = tidy_bang_pat v l p
    492 
    +tidy1 v _ (ModifiedPat _ _ pat) = tidyLPat v pat
    409 493
    410 494 
             -- case v of { x -> mr[] }
    411 495 
             -- = case v of { _ -> let x=v in mr[] }
    412 
    -tidy1 v (VarPat _ (L _ var))
    496 
    +tidy1 v _ (VarPat _ (L _ var))
    413 497 
       = return (bindMatchId var v, WildPat (idType var))
    414 498
    415 499 
             -- case v of { x@p -> mr[] }
    416 500 
             -- = case v of { p -> let x=v in mr[] }
    417 
    -tidy1 v (AsPat _ (L _ var) pat)
    418 
    -
    501 
    +tidy1 v _ (AsPat _ (L _ var) pat)
    419 502 
       = do  { (wrap, pat') <- tidyLPat v pat
    420 503 
             ; return (bindMatchId var v . wrap, pat') }
    421 504
    ... ... @@ -430,28 +513,30 @@ tidy1 v (AsPat _ (L _ var) pat)
    430 513 
         The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
    431 514 
     -}
    432 515
    433 
    -tidy1 v (LazyPat _ pat)
    516 
    +tidy1 v loc (LazyPat _ lpat)
    434 517 
         -- This is a convenient place to check for unlifted types under a lazy pattern.
    435 518 
         -- Doing this check during type-checking is unsatisfactory because we may
    436 519 
         -- not fully know the zonked types yet. We sure do here.
    437 
    -  = putSrcSpanDs (getLocA pat) $
    438 
    -    do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)
    439 
    -            -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType
    520 
    +  = putSrcSpanDsA loc $
    521 
    +    do  { let unlifted_bndrs = filter (isUnliftedType . idType) $
    522 
    +                               collectPatBinders CollNoDictBinders lpat
    523 
    +            -- NB: the binders can't be representation-polymorphic,
    524 
    +            --     so we're OK to call isUnliftedType
    440 525 
             ; unless (null unlifted_bndrs) $
    441 526 
               diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)
    442 527
    443 
    -        ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (matchIdExpr v)
    528 
    +        ; (_,sel_prs) <- mkSelectorBinds [] lpat LazyPatCtx (matchIdExpr v)
    444 529 
             ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
    445 530 
             ; return (mkCoreLets sel_binds, WildPat (matchIdType v)) }
    446 531
    447 
    -tidy1 _ (ListPat ty pats)
    532 
    +tidy1 _ _ (ListPat ty pats)
    448 533 
       = return (idDsWrapper, unLoc list_ConPat)
    449 534 
       where
    450 535 
         list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
    451 536 
                             (mkNilPat ty)
    452 537 
                             pats
    453 538
    454 
    -tidy1 _ (TuplePat tys pats boxity)
    539 
    +tidy1 _ _ (TuplePat tys pats boxity)
    455 540 
       = return (idDsWrapper, unLoc tuple_ConPat)
    456 541 
       where
    457 542 
         arity = length pats
    ... ... @@ -461,45 +546,46 @@ tidy1 _ (TuplePat tys pats boxity)
    461 546 
                  Boxed   -> tys
    462 547 
                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
    463 548
    464 
    -tidy1 _ (SumPat tys pat alt arity)
    549 
    +tidy1 _ _ (SumPat tys pat alt arity)
    465 550 
       = return (idDsWrapper, unLoc sum_ConPat)
    466 551 
       where
    467 552 
         sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)
    468 553 
                      -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
    469 554
    470 555 
     -- LitPats: we *might* be able to replace these w/ a simpler form
    471 
    -tidy1 _ (LitPat _ lit)
    472 
    -  = do { in_gen <- inGeneratedCodeDs;
    473 
    -         unless in_gen $
    474 
    -           warnAboutOverflowedLit lit
    556 
    +tidy1 _ loc (LitPat _ lit)
    557 
    +  = do { unlessInGenCode loc $ warnAboutOverflowedLit lit
    558 
    +            -- Overflow warnings: see (TP2) in Note [Tidying patterns]
    475 559 
            ; return (idDsWrapper, tidyLitPat lit) }
    476 560
    477 561 
     -- NPats: we *might* be able to replace these w/ a simpler form
    478 
    -tidy1 _ (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
    479 
    -  = do { in_gen <- inGeneratedCodeDs;
    480 
    -         unless in_gen $
    481 
    -           let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
    482 
    -                    | otherwise = lit
    483 
    -           in warnAboutOverflowedOverLit lit'
    562 
    +tidy1 _ loc (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
    563 
    +  = do { unlessInGenCode loc $ warnAboutOverflowedOverLit lit'
    564 
    +            -- Overflow warnings: see (TP2) in Note [Tidying patterns]
    484 565 
            ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
    566 
    +  where
    567 
    +    lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
    568 
    +         | otherwise        = lit
    485 569
    486 570 
     -- NPlusKPat: we may want to warn about the literals
    487 
    -tidy1 _ n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
    488 
    -  = do { in_gen <- inGeneratedCodeDs;
    489 
    -         unless in_gen $ do
    490 
    -           warnAboutOverflowedOverLit lit1
    491 
    -           warnAboutOverflowedOverLit lit2
    571 
    +tidy1 _ loc n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
    572 
    +  = do { unlessInGenCode loc $
    573 
    +         do { warnAboutOverflowedOverLit lit1
    574 
    +            ; warnAboutOverflowedOverLit lit2 }
    575 
    +            -- Overflow warnings: see (TP2) in Note [Tidying patterns]
    492 576 
            ; return (idDsWrapper, n) }
    493 577
    494 
    -tidy1 _ (OrPat ty lpats)
    578 
    +tidy1 _ _ (OrPat ty lpats)
    495 579 
       -- See Note [Implementation of OrPatterns]. We desugar
    496 580 
       --   (1; 2; 3)
    497 581 
       -- to
    498 582 
       --   ((\case 1 -> True; 2 -> True; 3 -> True; _ -> False) -> True)
    499 
    -  = return (idDsWrapper, ViewPat ty (noLocA (HsLam noAnn LamCase mg)) (mkPrefixConPat trueDataCon [] []))
    583 
    +  = return (idDsWrapper, ViewPat ty (noLocA (HsLam noAnn LamCase mg))
    584 
    +                                    (mkPrefixConPat trueDataCon [] []))
    500 585 
       where
    501 586 
         mg :: MatchGroup GhcTc (LHsExpr GhcTc)
    502 
    -    mg = MG mgtc (noLocA (map match_true (NE.toList lpats) ++ [match_false (noLocA $ WildPat ty)]))
    587 
    +    mg = MG mgtc (noLocA (map match_true (NE.toList lpats)
    588 
    +                          ++ [match_false (noLocA $ WildPat ty)]))
    503 589 
         mgtc = MatchGroupTc
    504 590 
            { mg_arg_tys = [tymult ty]
    505 591 
            , mg_res_ty = boolTy
    ... ... @@ -520,31 +606,38 @@ tidy1 _ (OrPat ty lpats)
    520 606 
         single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField)
    521 607
    522 608 
     -- Everything else goes through unchanged...
    523 
    -tidy1 _ non_interesting_pat
    609 
    +tidy1 _ _ non_interesting_pat
    524 610 
       = return (idDsWrapper, non_interesting_pat)
    525 611
    526 612 
     --------------------
    527 613 
     tidy_bang_pat :: MatchId -> SrcSpanAnnA -> Pat GhcTc
    528 614 
                   -> DsM (DsWrapper, Pat GhcTc)
    529 615
    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
    616 
    +-- Push the bang-pattern inwards, in the hope that it may disappear next time
    617 
    +--   AsPat  !(x@p)     -->  x@(!p)
    618 
    +--   CoPat  !(p |> co) -->  (!p) |> co
    619 
    +--   OrPat  !(p || q)  -->  (!p || !q)
    536 620 
     tidy_bang_pat v l (AsPat x v' p)
    537 
    -  = tidy1 v (AsPat x v' (L l (BangPat noExtField p)))
    621 
    +  = tidy1 v l (AsPat x v' (L l (BangPat noExtField p)))
    538 622 
     tidy_bang_pat v l (XPat (CoPat w p t))
    539 
    -  = tidy1 v (XPat $ CoPat w (BangPat noExtField (L l p)) t)
    623 
    +  = tidy1 v l (XPat $ CoPat w (BangPat noExtField (L l p)) t)
    540 624 
     tidy_bang_pat v l (OrPat x (p:|ps)) -- push bang into first pat alt
    541 
    -  = tidy1 v (OrPat x (L l (BangPat noExtField p) :| ps))
    625 
    +  = tidy1 v l (OrPat x (L l (BangPat noExtField p) :| ps))
    626 
    +
    627 
    +-- Discard par/sig/bang under a bang
    628 
    +--    !(p)      -->   !p
    629 
    +--    !(p::ty)  -->   !p
    630 
    +--    !(!p)     -->   !p
    631 
    +tidy_bang_pat v _ (ParPat _ (L l p))   = tidy_bang_pat v l p
    632 
    +tidy_bang_pat v _ (SigPat _ (L l p) _) = tidy_bang_pat v l p
    633 
    +tidy_bang_pat v _ (BangPat _ (L l p))  = tidy_bang_pat v l p
    542 634
    543 635 
     -- Discard bang around strict pattern
    544 
    -tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
    545 
    -tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
    546 
    -tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
    547 
    -tidy_bang_pat v _ p@(SumPat {})    = tidy1 v p
    636 
    +--    e.g.  !(Just p)  -->  Just p
    637 
    +tidy_bang_pat v l p@(LitPat {})    = tidy1 v l p
    638 
    +tidy_bang_pat v l p@(ListPat {})   = tidy1 v l p
    639 
    +tidy_bang_pat v l p@(TuplePat {})  = tidy1 v l p
    640 
    +tidy_bang_pat v l p@(SumPat {})    = tidy1 v l p
    548 641
    549 642 
     -- Data/newtype constructors
    550 643 
     tidy_bang_pat v l p@(ConPat { pat_con = L _ (RealDataCon dc)
    ... ... @@ -554,12 +647,13 @@ tidy_bang_pat v l p@(ConPat { pat_con = L _ (RealDataCon dc)
    554 647 
                                   }
    555 648 
                                 })
    556 649 
       -- 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
    650 
    +  | isNewTyCon (dataConTyCon dc)
    651 
    +  , (ty:_) <- dataConInstArgTys dc arg_tys
    652 
    +  = tidy1 v l (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
    653 
    +
    654 
    +  -- Discard bang around non-newtype data constructors
    655 
    +  | otherwise
    656 
    +  = tidy1 v l p
    563 657
    564 658 
     -------------------
    565 659 
     -- Default case, leave the bang there:
    ... ... @@ -1033,14 +1127,25 @@ for overloaded strings.
    1033 1127 
     groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
    1034 1128 
     -- If the result is of form [g1, g2, g3],
    1035 1129 
     -- (a) all the (pg,eq) pairs in g1 have the same pg
    1130 
    +--     with the exception documented in (GE1) of Note [Grouping equations]
    1036 1131 
     -- (b) none of the gi are empty
    1037 1132 
     -- The ordering of equations is unchanged
    1038 1133 
     groupEquations platform eqns
    1039 
    -  = NE.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
    1040 
    -  -- comprehension on NonEmpty
    1134 
    +  = group_eqns $ map add_gp eqns
    1041 1135 
       where
    1042 
    -    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
    1043 
    -    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
    1136 
    +    add_gp :: EquationInfoNE -> (PatGroup, EquationInfoNE)
    1137 
    +    add_gp eqn = (patGroup platform (firstPat eqn), eqn)
    1138 
    +
    1139 
    +    group_eqns :: [(PatGroup,EquationInfoNE)] -> [NonEmpty (PatGroup, EquationInfoNE)]
    1140 
    +    -- See Note [Grouping equations]
    1141 
    +    group_eqns [] = []
    1142 
    +    group_eqns ((PgBang,e) : pges) = [ (PgBang,e) :| pges ]  -- See (GE1)
    1143 
    +    group_eqns ((pg1,e)    : pges) = ((pg1,e) :| pges1) : group_eqns pges2
    1144 
    +      where
    1145 
    +        (pges1, pges2) = span same_gp pges
    1146 
    +
    1147 
    +        same_gp :: (PatGroup,EquationInfo) -> Bool
    1148 
    +        same_gp (pg2,_) = pg1 `sameGroup` pg2
    1044 1149
    1045 1150 
     -- TODO Make subGroup1 using a NonEmptyMap
    1046 1151 
     subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems

  • compiler/GHC/HsToCore/Match/Literal.hs
    ... ... @@ -581,8 +581,9 @@ tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty
    581 581
    582 582 
         mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
    583 583 
         mk_con_pat con lit
    584 
    -      -- Mark the generated literal to avoid duplicate -Woverflowed-literals.
    585 584 
           = unLoc (mkPrefixConPat con [wrapGenSpan $ LitPat noExtField lit] [])
    585 
    +        -- wrapGenSpan: mark the generated literal to avoid duplicate
    586 
    +        -- -Woverflowed-literals. See (TP2) in Note [Tidying patterns]
    586 587
    587 588 
         mb_int_lit :: Maybe Integer
    588 589 
         mb_int_lit = case (mb_neg, val) of

  • compiler/GHC/HsToCore/Monad.hs
    ... ... @@ -16,7 +16,7 @@ module GHC.HsToCore.Monad (
    16 16 
             newSysLocalMDs, newSysLocalsMDs, newFailLocalMDs,
    17 17 
             newUniqueId, newPredVarDs, newStaticId,
    18 18 
             getSrcSpanDs, inGeneratedCodeDs, putSrcSpanDs, putSrcSpanDsA,
    19 
    -        mkNamePprCtxDs,
    19 
    +        unlessInGenCode, mkNamePprCtxDs,
    20 20 
             newUnique,
    21 21 
             UniqSupply, newUniqueSupply,
    22 22 
             getGhcModeDs, dsGetFamInstEnvs, dsGetGlobalRdrEnv,
    ... ... @@ -151,7 +151,7 @@ data EquationInfo
    151 151 
       = EqnMatch  { eqn_pat :: LPat GhcTc
    152 152 
                     -- ^ The first pattern of the equation
    153 153 
                     --
    154 
    -                -- NB: The location info is used to determine whether the
    154 
    +                -- NB: The location info is used only to determine whether the
    155 155 
                     -- pattern is generated or not.
    156 156 
                     -- This helps us avoid warnings on patterns that GHC elaborated.
    157 157 
                     --
    ... ... @@ -681,6 +681,11 @@ getSrcSpanDs = do { env <- getLclEnv
    681 681 
     inGeneratedCodeDs :: DsM Bool
    682 682 
     inGeneratedCodeDs = dsl_in_generated_code <$> getLclEnv
    683 683
    684 
    +unlessInGenCode :: EpAnn ann -> DsM () -> DsM ()
    685 
    +unlessInGenCode span do_warn
    686 
    +  | isGeneratedSrcSpan (locA span) = return ()
    687 
    +  | otherwise                      = do_warn
    688 
    +
    684 689 
     putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
    685 690 
     putSrcSpanDs (RealSrcSpan real_span _) thing_inside
    686 691 
       = updLclEnv (\ env -> env {dsl_loc = real_span, dsl_in_generated_code = False}) thing_inside

  • 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/T27862a.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    2 
    +{-# OPTIONS_GHC -Woverflowed-literals #-}
    3 
    +
    4 
    +-- We expect only /one/ warning
    5 
    +
    6 
    +module T27862a where
    7 
    +
    8 
    +import Data.Word
    9 
    +
    10 
    +f :: Word8 -> Int
    11 
    +f !x | even x = 0
    12 
    +f 300 = 1
    13 
    +f _   = 2

  • testsuite/tests/deSugar/should_compile/T27862a.stderr
    1 
    +T27862a.hs:11:1: warning: [GHC-97441] [-Woverflowed-literals (in -Wdefault)]
    2 
    +    Literal 300 is out of the Word8 range 0..255
    3 
    +

  • testsuite/tests/deSugar/should_compile/all.T
    ... ... @@ -121,3 +121,9 @@ 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'])
    129 
    +test('T27862a', normal, compile, [''])

    • —
    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/c8a42812606982e5663198a034357c990bd47430 at 1793660061