[Git][ghc/ghc][wip/T13253] This patch addresses the exponential blow-up in the simplifier.

Simon Peyton Jones gitlab at gitlab.haskell.org
Thu Jun 11 16:25:40 UTC 2020



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


Commits:
b3163d88 by Simon Peyton Jones at 2020-06-11T17:24:54+01:00
This patch addresses the exponential blow-up in the simplifier.

Specifically:
  #13253 exponential inlining
  #10421 ditto
  #18140 strict constructors
  #18282 another nested-function call case

This patch makes two significant changes:

1. For Ids that are used at most once in each branch of a case,
   make the occurrence analyser record the total number of
   syntactic occurrences.  Then in postInlineUnconditionally
   use that info to avoid inling something many many times.

   Actual changes:
     * See the occ_n_br field of OneOcc.
     * postInlineUnconditionally
   See Note [Suppress exponential blowup] in GHC.Core.Opt.Simplify.Utils

2. Change the way that mkDupableCont handles StrictArg.
   The details are explained in GHC.Core.Opt.Simplify
      Note [Duplicating StrictArg]

Current nofib run

        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
             VS          -0.3%   +115.9%    +12.1%    +11.2%      0.0%
         boyer2          -0.3%    +10.0%     +3.5%     +4.0%      0.0%
   cryptarithm2          -0.3%    +39.0%    +16.6%    +16.1%      0.0%
         gamteb          -0.3%     +4.1%     -0.0%     +0.4%      0.0%
     last-piece          -0.3%     +1.4%     -1.1%     -0.4%      0.0%
           mate          -0.4%    -11.1%     -8.5%     -9.0%      0.0%
     multiplier          -0.3%     -2.2%     -1.5%     -1.5%      0.0%
      transform          -0.3%     +3.4%     +0.5%     +0.8%      0.0%
--------------------------------------------------------------------------------
            Min          -0.8%    -11.1%     -8.5%     -9.0%      0.0%
            Max          -0.3%   +115.9%    +30.1%    +26.4%      0.0%
 Geometric Mean          -0.3%     +1.0%     +1.0%     +1.0%     -0.0%

Should investigate these numbers.

But the tickets are indeed cured, I think.

- - - - -


14 changed files:

- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Types/Basic.hs
- compiler/GHC/Types/Id/Info.hs
- + testsuite/tests/perf/compiler/T10421.hs
- + testsuite/tests/perf/compiler/T10421_Form.hs
- + testsuite/tests/perf/compiler/T10421_Y.hs
- + testsuite/tests/perf/compiler/T13253-spj.hs
- + testsuite/tests/perf/compiler/T13253.hs
- + testsuite/tests/perf/compiler/T18140.hs
- testsuite/tests/perf/compiler/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -832,7 +832,7 @@ occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage
 
     certainly_inline -- See Note [Cascading inlines]
       = case occ of
-          OneOcc { occ_in_lam = NotInsideLam, occ_one_br = InOneBranch }
+          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }
             -> active && not_stable
           _ -> False
 
@@ -2563,7 +2563,7 @@ mkOneOcc id int_cxt arity
   = emptyDetails
   where
     occ_info = OneOcc { occ_in_lam  = NotInsideLam
-                      , occ_one_br  = InOneBranch
+                      , occ_n_br    = oneBranch
                       , occ_int_cxt = int_cxt
                       , occ_tail    = AlwaysTailCalled arity }
 
@@ -2967,11 +2967,15 @@ addOccInfo a1 a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
 -- (orOccInfo orig new) is used
 -- when combining occurrence info from branches of a case
 
-orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1
-                  , occ_tail   = tail1 })
-          (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2
-                  , occ_tail   = tail2 })
-  = OneOcc { occ_one_br  = MultipleBranches -- because it occurs in both branches
+orOccInfo (OneOcc { occ_in_lam  = in_lam1
+                  , occ_n_br    = nbr1
+                  , occ_int_cxt = int_cxt1
+                  , occ_tail    = tail1 })
+          (OneOcc { occ_in_lam  = in_lam2
+                  , occ_n_br    = nbr2
+                  , occ_int_cxt = int_cxt2
+                  , occ_tail    = tail2 })
+  = OneOcc { occ_n_br    = nbr1 + nbr2
            , occ_in_lam  = in_lam1 `mappend` in_lam2
            , occ_int_cxt = int_cxt1 `mappend` int_cxt2
            , occ_tail    = tail1 `andTailCallInfo` tail2 }


=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -632,8 +632,8 @@ lvlMFE env strict_ctxt e@(_, AnnCase {})
 lvlMFE env strict_ctxt ann_expr
   |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
          -- Only floating to the top level is allowed.
-  || anyDVarSet isJoinId fvs   -- If there is a free join, don't float
-                               -- See Note [Free join points]
+  || hasFreeJoin env fvs   -- If there is a free join, don't float
+                           -- See Note [Free join points]
   || isExprLevPoly expr
          -- We can't let-bind levity polymorphic expressions
          -- See Note [Levity polymorphism invariants] in GHC.Core
@@ -729,6 +729,14 @@ lvlMFE env strict_ctxt ann_expr
                 && floatConsts env
                 && (not strict_ctxt || is_bot || exprIsHNF expr)
 
+hasFreeJoin :: LevelEnv -> DVarSet -> Bool
+-- Has a free join point which is not being floated to top level.
+-- (In the latter case it won't be a join point any more.)
+-- Not treating top-level ones specially had a massive effect
+-- on nofib/minimax/Prog.prog
+hasFreeJoin env fvs
+  = not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
+
 isBottomThunk :: Maybe (Arity, s) -> Bool
 -- See Note [Bottoming floats] (2)
 isBottomThunk (Just (0, _)) = True   -- Zero arity


=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -625,13 +625,6 @@ prepareRhs mode top_lvl occ rhs0
     go _ other
         = return (False, emptyLetFloats, other)
 
-makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)
-makeTrivialArg mode arg@(ValArg { as_arg = e })
-  = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e
-       ; return (floats, arg { as_arg = e' }) }
-makeTrivialArg _ arg
-  = return (emptyLetFloats, arg)  -- CastBy, TyArg
-
 makeTrivial :: SimplMode -> TopLevelFlag
             -> FastString  -- ^ A "friendly name" to build the new binder from
             -> OutExpr     -- ^ This expression satisfies the let/app invariant
@@ -3185,9 +3178,11 @@ mkDupableCont env (TickIt t cont)
 
 mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
                               , sc_body = body, sc_env = se, sc_cont = cont})
-  -- See Note [Duplicating StrictBind]
+-- See Note [Duplicating StrictBind]
+-- K[ let x = <> in b ]  -->   join j x = K[ b ]
+--                             j <>
   = do { let sb_env = se `setInScopeFromE` env
-       ; (sb_env1, bndr') <- simplBinder sb_env bndr
+       ; (sb_env1, bndr')      <- simplBinder sb_env bndr
        ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont
           -- No need to use mkDupableCont before simplLam; we
           -- use cont once here, and then share the result if necessary
@@ -3195,36 +3190,20 @@ mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
        ; let join_body = wrapFloats floats1 join_inner
              res_ty    = contResultType cont
 
-       ; (floats2, body2)
-            <- if exprIsDupable (targetPlatform (seDynFlags env)) join_body
-               then return (emptyFloats env, join_body)
-               else do { join_bndr <- newJoinId [bndr'] res_ty
-                       ; let join_call = App (Var join_bndr) (Var bndr')
-                             join_rhs  = Lam (setOneShotLambda bndr') join_body
-                             join_bind = NonRec join_bndr join_rhs
-                             floats    = emptyFloats env `extendFloats` join_bind
-                       ; return (floats, join_call) }
-       ; return ( floats2
-                , StrictBind { sc_bndr = bndr', sc_bndrs = []
-                             , sc_body = body2
-                             , sc_env  = zapSubstEnv se `setInScopeFromF` floats2
-                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
-                             , sc_dup  = OkToDup
-                             , sc_cont = mkBoringStop res_ty } ) }
+       ; mkDupableStrictBind env RhsCtxt bndr' join_body res_ty }
 
-mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci
+mkDupableCont env (StrictArg { sc_fun = fun, sc_cci = cci
                              , sc_cont = cont, sc_fun_ty = fun_ty })
-        -- See Note [Duplicating StrictArg]
-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
-  = do { (floats1, cont') <- mkDupableCont env cont
-       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))
-                                           (ai_args info)
-       ; return ( foldl' addLetFloats floats1 floats_s
-                , StrictArg { sc_fun = info { ai_args = args' }
-                            , sc_cont = cont'
-                            , sc_cci = cci
-                            , sc_fun_ty = fun_ty
-                            , sc_dup = OkToDup} ) }
+-- See Note [Duplicating StrictArg]
+-- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+--   K[ f a b <> ]   -->   join j x = K[ f a b x ]
+--                         j <>
+  = do { let arg_ty = funArgTy fun_ty
+             rhs_ty = contResultType cont
+       ; arg_bndr <- newId (fsLit "arg") arg_ty
+       ; let env' = env `addNewInScopeIds` [arg_bndr]
+       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
+       ; mkDupableStrictBind env' cci arg_bndr (wrapFloats floats join_rhs) rhs_ty }
 
 mkDupableCont env (ApplyToTy { sc_cont = cont
                              , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
@@ -3296,6 +3275,33 @@ mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
                                       -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
                           , sc_cont = mkBoringStop (contResultType cont) } ) }
 
+mkDupableStrictBind :: SimplEnv -> CallCtxt -> OutId -> OutExpr -> OutType
+                    -> SimplM (SimplFloats, SimplCont)
+mkDupableStrictBind env cci arg_bndr join_rhs res_ty
+  | exprIsDupable (targetPlatform (seDynFlags env)) join_rhs
+  = return (emptyFloats env
+           , StrictBind { sc_bndr = arg_bndr, sc_bndrs = []
+                        , sc_body = join_rhs
+                        , sc_env  = zapSubstEnv env
+                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
+                        , sc_dup  = OkToDup
+                        , sc_cont = mkBoringStop res_ty } )
+  | otherwise
+  = do { join_bndr <- newJoinId [arg_bndr] res_ty
+       ; let arg_info = ArgInfo { ai_fun   = join_bndr
+                                , ai_rules = Nothing, ai_args  = []
+                                , ai_encl  = False, ai_strs  = repeat False
+                                , ai_discs = repeat 0 }
+       ; return ( addJoinFloats (emptyFloats env) $
+                  unitJoinFloat                   $
+                  NonRec join_bndr                $
+                  Lam (setOneShotLambda arg_bndr) join_rhs
+                , StrictArg { sc_dup    = OkToDup
+                            , sc_fun    = arg_info
+                            , sc_fun_ty = idType join_bndr
+                            , sc_cont   = mkBoringStop res_ty
+                            , sc_cci    = cci } ) }
+
 mkDupableAlt :: Platform -> OutId
              -> JoinFloats -> OutAlt
              -> SimplM (JoinFloats, OutAlt)
@@ -3469,56 +3475,75 @@ type variables as well as term variables.
 
 Note [Duplicating StrictArg]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We make a StrictArg duplicable simply by making all its
-stored-up arguments (in sc_fun) trivial, by let-binding
-them.  Thus:
-        f E [..hole..]
-        ==>     let a = E
-                in f a [..hole..]
-Now if the thing in the hole is a case expression (which is when
-we'll call mkDupableCont), we'll push the function call into the
-branches, which is what we want.  Now RULES for f may fire, and
-call-pattern specialisation.  Here's an example from #3116
+What code do we want for this?
+
+   f (case x1 of { T -> F; F -> T })
+     (case x2 of { T -> F; F -> T })
+     ...etc...
+
+when f is strict in all its arguments.  (It might, for example, be a
+strict data constructor whose wrapper has not yet been inlined.)
+
+Morally, we want to evaluate each argument in turn, and then call f.
+Eavluating each argument has a case-split, so we'll get a diamond
+pattern of join points, like this, assuming we evaluate the args
+left-to-right:
+
+  join {
+    j1 a1 = join {
+              j2 a2 = .....
+            } in case x2 of { T -> j2 F; j2 T }
+  } in case x1 of { T -> j1 F; F -> j1 T }
+
+So when we want to duplicate a StrictArg continuation, we
+want to use this transformation
+   K[ f a b <> ]   -->   join j x = K[ f a b x ]
+                         in j <>
+
+-- Downsides --
+
+This plan has some downsides, because now the call to 'f' can't
+"see" the actual argument 'x' which might be important for RULES
+or call-pattern specialisation. Here's an example from #3116
+
      go (n+1) (case l of
                  1  -> bs'
                  _  -> Chunk p fpc (o+1) (l-1) bs')
-If we can push the call for 'go' inside the case, we get
+
+If we pushed the entire call for 'go' inside the case, we get
 call-pattern specialisation for 'go', which is *crucial* for
 this program.
 
-Here is the (&&) example:
+Here is another example. With our current approach we see
         && E (case x of { T -> F; F -> T })
-  ==>   let a = E in
-        case x of { T -> && a F; F -> && a T }
-Much better!
-
-Notice that
-  * Arguments to f *after* the strict one are handled by
-    the ApplyToVal case of mkDupableCont.  Eg
-        f [..hole..] E
-
-  * We can only do the let-binding of E because the function
-    part of a StrictArg continuation is an explicit syntax
-    tree.  In earlier versions we represented it as a function
-    (CoreExpr -> CoreEpxr) which we couldn't take apart.
-
-Historical aide: previously we did this (where E is a
-big argument:
-        f E [..hole..]
-        ==>     let $j = \a -> f E a
-                in $j [..hole..]
-
-But this is terrible! Here's an example:
-        && E (case x of { T -> F; F -> T })
-Now, && is strict so we end up simplifying the case with
-an ArgOf continuation.  If we let-bind it, we get
-        let $j = \v -> && E v
-        in simplExpr (case x of { T -> F; F -> T })
-                     (ArgOf (\r -> $j r)
-And after simplifying more we get
+  ==>
         let $j = \v -> && E v
         in case x of { T -> $j F; F -> $j T }
-Which is a Very Bad Thing
+
+But we'd prefer to get
+        let a = E
+        in case x of { T -> && a F; F -> && a T }
+
+Pushing the whole call inwards in this way is precisely the change
+that was made in #3116, but /un-done/ by my fix to #13253.  Why?
+Because pushing the whole call inwards works very badly in some cases.
+
+   f (case x1 of { T->F; F->T }) (case x2..) ...
+
+==> GHC 8.10 duplicate StrictArg
+  (case x1 of { T -> f F, F -> f T })
+     (case x2 ...)
+     (case x3 ...)
+==> duplicate ApplyToVal
+  let a2 = case x2 of ...
+      a3 = case x3 of ...
+  in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }
+
+Now there is an Awful Danger than we'll postInlineUnconditionally a2
+and a3, and repeat the whole exercise, leading to exponential code
+size.  Moreover, if we don't, those ai lets are really strict; so not
+or later they will be dealt with via Note [Duplicating StrictBind].
+StrictArg and StrictBind should be handled the same.
 
 
 Note [Duplicating StrictBind]
@@ -3528,9 +3553,10 @@ that for case expressions.  After all,
    let x* = e in b   is similar to    case e of x -> b
 
 So we potentially make a join-point for the body, thus:
-   let x = [] in b   ==>   join j x = b
-                           in let x = [] in j x
+   let x = <> in b   ==>   join j x = b
+                           in j <>
 
+Just like StrictArg in fact -- and indeed they share code.
 
 Note [Join point abstraction]  Historical note
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1175,9 +1175,9 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
     extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)
 
     one_occ IAmDead = True -- Happens in ((\x.1) v)
-    one_occ OneOcc{ occ_one_br = InOneBranch
+    one_occ OneOcc{ occ_n_br   = 1
                   , occ_in_lam = NotInsideLam }   = isNotTopLevel top_lvl || early_phase
-    one_occ OneOcc{ occ_one_br = InOneBranch
+    one_occ OneOcc{ occ_n_br   = 1
                   , occ_in_lam = IsInsideLam
                   , occ_int_cxt = IsInteresting } = canInlineInLam rhs
     one_occ _                                     = False
@@ -1303,12 +1303,17 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs
         --         False -> case x of ...
         -- This is very important in practice; e.g. wheel-seive1 doubles
         -- in allocation if you miss this out
-      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }
-               -- OneOcc => no code-duplication issue
-        ->     smallEnoughToInline dflags unfolding     -- Small enough to dup
+
+      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }
+        ->  -- See Note [Suppress exponential blowup]
+            n_br < (case int_cxt of
+                        IsInteresting  -> 16
+                        NotInteresting -> 4)
+
+           && smallEnoughToInline dflags unfolding     -- Small enough to dup
                         -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
                         --
-                        -- NB: Do NOT inline arbitrarily big things, even if one_br is True
+                        -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1
                         -- Reason: doing so risks exponential behaviour.  We simplify a big
                         --         expression, inline it, and simplify it again.  But if the
                         --         very same thing happens in the big expression, we get
@@ -1355,7 +1360,35 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs
     active    = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
         -- See Note [pre/postInlineUnconditionally in gentle mode]
 
-{-
+{- Note [Suppress exponential blowup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In #13253, and a raft of related tickets, we got an exponential blowup
+in code size from postInlineUnconditionally.  The trouble comes when
+we have
+  let j1a = case f y     of { True -> p;   False -> q }
+      j1b = case f y     of { True -> q;   False -> p }
+      j2a = case f (y+1) of { True -> j1a; False -> j1b }
+      j2b = case f (y+1) of { True -> j1b; False -> j1a }
+      ...
+  in case f (y+10) of { True -> j10a; False -> j10b }
+
+when there are many branches. In pass 1, postInlineUnconditionally
+inlines j10a and j10b (they are both small).  Now we have two calls
+to j9a and two to j9b.  In pass 2, postInlineUnconditionally inlines
+all four of these calls, leaving four calls to j8a and j8b. Etc.
+Yikes!  This is exponential!
+
+Moreover, this structure can and does arise easily, as the
+tickets show: it's just a sequence of diamond control flow blocks.
+
+Solution: stop doing postInlineUnconditionally for some fixed,
+smallish number of branches, say 4.
+
+This still leaves the nasty possiblity that /ordinary/ inlining (not
+postInlineUnconditionally) might inline these join points, each of
+which is individually quiet small.  I'm still not sure what to do
+about this (see #15488).  But let's kill off one problem anyway.
+
 Note [Top level and postInlineUnconditionally]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We don't do postInlineUnconditionally for top-level things (even for


=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -424,7 +424,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
     safe_to_inline IAmALoopBreaker{}                  = False
     safe_to_inline IAmDead                            = True
     safe_to_inline OneOcc{ occ_in_lam = NotInsideLam
-                         , occ_one_br = InOneBranch } = True
+                         , occ_n_br = 1 }             = True
     safe_to_inline OneOcc{}                           = False
     safe_to_inline ManyOccs{}                         = False
 


=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -68,7 +68,7 @@ module GHC.Types.Basic (
         isNoOccInfo, strongLoopBreaker, weakLoopBreaker,
 
         InsideLam(..),
-        OneBranch(..),
+        BranchCount, oneBranch,
         InterestingCxt(..),
         TailCallInfo(..), tailCallInfo, zapOccTailCallInfo,
         isAlwaysTailCalled,
@@ -978,7 +978,7 @@ data OccInfo
                         -- lambda and case-bound variables.
 
   | OneOcc          { occ_in_lam  :: !InsideLam
-                    , occ_one_br  :: !OneBranch
+                    , occ_n_br    :: {-# UNPACK #-} !BranchCount
                     , occ_int_cxt :: !InterestingCxt
                     , occ_tail    :: !TailCallInfo }
                         -- ^ Occurs exactly once (per branch), not inside a rule
@@ -992,6 +992,11 @@ data OccInfo
 
 type RulesOnly = Bool
 
+type BranchCount = Int -- For OneOcc, says how many syntactic occurrences there are
+
+oneBranch :: BranchCount
+oneBranch = 1
+
 {-
 Note [LoopBreaker OccInfo]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1057,14 +1062,6 @@ instance Monoid InsideLam where
   mempty = NotInsideLam
   mappend = (Semi.<>)
 
------------------
-data OneBranch
-  = InOneBranch
-    -- ^ One syntactic occurrence: Occurs in only one case branch
-    -- so no code-duplication issue to worry about
-  | MultipleBranches
-  deriving (Eq)
-
 -----------------
 data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]
                   | NoTailCallInfo
@@ -1124,12 +1121,10 @@ instance Outputable OccInfo where
           pp_ro | rule_only = char '!'
                 | otherwise = empty
   ppr (OneOcc inside_lam one_branch int_cxt tail_info)
-        = text "Once" <> pp_lam inside_lam <> pp_br one_branch <> pp_args int_cxt <> pp_tail
+        = text "Once" <> pp_lam inside_lam <> ppr one_branch <> pp_args int_cxt <> pp_tail
         where
           pp_lam IsInsideLam     = char 'L'
           pp_lam NotInsideLam    = empty
-          pp_br MultipleBranches = char '*'
-          pp_br InOneBranch      = empty
           pp_args IsInteresting  = char '!'
           pp_args NotInteresting = empty
           pp_tail                = pprShortTailCallInfo tail_info
@@ -1156,7 +1151,7 @@ AlwaysTailCalled.
 
 Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that
 being tail-called would mean that the variable could only appear once per branch
-(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join
+(thus getting a `OneOcc { }` occurrence info), but a join
 point can also be invoked from other join points, not just from case branches:
 
   let j1 x = ...
@@ -1167,7 +1162,7 @@ point can also be invoked from other join points, not just from case branches:
        C -> j2 q
 
 Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get
-ManyOccs and j2 will get `OneOcc { occ_one_br = True }`.
+ManyOccs and j2 will get `OneOcc { occ_n_br = 2 }`.
 
 ************************************************************************
 *                                                                      *


=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -58,7 +58,7 @@ module GHC.Types.Id.Info (
         isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,
         occInfo, setOccInfo,
 
-        InsideLam(..), OneBranch(..),
+        InsideLam(..), BranchCount,
 
         TailCallInfo(..),
         tailCallInfo, isAlwaysTailCalled,


=====================================
testsuite/tests/perf/compiler/T10421.hs
=====================================
@@ -0,0 +1,51 @@
+-- Exponential with GHC 8.10
+
+module RegBig where
+
+import Prelude
+
+import Control.Applicative
+import T10421_Form
+import T10421_Y
+
+data Register
+  = Register String
+             String
+             String
+             String
+             String
+             String
+             String
+             String
+             String
+             String
+             String
+             String
+
+registerForm :: a -> IO (FormResult Register)
+registerForm _  = do
+  (a1, _) <- mreq textField "" Nothing
+  (a2, _) <- mreq textField "" Nothing
+  (a3, _) <- mreq textField "" Nothing
+  (a4, _) <- mreq textField "" Nothing
+  (a5, _) <- mreq textField "" Nothing
+  (a6, _) <- mreq textField "" Nothing
+  (a7, _) <- mreq textField "" Nothing
+  (a8, _) <- mreq textField "" Nothing
+  (a9, _) <- mreq textField "" Nothing
+  (a10, _) <- mreq textField "" Nothing
+  (a11, _) <- mreq textField "" Nothing
+  (a12, _) <- mreq textField "" Nothing
+  return (Register <$> a1
+                   <*> a2
+                   <*> a3
+                   <*> a4
+                   <*> a5
+                   <*> a6
+                   <*> a7
+                   <*> a8
+                   <*> a9
+                   <*> a10
+                   <*> a11
+                   <*> a12
+      )


=====================================
testsuite/tests/perf/compiler/T10421_Form.hs
=====================================
@@ -0,0 +1,19 @@
+-- Form.hs
+module T10421_Form where
+
+import Control.Applicative
+
+data FormResult a = FormMissing
+                  | FormFailure [String]
+                  | FormSuccess a
+instance Functor FormResult where
+    fmap _ FormMissing = FormMissing
+    fmap _ (FormFailure errs) = FormFailure errs
+    fmap f (FormSuccess a) = FormSuccess $ f a
+instance Applicative FormResult where
+    pure = FormSuccess
+    (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
+    (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
+    (FormFailure x) <*> _ = FormFailure x
+    _ <*> (FormFailure y) = FormFailure y
+    _ <*> _ = FormMissing


=====================================
testsuite/tests/perf/compiler/T10421_Y.hs
=====================================
@@ -0,0 +1,17 @@
+-- Y.hs
+{-# OPTIONS_GHC -fomit-interface-pragmas #-}
+-- Imagine the values defined in this module are complicated
+-- and there is no useful inlining/strictness/etc. information
+
+module T10421_Y where
+
+import T10421_Form
+
+mreq :: a -> b -> c -> IO (FormResult d, ())
+mreq = undefined
+
+mopt :: a -> b -> c -> IO (FormResult d, ())
+mopt = undefined
+
+textField = undefined
+checkBoxField = undefined


=====================================
testsuite/tests/perf/compiler/T13253-spj.hs
=====================================
@@ -0,0 +1,20 @@
+-- Exponential with GHC 8.10
+
+module T13253 where
+
+f :: Int -> Bool -> Bool
+{-# INLINE f #-}
+f y x = case x of { True -> y>0 ; False -> y<0 }
+
+foo y x = f (y+1) $
+          f (y+2) $
+          f (y+3) $
+          f (y+4) $
+          f (y+5) $
+          f (y+6) $
+          f (y+7) $
+          f (y+8) $
+          f (y+9) $
+          f (y+10) $
+          f (y+11) $
+          f y x


=====================================
testsuite/tests/perf/compiler/T13253.hs
=====================================
@@ -0,0 +1,122 @@
+-- Exponential with GHC 8.10
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module T13253 where
+
+import Control.Monad (liftM)
+import Control.Monad.Trans.RWS.Lazy -- check how strict behaves
+import Control.Monad.Trans.Reader (ReaderT)
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Trans.Class (MonadTrans (..))
+import Data.ByteString (ByteString)
+import Data.Monoid (Any (..))
+import Data.Semigroup (Semigroup (..))
+import Data.String (IsString (..))
+import System.Environment (getEnv)
+
+type Handler = ReaderT () IO
+type MForm = RWST (Maybe ([(String, Text)], ()), (), ()) Any [Int]
+type Text = ByteString -- close enough
+
+data HugeStruct = HugeStruct
+  !Text
+  !Text
+  !Text
+  !Text
+  !Text
+  !Text
+  !Text
+  !Text
+  !Text -- 9th
+  !Text
+  !Text
+
+data FormResult a = FormMissing
+                  | FormFailure [Text]
+                  | FormSuccess a
+    deriving Show
+instance Functor FormResult where
+    fmap _ FormMissing = FormMissing
+    fmap _ (FormFailure errs) = FormFailure errs
+    fmap f (FormSuccess a) = FormSuccess $ f a
+instance Applicative FormResult where
+    pure = FormSuccess
+    (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
+    (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
+    (FormFailure x) <*> _ = FormFailure x
+    _ <*> (FormFailure y) = FormFailure y
+    _ <*> _ = FormMissing
+instance Monoid m => Monoid (FormResult m) where
+    mempty = pure mempty
+    mappend x y = mappend <$> x <*> y
+instance Semigroup m => Semigroup (FormResult m) where
+    x <> y = (<>) <$> x <*> y
+
+mreq :: MonadIO m => String -> MForm m (FormResult Text, ())
+-- fast
+--mreq v = pure (FormFailure [], ())
+-- slow
+mreq v = mhelper v (\m l -> FormFailure ["fail"]) FormSuccess
+
+askParams :: Monad m => MForm m (Maybe [(String, Text)])
+askParams = do
+    (x, _, _) <- ask
+    return $ liftM fst x
+
+mhelper
+    :: MonadIO m
+    => String
+    -> (() -> () -> FormResult b) -- on missing
+    -> (Text -> FormResult b)      -- on success
+    -> MForm m (FormResult b, ())
+mhelper v onMissing onFound = do
+    -- without tell, also faster
+    tell (Any True)
+    -- with different "askParams": faster.
+    -- mp <- liftIO $ read <$> readFile v
+    mp <- askParams
+    (res, x) <- case mp of
+        Nothing -> return (FormMissing, ())
+        Just p -> do
+            return $ case lookup v p of
+                Nothing -> (onMissing () (), ())
+                Just t -> (onFound t, ())
+    return (res, x)
+
+-- not inlining, also faster:
+-- {-# NOINLINE mhelper #-}
+
+sampleForm2 :: MForm Handler (FormResult HugeStruct)
+sampleForm2 = do
+    (x01, _) <- mreq "UNUSED"
+    (x02, _) <- mreq "UNUSED"
+    (x03, _) <- mreq "UNUSED"
+    (x04, _) <- mreq "UNUSED"
+    (x05, _) <- mreq "UNUSED"
+    (x06, _) <- mreq "UNUSED"
+    (x07, _) <- mreq "UNUSED"
+    (x08, _) <- mreq "UNUSED"
+    (x09, _) <- mreq "UNUSED"
+    (x10, _) <- mreq "UNUSED"
+    (x11, _) <- mreq "UNUSED"
+
+    let hugeStructRes = HugeStruct
+          <$> x01
+          <*> x02
+          <*> x03
+          <*> x04
+          <*> x05
+          <*> x06
+          <*> x07
+          <*> x08
+          <*> x09
+          <*> x10
+          <*> x11
+
+    pure hugeStructRes
+
+
+main :: IO ()
+main = pure ()


=====================================
testsuite/tests/perf/compiler/T18140.hs
=====================================
@@ -0,0 +1,57 @@
+-- Exponential with GHC 8.10
+
+{-# LANGUAGE BangPatterns  #-}
+module T18140 where
+
+
+data D = D
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+  !(Maybe Bool)
+
+maMB :: Maybe Bool -> Maybe Bool -> Maybe Bool
+maMB Nothing  y        = y
+maMB x        Nothing  = x
+maMB (Just x) (Just y) = Just (maB x y)
+
+maB :: Bool -> Bool -> Bool
+maB _ y = y
+
+maD :: D -> D -> D
+maD  (D x'1 x'2 x'3 x'4  x'5 x'6 x'7 x'8 x'9 x'10 x'11 x'12 x'13 x'14 x'15 x'16 x'17 x'18)
+     (D y'1 y'2 y'3 y'4  y'5 y'6 y'7 y'8 y'9 y'10 y'11 y'12 y'13 y'14 y'15 y'16 y'17 y'18)
+     = D
+      (maMB x'1 y'1)
+      (maMB x'2 y'2)
+      (maMB x'3 y'3)
+      (maMB x'4 y'4)
+      (maMB x'5 y'5)
+      (maMB x'6 y'6)
+      (maMB x'7 y'7)
+      (maMB x'8 y'8)
+      (maMB x'9 y'9)
+      (maMB x'10 y'10)
+      (maMB x'11 y'11)
+      (maMB x'12 y'12)
+      (maMB x'13 y'13)
+      (maMB x'14 y'14)
+      (maMB x'15 y'15)
+      (maMB x'16 y'16)
+      (maMB x'17 y'17)
+      (maMB x'18 y'18)
+


=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -361,3 +361,24 @@ test ('T18282',
       ],
       compile,
       ['-v0 -O'])
+test ('T18140',
+      [ collect_compiler_stats('bytes allocated',2)
+      ],
+      compile,
+      ['-v0 -O'])
+test('T10421',
+    [ only_ways(['normal']),
+      collect_compiler_stats('bytes allocated', 1)
+    ],
+    multimod_compile,
+    ['T10421', '-v0 -O'])
+test ('T13253',
+      [ collect_compiler_stats('bytes allocated',2)
+      ],
+      compile,
+      ['-v0 -O'])
+test ('T13253-spj',
+      [ collect_compiler_stats('bytes allocated',2)
+      ],
+      compile,
+      ['-v0 -O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3163d88c5e3bedce30d7c88b9d252a901d63f0b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b3163d88c5e3bedce30d7c88b9d252a901d63f0b
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200611/9c157570/attachment-0001.html>


More information about the ghc-commits mailing list