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,E7]   -- 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,21 @@ 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] for why it's expected
    371 
    +-- that `getBangPat` may return a non-bang pattern.
    372 
    +getBangPat (BangPat _ pat  ) = unLoc pat
    373 
    +getBangPat pat               = pat
    374 
    +
    375 
    +
    301 376 
     -- | Use this pattern synonym to match on a 'ViewPat'.
    302 377 
     --
    303 378 
     -- N.B.: View patterns can occur inside HsExpansions.
    ... ... @@ -334,41 +409,46 @@ See also the "lifted case" discussion in Note [Case elimination] in GHC.Core.Opt
    334 409 
     *                                                                      *
    335 410 
     ************************************************************************
    336 411
    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)
    412 
    +Note [Tidying patterns]
    413 
    +~~~~~~~~~~~~~~~~~~~~~~~
    414 
    +`tidyEqninfo` tidies up the leftmost pattern in an `EquationInfo`, given the
    415 
    +variable `v` which will be scrutinised. This makes desugaring the pattern match
    416 
    +simpler by transforming some of the patterns to simpler forms. (Tuples to
    417 
    +Constructor Patterns)
    342 418
    343 419 
     Among other things in the resulting Pattern:
    344 420 
     * Variables and irrefutable(lazy) patterns are replaced by Wildcards
    345 421 
     * As patterns are replaced by the patterns they wrap.
    346 422
    347 423 
     The bindings created by the above patterns are put into the returned wrapper
    348 
    -instead.
    349 
    -
    350 
    -This means a definition of the form:
    424 
    +instead.  This means a definition of the form:
    351 425 
       f x = rhs
    352 426 
     when called with v get's desugared to the equivalent of:
    353 427 
       let x = v
    354 428 
       in
    355 429 
       f _ = rhs
    356 430
    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.
    431 
    +The same principle holds for as patterns (@) and irrefutable/lazy patterns (~).  In
    432 
    +the case of irrefutable patterns the irrefutable pattern is pushed into the binding.
    361 433
    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)
    434 
    +Pattern Constructors which only represent syntactic sugar are converted into their
    435 
    +desugared representation.  This usually means converting them to Constructor
    436 
    +patterns but for some depends on enabled extensions. (Eg OverloadedLists)
    366 437
    367 438 
     GHC also tries to convert overloaded Literals into regular ones.
    368 439
    369 440 
     The result of this tidying is that the column of patterns will include
    370 441 
     only these which can be assigned a PatternGroup (see patGroup).
    371 442
    443 
    +(TP1) We may call `tidyPat` on the same pattern more than once, principally because
    444 
    +   of the treatment of bang-patterns; see (GE1) in Note [Grouping equations].
    445 
    +   So (slightly hackily) we wrap tidied patterns in GeneratedSrcSpan to signal this.
    446 
    +   See `wrapGenSpan` in `tidyLPat`.
    447 
    +
    448 
    +(TP2) Tidying is a convenient place to warn about overflowed literal values. We
    449 
    +  can't do it in the typechecker because the types are not settled.  See the
    450 
    +  `tidyPat1` equations for `LitPat`, `NPat`, `NPlusKPat`.  But we only want to
    451 
    +  want /once/; hence the `unlessInGenCode` check, in turn relying on (TP1).
    372 452 
     -}
    373 453
    374 454 
     tidyEqnInfo :: MatchId -> EquationInfo
    ... ... @@ -383,14 +463,19 @@ tidyEqnInfo :: MatchId -> EquationInfo
    383 463
    384 464 
     tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn)
    385 465
    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' })
    466 
    +tidyEqnInfo v eqn@(EqnMatch { eqn_pat = pat })
    467 
    +  = do { (wrap, pat') <- tidyLPat v pat
    468 
    +         -- Always return a patten wrapped in `generatedSrcSpan`,
    469 
    +         -- which simply records that this pattern has been tidied,
    470 
    +         -- and perhaps transformed from its original source form
    471 
    +         -- See (TP1) in Note [Tidying patterns]
    472 
    +       ; return (wrap, eqn{ eqn_pat =  wrapGenSpan pat' }) }
    389 473
    390 474 
     tidyLPat :: MatchId -> LPat GhcTc -> DsM (DsWrapper, Pat GhcTc)
    391 
    -tidyLPat v (L loc pat) = putSrcSpanDsA loc (tidy1 v pat)
    475 
    +tidyLPat v (L loc pat) = tidy1 v loc pat
    392 476
    393 477 
     tidy1 :: MatchId             -- The scrutinee
    478 
    +      -> SrcSpanAnnA
    394 479 
           -> Pat GhcTc           -- The pattern against which it is to be matched
    395 480 
           -> DsM (DsWrapper,     -- Extra bindings to do before the match
    396 481 
                   Pat GhcTc)     -- Equivalent pattern
    ... ... @@ -401,21 +486,20 @@ tidy1 :: MatchId -- The scrutinee
    401 486 
     -- It eliminates many pattern forms (as-patterns, variable patterns,
    402 487 
     -- list patterns, etc) and returns any created bindings in the wrapper.
    403 488
    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
    489 
    +tidy1 v _ (ParPat _ pat)        = tidyLPat v pat
    490 
    +tidy1 v _ (SigPat _ pat _)      = tidyLPat v pat
    491 
    +tidy1 _ _ (WildPat ty)          = return (idDsWrapper, WildPat ty)
    492 
    +tidy1 v _ (BangPat _ (L l p))   = tidy_bang_pat v l p
    493 
    +tidy1 v _ (ModifiedPat _ _ pat) = tidyLPat v pat
    409 494
    410 495 
             -- case v of { x -> mr[] }
    411 496 
             -- = case v of { _ -> let x=v in mr[] }
    412 
    -tidy1 v (VarPat _ (L _ var))
    497 
    +tidy1 v _ (VarPat _ (L _ var))
    413 498 
       = return (bindMatchId var v, WildPat (idType var))
    414 499
    415 500 
             -- case v of { x@p -> mr[] }
    416 501 
             -- = case v of { p -> let x=v in mr[] }
    417 
    -tidy1 v (AsPat _ (L _ var) pat)
    418 
    -
    502 
    +tidy1 v _ (AsPat _ (L _ var) pat)
    419 503 
       = do  { (wrap, pat') <- tidyLPat v pat
    420 504 
             ; return (bindMatchId var v . wrap, pat') }
    421 505
    ... ... @@ -430,28 +514,30 @@ tidy1 v (AsPat _ (L _ var) pat)
    430 514 
         The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
    431 515 
     -}
    432 516
    433 
    -tidy1 v (LazyPat _ pat)
    517 
    +tidy1 v loc (LazyPat _ lpat)
    434 518 
         -- This is a convenient place to check for unlifted types under a lazy pattern.
    435 519 
         -- Doing this check during type-checking is unsatisfactory because we may
    436 520 
         -- 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
    521 
    +  = putSrcSpanDsA loc $
    522 
    +    do  { let unlifted_bndrs = filter (isUnliftedType . idType) $
    523 
    +                               collectPatBinders CollNoDictBinders lpat
    524 
    +            -- NB: the binders can't be representation-polymorphic,
    525 
    +            --     so we're OK to call isUnliftedType
    440 526 
             ; unless (null unlifted_bndrs) $
    441 527 
               diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)
    442 528
    443 
    -        ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (matchIdExpr v)
    529 
    +        ; (_,sel_prs) <- mkSelectorBinds [] lpat LazyPatCtx (matchIdExpr v)
    444 530 
             ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
    445 531 
             ; return (mkCoreLets sel_binds, WildPat (matchIdType v)) }
    446 532
    447 
    -tidy1 _ (ListPat ty pats)
    533 
    +tidy1 _ _ (ListPat ty pats)
    448 534 
       = return (idDsWrapper, unLoc list_ConPat)
    449 535 
       where
    450 536 
         list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
    451 537 
                             (mkNilPat ty)
    452 538 
                             pats
    453 539
    454 
    -tidy1 _ (TuplePat tys pats boxity)
    540 
    +tidy1 _ _ (TuplePat tys pats boxity)
    455 541 
       = return (idDsWrapper, unLoc tuple_ConPat)
    456 542 
       where
    457 543 
         arity = length pats
    ... ... @@ -461,45 +547,46 @@ tidy1 _ (TuplePat tys pats boxity)
    461 547 
                  Boxed   -> tys
    462 548 
                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
    463 549
    464 
    -tidy1 _ (SumPat tys pat alt arity)
    550 
    +tidy1 _ _ (SumPat tys pat alt arity)
    465 551 
       = return (idDsWrapper, unLoc sum_ConPat)
    466 552 
       where
    467 553 
         sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)
    468 554 
                      -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
    469 555
    470 556 
     -- 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
    557 
    +tidy1 _ loc (LitPat _ lit)
    558 
    +  = do { unlessInGenCode loc $ warnAboutOverflowedLit lit
    559 
    +            -- Overflow warnings: see (TP2) in Note [Tidying patterns]
    475 560 
            ; return (idDsWrapper, tidyLitPat lit) }
    476 561
    477 562 
     -- 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'
    563 
    +tidy1 _ loc (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
    564 
    +  = do { unlessInGenCode loc $ warnAboutOverflowedOverLit lit'
    565 
    +            -- Overflow warnings: see (TP2) in Note [Tidying patterns]
    484 566 
            ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
    567 
    +  where
    568 
    +    lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
    569 
    +         | otherwise        = lit
    485 570
    486 571 
     -- 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
    572 
    +tidy1 _ loc n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
    573 
    +  = do { unlessInGenCode loc $
    574 
    +         do { warnAboutOverflowedOverLit lit1
    575 
    +            ; warnAboutOverflowedOverLit lit2 }
    576 
    +            -- Overflow warnings: see (TP2) in Note [Tidying patterns]
    492 577 
            ; return (idDsWrapper, n) }
    493 578
    494 
    -tidy1 _ (OrPat ty lpats)
    579 
    +tidy1 _ _ (OrPat ty lpats)
    495 580 
       -- See Note [Implementation of OrPatterns]. We desugar
    496 581 
       --   (1; 2; 3)
    497 582 
       -- to
    498 583 
       --   ((\case 1 -> True; 2 -> True; 3 -> True; _ -> False) -> True)
    499 
    -  = return (idDsWrapper, ViewPat ty (noLocA (HsLam noAnn LamCase mg)) (mkPrefixConPat trueDataCon [] []))
    584 
    +  = return (idDsWrapper, ViewPat ty (noLocA (HsLam noAnn LamCase mg))
    585 
    +                                    (mkPrefixConPat trueDataCon [] []))
    500 586 
       where
    501 587 
         mg :: MatchGroup GhcTc (LHsExpr GhcTc)
    502 
    -    mg = MG mgtc (noLocA (map match_true (NE.toList lpats) ++ [match_false (noLocA $ WildPat ty)]))
    588 
    +    mg = MG mgtc (noLocA (map match_true (NE.toList lpats)
    589 
    +                          ++ [match_false (noLocA $ WildPat ty)]))
    503 590 
         mgtc = MatchGroupTc
    504 591 
            { mg_arg_tys = [tymult ty]
    505 592 
            , mg_res_ty = boolTy
    ... ... @@ -520,31 +607,38 @@ tidy1 _ (OrPat ty lpats)
    520 607 
         single_grhs e = GRHSs emptyComments [noLocA $ GRHS noAnn [] e] (EmptyLocalBinds noExtField)
    521 608
    522 609 
     -- Everything else goes through unchanged...
    523 
    -tidy1 _ non_interesting_pat
    610 
    +tidy1 _ _ non_interesting_pat
    524 611 
       = return (idDsWrapper, non_interesting_pat)
    525 612
    526 613 
     --------------------
    527 614 
     tidy_bang_pat :: MatchId -> SrcSpanAnnA -> Pat GhcTc
    528 615 
                   -> DsM (DsWrapper, Pat GhcTc)
    529 616
    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
    617 
    +-- Push the bang-pattern inwards, in the hope that it may disappear next time
    618 
    +--   AsPat  !(x@p)     -->  x@(!p)
    619 
    +--   CoPat  !(p |> co) -->  (!p) |> co
    620 
    +--   OrPat  !(p || q)  -->  (!p || !q)
    536 621 
     tidy_bang_pat v l (AsPat x v' p)
    537 
    -  = tidy1 v (AsPat x v' (L l (BangPat noExtField p)))
    622 
    +  = tidy1 v l (AsPat x v' (L l (BangPat noExtField p)))
    538 623 
     tidy_bang_pat v l (XPat (CoPat w p t))
    539 
    -  = tidy1 v (XPat $ CoPat w (BangPat noExtField (L l p)) t)
    624 
    +  = tidy1 v l (XPat $ CoPat w (BangPat noExtField (L l p)) t)
    540 625 
     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))
    626 
    +  = tidy1 v l (OrPat x (L l (BangPat noExtField p) :| ps))
    627 
    +
    628 
    +-- Discard par/sig/bang under a bang
    629 
    +--    !(p)      -->   !p
    630 
    +--    !(p::ty)  -->   !p
    631 
    +--    !(!p)     -->   !p
    632 
    +tidy_bang_pat v _ (ParPat _ (L l p))   = tidy_bang_pat v l p
    633 
    +tidy_bang_pat v _ (SigPat _ (L l p) _) = tidy_bang_pat v l p
    634 
    +tidy_bang_pat v _ (BangPat _ (L l p))  = tidy_bang_pat v l p
    542 635
    543 636 
     -- 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
    637 
    +--    e.g.  !(Just p)  -->  Just p
    638 
    +tidy_bang_pat v l p@(LitPat {})    = tidy1 v l p
    639 
    +tidy_bang_pat v l p@(ListPat {})   = tidy1 v l p
    640 
    +tidy_bang_pat v l p@(TuplePat {})  = tidy1 v l p
    641 
    +tidy_bang_pat v l p@(SumPat {})    = tidy1 v l p
    548 642
    549 643 
     -- Data/newtype constructors
    550 644 
     tidy_bang_pat v l p@(ConPat { pat_con = L _ (RealDataCon dc)
    ... ... @@ -554,12 +648,13 @@ tidy_bang_pat v l p@(ConPat { pat_con = L _ (RealDataCon dc)
    554 648 
                                   }
    555 649 
                                 })
    556 650 
       -- 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
    651 
    +  | isNewTyCon (dataConTyCon dc)
    652 
    +  , (ty:_) <- dataConInstArgTys dc arg_tys
    653 
    +  = tidy1 v l (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
    654 
    +
    655 
    +  -- Discard bang around non-newtype data constructors
    656 
    +  | otherwise
    657 
    +  = tidy1 v l p
    563 658
    564 659 
     -------------------
    565 660 
     -- Default case, leave the bang there:
    ... ... @@ -1033,14 +1128,25 @@ for overloaded strings.
    1033 1128 
     groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)]
    1034 1129 
     -- If the result is of form [g1, g2, g3],
    1035 1130 
     -- (a) all the (pg,eq) pairs in g1 have the same pg
    1131 
    +--     with the exception documented in (GE1) of Note [Grouping equations]
    1036 1132 
     -- (b) none of the gi are empty
    1037 1133 
     -- The ordering of equations is unchanged
    1038 1134 
     groupEquations platform eqns
    1039 
    -  = NE.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
    1040 
    -  -- comprehension on NonEmpty
    1135 
    +  = group_eqns $ map add_gp eqns
    1041 1136 
       where
    1042 
    -    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
    1043 
    -    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
    1137 
    +    add_gp :: EquationInfoNE -> (PatGroup, EquationInfoNE)
    1138 
    +    add_gp eqn = (patGroup platform (firstPat eqn), eqn)
    1139 
    +
    1140 
    +    group_eqns :: [(PatGroup,EquationInfoNE)] -> [NonEmpty (PatGroup, EquationInfoNE)]
    1141 
    +    -- See Note [Grouping equations]
    1142 
    +    group_eqns [] = []
    1143 
    +    group_eqns ((PgBang,e) : pges) = [ (PgBang,e) :| pges ]  -- See (GE1)
    1144 
    +    group_eqns ((pg1,e)    : pges) = ((pg1,e) :| pges1) : group_eqns pges2
    1145 
    +      where
    1146 
    +        (pges1, pges2) = span same_gp pges
    1147 
    +
    1148 
    +        same_gp :: (PatGroup,EquationInfo) -> Bool
    1149 
    +        same_gp (pg2,_) = pg1 `sameGroup` pg2
    1044 1150
    1045 1151 
     -- TODO Make subGroup1 using a NonEmptyMap
    1046 1152 
     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/3f422a62e8fccd1a7a9f90a7ef2119fd7191ce60 at 1793664044