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

Commits:

8 changed files:

Changes:

  • compiler/GHC/Core/Opt/OccurAnal.hs
    ... ... @@ -28,7 +28,7 @@ core expression with (hopefully) improved usage information.
    28 28 
     module GHC.Core.Opt.OccurAnal (
    29 29 
         occurAnalysePgm,
    30 30 
         occurAnalyseExpr,
    31 
    -    zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap
    31 
    +    zapLambdaBndrs
    32 32 
       ) where
    33 33
    34 34 
     import GHC.Prelude hiding ( head, init, last, tail )
    ... ... @@ -36,7 +36,7 @@ import GHC.Prelude hiding ( head, init, last, tail )
    36 36 
     import GHC.Core
    37 37 
     import GHC.Core.FVs
    38 38 
     import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,
    39 
    -                          mkCastMCo, mkTicks )
    39 
    +                          mkCastMCo, mkTicks, BinderSwapDecision(..), scrutOkForBinderSwap )
    40 40 
     import GHC.Core.Opt.Arity   ( joinRhsArity, isOneShotBndr )
    41 41 
     import GHC.Core.Coercion
    42 42 
     import GHC.Core.Type
    ... ... @@ -3537,6 +3537,7 @@ doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.
    3537 3537 
     -}
    3538 3538
    3539 3539 
     addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
    3540 
    +-- See Note [Binder swap]
    3540 3541 
     -- See Note [The binder-swap substitution]
    3541 3542 
     addBndrSwap scrut case_bndr
    3542 3543 
                 env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })
    ... ... @@ -3544,7 +3545,7 @@ addBndrSwap scrut case_bndr
    3544 3545 
       , scrut_var /= case_bndr
    3545 3546 
           -- Consider: case x of x { ... }
    3546 3547 
           -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop
    3547 
    -  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)
    3548 
    +  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mkSymMCo mco)
    3548 3549 
             , occ_bs_rng = rng_vars `extendVarSet` case_bndr'
    3549 3550 
                            `unionVarSet` tyCoVarsOfMCo mco }
    3550 3551
    ... ... @@ -3554,27 +3555,6 @@ addBndrSwap scrut case_bndr
    3554 3555 
         case_bndr' = zapIdOccInfo case_bndr
    3555 3556 
                      -- See Note [Zap case binders in proxy bindings]
    3556 3557
    3557 
    --- | See bBinderSwaOk.
    3558 
    -data BinderSwapDecision
    3559 
    -  = NoBinderSwap
    3560 
    -  | DoBinderSwap OutVar MCoercion
    3561 
    -
    3562 
    -scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision
    3563 
    --- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then
    3564 
    ---    v = e |> mco
    3565 
    --- See Note [Case of cast]
    3566 
    --- See Historical Note [Care with binder-swap on dictionaries]
    3567 
    ---
    3568 
    --- We use this same function in SpecConstr, and Simplify.Iteration,
    3569 
    --- when something binder-swap-like is happening
    3570 
    -scrutOkForBinderSwap e
    3571 
    -  = case e of
    3572 
    -      Tick _ e        -> scrutOkForBinderSwap e  -- Drop ticks
    3573 
    -      Var v           -> DoBinderSwap v MRefl
    3574 
    -      Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co))
    3575 
    -                         -- Cast: see Note [Case of cast]
    3576 
    -      _               -> NoBinderSwap
    3577 
    -
    3578 3558 
     lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
    3579 3559 
     -- See Note [The binder-swap substitution]
    3580 3560 
     -- Returns an expression of the same type as Id

  • compiler/GHC/Core/Opt/Simplify/Iteration.hs
    ... ... @@ -22,7 +22,7 @@ import GHC.Core.TyCo.Compare( eqType )
    22 22 
     import GHC.Core.Opt.Simplify.Env
    23 23 
     import GHC.Core.Opt.Simplify.Inline
    24 24 
     import GHC.Core.Opt.Simplify.Utils
    25 
    -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) )
    25 
    +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )
    26 26 
     import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )
    27 27 
     import qualified GHC.Core.Make
    28 28 
     import GHC.Core.Coercion hiding ( substCo, substCoVar )
    ... ... @@ -3601,11 +3601,13 @@ addAltUnfoldings env case_bndr bndr_swap con_app
    3601 3601 
         env1 = addBinderUnfolding env case_bndr con_app_unf
    3602 3602
    3603 3603 
         -- See Note [Add unfolding for scrutinee]
    3604 
    +    -- e.g. case (x |> co) of K a b -> blah
    3605 
    +    --      We add to `x` the unfolding  (K a b |> sym co)
    3604 3606 
         env2 | DoBinderSwap v mco <- bndr_swap
    3605 3607 
              = addBinderUnfolding env1 v $
    3606 3608 
                   if isReflMCo mco  -- isReflMCo: avoid calling mk_simple_unf
    3607 3609 
                   then con_app_unf  --            twice in the common case
    3608 
    -              else mk_simple_unf (mkCastMCo con_app mco)
    3610 
    +              else mk_simple_unf (mkCastMCo con_app (mkSymMCo mco))
    3609 3611
    3610 3612 
              | otherwise = env1
    3611 3613

  • compiler/GHC/Core/Opt/Simplify/Utils.hs
    ... ... @@ -2693,7 +2693,7 @@ mkCase, mkCase1, mkCase2, mkCase3
    2693 2693
    2694 2694 
     mkCase mode scrut outer_bndr alts_ty alts
    2695 2695 
       | sm_case_merge mode
    2696 
    -  , Just (joins, alts') <- mergeCaseAlts outer_bndr alts
    2696 
    +  , Just (joins, alts') <- mergeCaseAlts scrut outer_bndr alts
    2697 2697 
       = do  { tick (CaseMerge outer_bndr)
    2698 2698 
             ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts'
    2699 2699 
             ; return (mkLets joins case_expr) }

  • compiler/GHC/Core/Opt/SpecConstr.hs
    ... ... @@ -29,7 +29,6 @@ import GHC.Core.Opt.Simplify.Inline
    29 29 
     import GHC.Core.FVs     ( exprsFreeVarsList, exprFreeVars )
    30 30 
     import GHC.Core.Opt.Monad
    31 31 
     import GHC.Core.Opt.WorkWrap.Utils
    32 
    -import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap )
    33 32 
     import GHC.Core.DataCon
    34 33 
     import GHC.Core.Class( classTyVars )
    35 34 
     import GHC.Core.Coercion hiding( substCo )

  • compiler/GHC/Core/Utils.hs
    ... ... @@ -19,6 +19,7 @@ module GHC.Core.Utils (
    19 19 
             mergeAlts, mergeCaseAlts, trimConArgs,
    20 20 
             filterAlts, combineIdenticalAlts, refineDefaultAlt,
    21 21 
             scaleAltsBy,
    22 
    +        BinderSwapDecision(..), scrutOkForBinderSwap,
    22 23
    23 24 
             -- * Properties of expressions
    24 25 
             exprType, coreAltType, coreAltsType,
    ... ... @@ -72,7 +73,7 @@ import GHC.Platform
    72 73
    73 74 
     import GHC.Core
    74 75 
     import GHC.Core.Ppr
    75 
    -import GHC.Core.FVs( bindFreeVars )
    76 
    +import GHC.Core.FVs( exprFreeVars, bindFreeVars )
    76 77 
     import GHC.Core.DataCon
    77 78 
     import GHC.Core.Type as Type
    78 79 
     import GHC.Core.Predicate( isEqPred )
    ... ... @@ -112,11 +113,11 @@ import GHC.Utils.Outputable
    112 113 
     import GHC.Utils.Panic
    113 114 
     import GHC.Utils.Misc
    114 115
    116 
    +import Control.Monad       ( guard )
    115 117 
     import Data.ByteString     ( ByteString )
    116 118 
     import Data.Function       ( on )
    117 119 
     import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )
    118 120 
     import Data.Ord            ( comparing )
    119 
    -import Control.Monad       ( guard )
    120 121 
     import qualified Data.Set as Set
    121 122
    122 123 
     {-
    ... ... @@ -590,6 +591,28 @@ The default alternative must be first, if it exists at all.
    590 591 
     This makes it easy to find, though it makes matching marginally harder.
    591 592 
     -}
    592 593
    594 
    +data BinderSwapDecision
    595 
    +  = NoBinderSwap
    596 
    +  | DoBinderSwap OutVar MCoercion
    597 
    +
    598 
    +scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision
    599 
    +-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then
    600 
    +--    e = v |> mco
    601 
    +-- See Note [Case of cast]
    602 
    +-- See Historical Note [Care with binder-swap on dictionaries]
    603 
    +--
    604 
    +-- We use this same function in SpecConstr, and Simplify.Iteration,
    605 
    +-- when something binder-swap-like is happening
    606 
    +--
    607 
    +-- See Note [Binder swap] in GHC.Core.Opt.OccurAnal
    608 
    +scrutOkForBinderSwap e
    609 
    +  = case e of
    610 
    +      Tick _ e        -> scrutOkForBinderSwap e  -- Drop ticks
    611 
    +      Var v           -> DoBinderSwap v MRefl
    612 
    +      Cast (Var v) co -> DoBinderSwap v (MCo co)
    613 
    +                         -- Cast: see Note [Case of cast]
    614 
    +      _               -> NoBinderSwap
    615 
    +
    593 616 
     -- | Extract the default case alternative
    594 617 
     findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))
    595 618 
     findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs)
    ... ... @@ -651,11 +674,12 @@ filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase.
    651 674 
     -}
    652 675
    653 676 
     ---------------------------------
    654 
    -mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
    677 
    +mergeCaseAlts :: CoreExpr -> Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
    655 678 
     -- See Note [Merge Nested Cases]
    656 
    -mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    679 
    +mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    657 680 
       | Just (joins, inner_alts) <- go deflt_rhs
    658 
    -  = Just (joins, mergeAlts outer_alts inner_alts)
    681 
    +  , Just aux_binds <- mk_aux_binds joins
    682 
    +  = Just ( aux_binds ++ joins, mergeAlts outer_alts inner_alts )
    659 683 
                     -- NB: mergeAlts gives priority to the left
    660 684 
                     --      case x of
    661 685 
                     --        A -> e1
    ... ... @@ -665,6 +689,20 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    665 689 
                     -- When we merge, we must ensure that e1 takes
    666 690 
                     -- precedence over e2 as the value for A!
    667 691 
       where
    692 
    +    scrut_fvs = exprFreeVars scrut
    693 
    +
    694 
    +    -- See Note [Floating join points out of DEFAULT alternatives]
    695 
    +    mk_aux_binds join_binds
    696 
    +      | not (any mentions_outer_bndr join_binds)
    697 
    +      = Just []                         -- Good!  No auxiliary bindings needed
    698 
    +      | exprIsTrivial scrut
    699 
    +      , not (outer_bndr `elemVarSet` scrut_fvs)
    700 
    +      = Just [NonRec outer_bndr scrut]  -- Need a fixup binding
    701 
    +      | otherwise
    702 
    +      = Nothing                         -- Can't do it
    703 
    +
    704 
    +    mentions_outer_bndr bind = outer_bndr `elemVarSet` bindFreeVars bind
    705 
    +
    668 706 
         go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt])
    669 707
    670 708 
         -- Whizzo: we can merge!
    ... ... @@ -702,11 +740,10 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    702 740 
           = do { (joins, alts) <- go body
    703 741
    704 742 
                  -- Check for capture; but only if we could otherwise do a merge
    705 
    -           ; let capture = outer_bndr `elem` bindersOf bind
    706 
    -                           || outer_bndr `elemVarSet` bindFreeVars bind
    707 
    -           ; guard (not capture)
    743 
    +             --    (i.e. the recursive `go` succeeds)
    744 
    +           ; guard (okToFloatJoin scrut_fvs outer_bndr bind)
    708 745
    709 
    -           ; return (bind:joins, alts ) }
    746 
    +           ; return (bind : joins, alts ) }
    710 747 
           | otherwise
    711 748 
           = Nothing
    712 749
    ... ... @@ -718,7 +755,18 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    718 755
    719 756 
         go _ = Nothing
    720 757
    721 
    -mergeCaseAlts _ _ = Nothing
    758 
    +mergeCaseAlts _ _ _ = Nothing
    759 
    +
    760 
    +okToFloatJoin :: VarSet -> Id -> CoreBind -> Bool
    761 
    +-- Check a join-point binding to see if it can be floated out of
    762 
    +-- the DEFAULT branch of a `case`.
    763 
    +-- See Note [Floating join points out of DEFAULT alternatives]
    764 
    +okToFloatJoin scrut_fvs outer_bndr bind
    765 
    +  = not (any bad_bndr (bindersOf bind))
    766 
    +  where
    767 
    +    bad_bndr bndr = bndr == outer_bndr              -- (a)
    768 
    +                    || bndr `elemVarSet` scrut_fvs  -- (b)
    769 
    +
    722 770
    723 771 
     ---------------------------------
    724 772 
     mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]
    ... ... @@ -927,10 +975,46 @@ Wrinkles
    927 975 
           non-join-points unless the /outer/ case has just one alternative; doing
    928 976 
           so would risk more allocation
    929 977
    978 
    +      Floating out join points isn't entirely straightforward.
    979 
    +      See Note [Floating join points out of DEFAULT alternatives]
    980 
    +
    930 981 
     (MC5) See Note [Cascading case merge]
    931 982
    932 983 
     See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils
    933 984
    985 
    +Note [Floating join points out of DEFAULT alternatives]
    986 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    987 
    +Consider this, from (MC4) of Note [Merge Nested Cases]
    988 
    +   case x of r
    989 
    +     DEFAULT -> join j = rhs in case r of ...
    990 
    +     alts
    991 
    +
    992 
    +We want to float that join point out to give this
    993 
    +   join j = rhs
    994 
    +   case x of r
    995 
    +     DEFAULT -> case r of ...
    996 
    +     alts
    997 
    +
    998 
    +But doing so is flat-out wrong if the scoping gets messed up:
    999 
    +    (a) case x of r { DEFAULT -> join r = ... in ...r... }
    1000 
    +    (b) case j of r { DEFAULT -> join j = ... in ... }
    1001 
    +    (c) case x of r { DEFAULT -> join j = ...r.. in ... }
    1002 
    +In all these cases we can't float the join point out because r changes its
    1003 
    +meaning.  For (a) and (b) the Simplifier removes shadowing, so they'll
    1004 
    +be solved in the next iteration.  But case (c) will persist.
    1005 
    +
    1006 
    +Happily, we can fix up case (c) by adding an auxiliary binding, like this
    1007 
    +    let r = e in
    1008 
    +    join j = rhs[r]
    1009 
    +    case e of r
    1010 
    +       DEFAULT -> ...r...
    1011 
    +       ...other alts...
    1012 
    +
    1013 
    +We can only do this if
    1014 
    +  * We don't introduce shadowing: that is `j` and `r` do not appear free in `e`.
    1015 
    +    (Again the Simplifier will eliminate such shadowing.)
    1016 
    +  * The scrutinee `e` is trivial so that the transformation doesn't duplicate work.
    1017 
    +
    934 1018
    935 1019 
     Note [Cascading case merge]
    936 1020 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~

  • testsuite/tests/simplCore/should_compile/T26709.hs
    1 
    +module T26709 where
    2 
    +
    3 
    +data T = A | B | C
    4 
    +
    5 
    +f x = case x of
    6 
    +        A -> True
    7 
    +        _ -> let {-# NOINLINE j #-}
    8 
    +                 j y = y && not (f x)
    9 
    +             in case x of
    10 
    +                   B -> j True
    11 
    +                   C -> j False

  • testsuite/tests/simplCore/should_compile/T26709.stderr
    1 
    +[1 of 1] Compiling T26709           ( T26709.hs, T26709.o )
    2 
    +
    3 
    +==================== Tidy Core ====================
    4 
    +Result size of Tidy Core
    5 
    +  = {terms: 26, types: 9, coercions: 0, joins: 1/1}
    6 
    +
    7 
    +Rec {
    8 
    +-- RHS size: {terms: 25, types: 7, coercions: 0, joins: 1/1}
    9 
    +f [Occ=LoopBreaker] :: T -> Bool
    10 
    +[GblId, Arity=1, Str=<SL>, Unf=OtherCon []]
    11 
    +f = \ (x :: T) ->
    12 
    +      join {
    13 
    +        j [InlPrag=NOINLINE, Dmd=MC(1,L)] :: Bool -> Bool
    14 
    +        [LclId[JoinId(1)(Just [!])], Arity=1, Str=<1L>, Unf=OtherCon []]
    15 
    +        j (eta [OS=OneShot] :: Bool)
    16 
    +          = case eta of {
    17 
    +              False -> GHC.Internal.Types.False;
    18 
    +              True ->
    19 
    +                case f x of {
    20 
    +                  False -> GHC.Internal.Types.True;
    21 
    +                  True -> GHC.Internal.Types.False
    22 
    +                }
    23 
    +            } } in
    24 
    +      case x of {
    25 
    +        A -> GHC.Internal.Types.True;
    26 
    +        B -> jump j GHC.Internal.Types.True;
    27 
    +        C -> jump j GHC.Internal.Types.False
    28 
    +      }
    29 
    +end Rec }
    30 
    +
    31 
    +
    32 
    +

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -563,3 +563,8 @@ test('T26115', [grep_errmsg(r'DFun')], compile, ['-O -ddump-simpl -dsuppress-uni
    563 563 
     test('T26116', normal, compile, ['-O -ddump-rules'])
    564 564 
     test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniques'])
    565 565 
     test('T26349',  normal, compile, ['-O -ddump-rules'])
    566 
    +
    567 
    +# T26709: we expect three `case` expressions not four
    568 
    +test('T26709', [grep_errmsg(r'case')],
    569 
    +       multimod_compile,
    570 
    +       ['T26709', '-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