[GHC] #14688: Note [Lone variables] leads to missing a case-of-case opportunity

[GHC]

#14688: Note [Lone variables] leads to missing a case-of-case opportunity
-------------------------------------+-------------------------------------
        Reporter:  mpickering        |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  normal            |            Milestone:
       Component:  Compiler          |              Version:  8.2.2
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
                                     |  Unknown/Multiple
 Type of failure:  None/Unknown      |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by simonpj):

 Huh. I really don't think case-expressions should be expandable.  I think
 that's an unintentional consequences of sharing `exprIsCheapX`.

 This patch makes both `foo` and `foo2` behave well.  Would you like to do
 a full nofib run?
 {{{
 diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs
 index 945cad6..538648d 100644
 --- a/compiler/coreSyn/CoreArity.hs
 +++ b/compiler/coreSyn/CoreArity.hs
 @@ -514,9 +514,9 @@ getBotArity _        = Nothing
  mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun
  mk_cheap_fn dflags cheap_app
    | not (gopt Opt_DictsCheap dflags)
 -  = \e _     -> exprIsCheapX cheap_app e
 +  = \e _     -> exprIsCheapX True cheap_app e
    | otherwise
 -  = \e mb_ty -> exprIsCheapX cheap_app e
 +  = \e mb_ty -> exprIsCheapX True cheap_app e
               || case mb_ty of
                    Nothing -> False
                    Just ty -> isDictLikeTy ty
 diff --git a/compiler/coreSyn/CoreUnfold.hs
 b/compiler/coreSyn/CoreUnfold.hs
 index c459fd2..f30aca6 100644
 --- a/compiler/coreSyn/CoreUnfold.hs
 +++ b/compiler/coreSyn/CoreUnfold.hs
 @@ -1241,8 +1241,8 @@ tryUnfolding dflags id lone_variable
            = True
            | otherwise
            = case cont_info of
 -              CaseCtxt   -> not (lone_variable && is_wf)  -- Note [Lone
 variables]
 -              ValAppCtxt -> True                              -- Note
 [Cast then apply]
 +              CaseCtxt   -> not (lone_variable && is_exp)  -- Note [Lone
 variables]
 +              ValAppCtxt -> True                           -- Note [Cast
 then apply]
                RuleArgCtxt -> uf_arity > 0  -- See Note [Unfold info lazy
 contexts]
                DiscArgCtxt -> uf_arity > 0  --
                RhsCtxt     -> uf_arity > 0  --
 diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
 index 5e32dc6..c99e05f 100644
 --- a/compiler/coreSyn/CoreUtils.hs
 +++ b/compiler/coreSyn/CoreUtils.hs
 @@ -1131,18 +1131,18 @@ in this (which it previously was):
  -}

  --------------------
 +exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]
 +exprIsWorkFree = exprIsCheapX True isWorkFreeApp
 +
  exprIsCheap :: CoreExpr -> Bool
 -exprIsCheap = exprIsCheapX isCheapApp
 +exprIsCheap = exprIsCheapX True isCheapApp

  exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable]
 -exprIsExpandable = exprIsCheapX isExpandableApp
 -
 -exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]
 -exprIsWorkFree = exprIsCheapX isWorkFreeApp
 +exprIsExpandable = exprIsCheapX False isExpandableApp

  --------------------
 -exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool
 -exprIsCheapX ok_app e
 +exprIsCheapX :: Bool -> CheapAppFun -> CoreExpr -> Bool
 +exprIsCheapX ok_case ok_app e
    = ok e
    where
      ok e = go 0 e
 @@ -1153,7 +1153,8 @@ exprIsCheapX ok_app e
      go _ (Type {})                    = True
      go _ (Coercion {})                = True
      go n (Cast e _)                   = go n e
 -    go n (Case scrut _ _ alts)        = ok scrut &&
 +    go n (Case scrut _ _ alts)        = ok_case &&
 +                                        ok scrut &&
                                          and [ go n rhs | (_,_,rhs) <-
 alts ]
      go n (Tick t e) | tickishCounts t = False
                      | otherwise       = go n e
 }}}

-- 
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/14688#comment:3>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler