{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998

\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
-}


module GHC.Core.Opt.WorkWrap
 ( WwOpts (..)
 , wwTopBinds
 )
where

import GHC.Prelude

import GHC.Core
import GHC.Core.Unfold.Make
import GHC.Core.Utils  ( exprType, exprIsHNF )
import GHC.Core.Type
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Core.SimpleOpt

import GHC.Data.FastString

import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Unique.Supply
import GHC.Types.Basic
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.SourceText
import GHC.Types.Unique

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Monad
import GHC.Core.DataCon

{-
We take Core bindings whose binders have:

\begin{enumerate}

\item Strictness attached (by the front-end of the strictness
analyser), and / or

\item Constructed Product Result information attached by the CPR
analysis pass.

\end{enumerate}

and we return some ``plain'' bindings which have been
worker/wrapper-ified, meaning:

\begin{enumerate}

\item Functions have been split into workers and wrappers where
appropriate.  If a function has both strictness and CPR properties
then only one worker/wrapper doing both transformations is produced;

\item Binders' @IdInfos@ have been updated to reflect the existence of
these workers/wrappers (this is where we get STRICTNESS and CPR pragma
info for exported values).
\end{enumerate}
-}

wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram

wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram
wwTopBinds WwOpts
ww_opts UniqSupply
us CoreProgram
top_binds
  = UniqSupply -> UniqSM CoreProgram -> CoreProgram
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM CoreProgram -> CoreProgram)
-> UniqSM CoreProgram -> CoreProgram
forall a b. (a -> b) -> a -> b
$ (CoreBind -> UniqSM CoreProgram)
-> CoreProgram -> UniqSM CoreProgram
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (WwOpts -> CoreBind -> UniqSM CoreProgram
wwBind WwOpts
ww_opts) CoreProgram
top_binds

{-
************************************************************************
*                                                                      *
\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
*                                                                      *
************************************************************************

@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
turn.  Non-recursive case first, then recursive...
-}

wwBind  :: WwOpts
        -> CoreBind
        -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;
                                -- the caller will convert to Expr/Binding,
                                -- as appropriate.

wwBind :: WwOpts -> CoreBind -> UniqSM CoreProgram
wwBind WwOpts
ww_opts (NonRec Var
binder CoreExpr
rhs) = do
    CoreExpr
new_rhs   <- WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
rhs
    [(Var, CoreExpr)]
new_pairs <- WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)]
tryWW WwOpts
ww_opts RecFlag
NonRecursive Var
binder CoreExpr
new_rhs
    CoreProgram -> UniqSM CoreProgram
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
b CoreExpr
e | (Var
b,CoreExpr
e) <- [(Var, CoreExpr)]
new_pairs]
      -- Generated bindings must be non-recursive
      -- because the original binding was.

wwBind WwOpts
ww_opts (Rec [(Var, CoreExpr)]
pairs)
  = CoreBind -> CoreProgram
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreProgram)
-> ([(Var, CoreExpr)] -> CoreBind)
-> [(Var, CoreExpr)]
-> CoreProgram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Var, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Var, CoreExpr)] -> CoreProgram)
-> UniqSM [(Var, CoreExpr)] -> UniqSM CoreProgram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Var, CoreExpr) -> UniqSM [(Var, CoreExpr)])
-> [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (Var, CoreExpr) -> UniqSM [(Var, CoreExpr)]
do_one [(Var, CoreExpr)]
pairs
  where
    do_one :: (Var, CoreExpr) -> UniqSM [(Var, CoreExpr)]
do_one (Var
binder, CoreExpr
rhs) = do CoreExpr
new_rhs <- WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
rhs
                              WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)]
tryWW WwOpts
ww_opts RecFlag
Recursive Var
binder CoreExpr
new_rhs

{-
@wwExpr@ basically just walks the tree, looking for appropriate
annotations that can be used. Remember it is @wwBind@ that does the
matching by looking for strict arguments of the correct type.
@wwExpr@ is a version that just returns the ``Plain'' Tree.
-}

wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr

wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
_ e :: CoreExpr
e@(Type {}) = CoreExpr -> UniqSM CoreExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
wwExpr WwOpts
_ e :: CoreExpr
e@(Coercion {}) = CoreExpr -> UniqSM CoreExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
wwExpr WwOpts
_ e :: CoreExpr
e@(Lit  {}) = CoreExpr -> UniqSM CoreExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
wwExpr WwOpts
_ e :: CoreExpr
e@(Var  {}) = CoreExpr -> UniqSM CoreExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e

wwExpr WwOpts
ww_opts (Lam Var
binder CoreExpr
expr)
  = Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
new_binder (CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
expr
  where new_binder :: Var
new_binder | Var -> Bool
isId Var
binder = Var -> Var
zapIdUsedOnceInfo Var
binder
                   | Bool
otherwise   = Var
binder
  -- See Note [Zapping Used Once info in WorkWrap]

wwExpr WwOpts
ww_opts (App CoreExpr
f CoreExpr
a)
  = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr)
-> UniqSM CoreExpr -> UniqSM (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
f UniqSM (CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM CoreExpr
forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
a

wwExpr WwOpts
ww_opts (Tick CoreTickish
note CoreExpr
expr)
  = CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
note (CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
expr

wwExpr WwOpts
ww_opts (Cast CoreExpr
expr CoercionR
co) = do
    CoreExpr
new_expr <- WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
expr
    CoreExpr -> UniqSM CoreExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoercionR -> CoreExpr
forall b. Expr b -> CoercionR -> Expr b
Cast CoreExpr
new_expr CoercionR
co)

wwExpr WwOpts
ww_opts (Let CoreBind
bind CoreExpr
expr)
  = CoreProgram -> CoreExpr -> CoreExpr
forall b. [Bind b] -> Expr b -> Expr b
mkLets (CoreProgram -> CoreExpr -> CoreExpr)
-> UniqSM CoreProgram -> UniqSM (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WwOpts -> CoreBind -> UniqSM CoreProgram
wwBind WwOpts
ww_opts CoreBind
bind UniqSM (CoreExpr -> CoreExpr) -> UniqSM CoreExpr -> UniqSM CoreExpr
forall a b. UniqSM (a -> b) -> UniqSM a -> UniqSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
expr

wwExpr WwOpts
ww_opts (Case CoreExpr
expr Var
binder Type
ty [Alt Var]
alts) = do
    CoreExpr
new_expr <- WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
expr
    [Alt Var]
new_alts <- (Alt Var -> UniqSM (Alt Var)) -> [Alt Var] -> UniqSM [Alt Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Alt Var -> UniqSM (Alt Var)
ww_alt [Alt Var]
alts
    let new_binder :: Var
new_binder = Var -> Var
zapIdUsedOnceInfo Var
binder
      -- See Note [Zapping Used Once info in WorkWrap]
    CoreExpr -> UniqSM CoreExpr
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
new_expr Var
new_binder Type
ty [Alt Var]
new_alts)
  where
    ww_alt :: Alt Var -> UniqSM (Alt Var)
ww_alt (Alt AltCon
con [Var]
binders CoreExpr
rhs) = do
        CoreExpr
new_rhs <- WwOpts -> CoreExpr -> UniqSM CoreExpr
wwExpr WwOpts
ww_opts CoreExpr
rhs
        let new_binders :: [Var]
new_binders = [ if Var -> Bool
isId Var
b then Var -> Var
zapIdUsedOnceInfo Var
b else Var
b
                          | Var
b <- [Var]
binders ]
           -- See Note [Zapping Used Once info in WorkWrap]
        Alt Var -> UniqSM (Alt Var)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Var]
new_binders CoreExpr
new_rhs)

{-
************************************************************************
*                                                                      *
\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
*                                                                      *
************************************************************************

@tryWW@ just accumulates arguments, converts strictness info from the
front-end into the proper form, then calls @mkWwBodies@ to do
the business.

The only reason this is monadised is for the unique supply.

Note [Don't w/w INLINE things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very important to refrain from w/w-ing an INLINE function (ie one
with a stable unfolding) because the wrapper will then overwrite the
old stable unfolding with the wrapper code.

Furthermore, if the programmer has marked something as INLINE,
we may lose by w/w'ing it.

If the strictness analyser is run twice, this test also prevents
wrappers (which are INLINEd) from being re-done.  (You can end up with
several liked-named Ids bouncing around at the same time---absolute
mischief.)

Notice that we refrain from w/w'ing an INLINE function even if it is
in a recursive group.  It might not be the loop breaker.  (We could
test for loop-breaker-hood, but I'm not sure that ever matters.)

Note [Worker/wrapper for INLINABLE functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have
  {-# INLINABLE f #-}
  f :: Ord a => [a] -> Int -> a
  f x y = ....f....

where f is strict in y, we might get a more efficient loop by w/w'ing
f.  But that would make a new unfolding which would overwrite the old
one! So the function would no longer be INLINABLE, and in particular
will not be specialised at call sites in other modules.

This comes up in practice (#6056).

Solution:

* Do the w/w for strictness analysis, even for INLINABLE functions

* Transfer the Stable unfolding to the *worker*.  How do we "transfer
  the unfolding"? Easy: by using the old one, wrapped in work_fn! See
  GHC.Core.Unfold.Make.mkWorkerUnfolding.

* We use the /original, user-specified/ function's InlineSpec pragma
  for both the wrapper and the worker (see `mkStrWrapperInlinePrag`).
  So if f is INLINEABLE, both worker and wrapper will get an InlineSpec
  of (Inlinable "blah").

  It's important that both get this, because the specialiser uses
  the existence of a /user-specified/ INLINE/INLINABLE pragma to
  drive specialisation of imported functions.  See  GHC.Core.Opt.Specialise
  Note [Specialising imported functions]

* Remember, the subsequent inlining behaviour of the wrapper is expressed by
  (a) the stable unfolding
  (b) the unfolding guidance of UnfWhen
  (c) the inl_act activation (see Note [Wrapper activation]

For our {-# INLINEABLE f #-} example above, we will get something a
bit like like this:

  {-# Has stable unfolding, active in phase 2;
      plus InlineSpec = INLINEABLE #-}
  f :: Ord a => [a] -> Int -> a
  f d x y = case y of I# y' -> fw d x y'

  {-# Has stable unfolding, plus InlineSpec = INLINEABLE #-}
  fw :: Ord a => [a] -> Int# -> a
  fw d x y' = let y = I# y' in ...f...


(Historical note: we used to always give the wrapper an INLINE pragma,
but CSE will not happen if there is a user-specified pragma, but
should happen for w/w’ed things (#14186).  But now we simply propagate
any user-defined pragma info, so we'll defeat CSE (rightly) only when
there is a user-supplied INLINE/INLINEABLE pragma.)

Note [No worker/wrapper for record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We sometimes generate a lot of record selectors, and generally the
don't benefit from worker/wrapper.  Yes, mkWwBodies would find a w/w split,
but it is then suppressed by the certainlyWillInline test in splitFun.

The wasted effort in mkWwBodies makes a measurable difference in
compile time (see MR !2873), so although it's a terribly ad-hoc test,
we just check here for record selectors, and do a no-op in that case.

I did look for a generalisation, so that it's not just record
selectors that benefit.  But you'd need a cheap test for "this
function will definitely get a w/w split" and that's hard to predict
in advance...the logic in mkWwBodies is complex. So I've left the
super-simple test, with this Note to explain.

NB: record selectors are ordinary functions, inlined iff GHC wants to,
so won't be caught by the preceding isInlineUnfolding test in tryWW.

Note [Worker/wrapper for NOINLINE functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to disable worker/wrapper for NOINLINE things, but it turns out
this can cause unnecessary reboxing of values. Consider

  {-# NOINLINE f #-}
  f :: Int -> a
  f x = error (show x)

  g :: Bool -> Bool -> Int -> Int
  g True  True  p = f p
  g False True  p = p + 1
  g b     False p = g b True p

the strictness analysis will discover f and g are strict, but because f
has no wrapper, the worker for g will rebox p. So we get

  $wg x y p# =
    let p = I# p# in  -- Yikes! Reboxing!
    case x of
      False ->
        case y of
          False -> $wg False True p#
          True -> +# p# 1#
      True ->
        case y of
          False -> $wg True True p#
          True -> case f p of { }

  g x y p = case p of (I# p#) -> $wg x y p#

Now, in this case the reboxing will float into the True branch, and so
the allocation will only happen on the error path. But it won't float
inwards if there are multiple branches that call (f p), so the reboxing
will happen on every call of g. Disaster.

Solution: do worker/wrapper even on NOINLINE things; but move the
NOINLINE pragma to the worker.

(See #13143 for a real-world example.)

It is crucial that we do this for *all* NOINLINE functions. #10069
demonstrates what happens when we promise to w/w a (NOINLINE) leaf
function, but fail to deliver:

  data C = C Int# Int#

  {-# NOINLINE c1 #-}
  c1 :: C -> Int#
  c1 (C _ n) = n

  {-# NOINLINE fc #-}
  fc :: C -> Int#
  fc c = 2 *# c1 c

Failing to w/w `c1`, but still w/wing `fc` leads to the following code:

  c1 :: C -> Int#
  c1 (C _ n) = n

  $wfc :: Int# -> Int#
  $wfc n = let c = C 0# n in 2 #* c1 c

  fc :: C -> Int#
  fc (C _ n) = $wfc n

Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place.
This generalises to any function that derives its strictness signature from
its callees, so we have to make sure that when a function announces particular
strictness properties, we have to w/w them accordingly, even if it means
splitting a NOINLINE function.

Note [Worker activation]
~~~~~~~~~~~~~~~~~~~~~~~~
Follows on from Note [Worker/wrapper for INLINABLE functions]

It is *vital* that if the worker gets an INLINABLE pragma (from the
original function), then the worker has the same phase activation as
the wrapper (or later).  That is necessary to allow the wrapper to
inline into the worker's unfolding: see GHC.Core.Opt.Simplify.Utils
Note [Simplifying inside stable unfoldings].

If the original is NOINLINE, it's important that the worker inherits the
original activation. Consider

  {-# NOINLINE expensive #-}
  expensive x = x + 1

  f y = let z = expensive y in ...

If expensive's worker inherits the wrapper's activation,
we'll get this (because of the compromise in point (2) of
Note [Wrapper activation])

  {-# NOINLINE[Final] $wexpensive #-}
  $wexpensive x = x + 1
  {-# INLINE[Final] expensive #-}
  expensive x = $wexpensive x

  f y = let z = expensive y in ...

and $wexpensive will be immediately inlined into expensive, followed by
expensive into f. This effectively removes the original NOINLINE!

Otherwise, nothing is lost by giving the worker the same activation as the
wrapper, because the worker won't have any chance of inlining until the
wrapper does; there's no point in giving it an earlier activation.

Note [Don't w/w inline small non-loop-breaker things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general, we refrain from w/w-ing *small* functions, which are not
loop breakers, because they'll inline anyway.  But we must take care:
it may look small now, but get to be big later after other inlining
has happened.  So we take the precaution of adding a StableUnfolding
for any such functions.

I made this change when I observed a big function at the end of
compilation with a useful strictness signature but no w-w.  (It was
small during demand analysis, we refrained from w/w, and then got big
when something was inlined in its rhs.) When I measured it on nofib,
it didn't make much difference; just a few percent improved allocation
on one benchmark (bspt/Euclid.space).  But nothing got worse.

There is an infelicity though.  We may get something like
      f = g val
==>
      g x = case gw x of r -> I# r

      f {- InlineStable, Template = g val -}
      f = case gw x of r -> I# r

The code for f duplicates that for g, without any real benefit. It
won't really be executed, because calls to f will go via the inlining.

Note [Don't w/w join points for CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There's no point in exploiting CPR info on a join point. If the whole function
is getting CPR'd, then the case expression around the worker function will get
pushed into the join point by the simplifier, which will have the same effect
that w/w'ing for CPR would have - the result will be returned in an unboxed
tuple.

  f z = let join j x y = (x+1, y+1)
        in case z of A -> j 1 2
                     B -> j 2 3

  =>

  f z = case $wf z of (# a, b #) -> (a, b)
  $wf z = case (let join j x y = (x+1, y+1)
                in case z of A -> j 1 2
                             B -> j 2 3) of (a, b) -> (# a, b #)

  =>

  f z = case $wf z of (# a, b #) -> (a, b)
  $wf z = let join j x y = (# x+1, y+1 #)
          in case z of A -> j 1 2
                       B -> j 2 3

Note that we still want to give `j` the CPR property, so that `f` has it. So
CPR *analyse* join points as regular functions, but don't *transform* them.

We could retain the CPR /signature/ on the worker after W/W, but it would
become outright wrong if the Simplifier pushes a non-trivial continuation
into it. For example:
    case (let $j x = (x,x) in ...) of alts
    ==>
    let $j x = case (x,x) of alts in case ... of alts
Before pushing the case in, `$j` has the CPR property, but not afterwards.

So we simply zap the CPR signature for join pints as part of the W/W pass.
The signature served its purpose during CPR analysis in propagating the
CPR property of `$j`.

Doing W/W for returned products on a join point would be tricky anyway, as the
worker could not be a join point because it would not be tail-called. However,
doing the *argument* part of W/W still works for join points, since the wrapper
body will make a tail call:

  f z = let join j x y = x + y
        in ...

  =>

  f z = let join $wj x# y# = x# +# y#
                 j x y = case x of I# x# ->
                         case y of I# y# ->
                         $wj x# y#
        in ...

Note [Wrapper activation]
~~~~~~~~~~~~~~~~~~~~~~~~~
When should the wrapper inlining be active?

1. It must not be active earlier than the current Activation of the Id,
   because we must give rewrite rules mentioning the wrapper and
   specialisation a chance to fire.
   See Note [Worker/wrapper for INLINABLE functions]
   and Note [Worker activation]

2. It should be active at some point, despite (1) because of
   Note [Worker/wrapper for NOINLINE functions]

3. For ordinary functions with no pragmas we want to inline the
   wrapper as early as possible (#15056).  Suppose another module
   defines    f !x xs = ... foldr k z xs ...
   and suppose we have the usual foldr/build RULE.  Then if we have
   a call `f x [1..x]`, we'd expect to inline f and the RULE will fire.
   But if f is w/w'd (which it might be), we want the inlining to
   occur just as if it hadn't been.

   (This only matters if f's RHS is big enough to w/w, but small
   enough to inline given the call site, but that can happen.)

4. We do not want to inline the wrapper before specialisation.
         module Foo where
           f :: Num a => a -> Int -> a
           f n 0 = n              -- Strict in the Int, hence wrapper
           f n x = f (n+n) (x-1)

           g :: Int -> Int
           g x = f x x            -- Provokes a specialisation for f

         module Bar where
           import Foo

           h :: Int -> Int
           h x = f 3 x

   In module Bar we want to give specialisations a chance to fire
   before inlining f's wrapper.

   (Historical note: At one stage I tried making the wrapper inlining
   always-active, and that had a very bad effect on nofib/imaginary/x2n1;
   a wrapper was inlined before the specialisation fired.)

4a. If we have
      {-# SPECIALISE foo :: (Int,Int) -> Bool -> Int #-}
      {-# NOINLINE [n] foo #-}
    then specialisation will generate a SPEC rule active from Phase n.
    See Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise
    This SPEC specialisation rule will compete with inlining, but we don't
    mind that, because if inlining succeeds, it should be better.

    Now, if we w/w foo, we must ensure that the wrapper (which is very
    keen to inline) has a phase /after/ 'n', else it'll always "win" over
    the SPEC rule -- disaster (#20709).

Conclusion: the activation for the wrapper should be the /later/ of
  (a) the current activation of the function, or FinalPhase if it is NOINLINE
  (b) one phase /after/ the activation of any rules
This is implemented by mkStrWrapperInlinePrag.

Reminder: Note [Don't w/w INLINE things], so we don't need to worry
          about INLINE things here.


What if `foo` has no specialisations, is worker/wrappered (with the
wrapper inlining very early), and exported; and then in an importing
module we have {-# SPECIALISE foo : ... #-}?

Well then, we'll specialise foo's wrapper, which will expose a
specialisation for foo's worker, which we will do too.  That seems
fine.  (To work reliably, `foo` would need an INLINABLE pragma,
in which case we don't unpack dictionaries for the worker; see
see Note [Do not unbox class dictionaries].)

Note [Drop absent bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#19824):
   let t = ...big...
   in ...(f t x)...

were `f` ignores its first argument.  With luck f's wrapper will inline
thereby dropping `t`, but maybe not: the arguments to f all look boring.

So we pre-empt the problem by replacing t's RHS with an absent filler.
Simple and effective.
-}

tryWW   :: WwOpts
        -> RecFlag
        -> Id                           -- The fn binder
        -> CoreExpr                     -- The bound rhs; its innards
                                        --   are already ww'd
        -> UniqSM [(Id, CoreExpr)]      -- either *one* or *two* pairs;
                                        -- if one, then no worker (only
                                        -- the orig "wrapper" lives on);
                                        -- if two, then a worker and a
                                        -- wrapper.
tryWW :: WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)]
tryWW WwOpts
ww_opts RecFlag
is_rec Var
fn_id CoreExpr
rhs
  -- See Note [Drop absent bindings]
  | Demand -> Bool
isAbsDmd (IdInfo -> Demand
demandInfo IdInfo
fn_info)
  , Bool -> Bool
not (Var -> Bool
isJoinId Var
fn_id)
  , Just CoreExpr
filler <- WwOpts -> Var -> StrictnessMark -> Maybe CoreExpr
mkAbsentFiller WwOpts
ww_opts Var
fn_id StrictnessMark
NotMarkedStrict
  = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Var
new_fn_id, CoreExpr
filler)]

  -- See Note [Don't w/w INLINE things]
  | IdInfo -> Bool
hasInlineUnfolding IdInfo
fn_info
  = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Var
new_fn_id, CoreExpr
rhs)]

  -- See Note [No worker/wrapper for record selectors]
  | Var -> Bool
isRecordSelector Var
fn_id
  = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Var
new_fn_id, CoreExpr
rhs ) ]

  -- Don't w/w OPAQUE things
  -- See Note [OPAQUE pragma]
  --
  -- Whilst this check might seem superfluous, since we strip boxity
  -- information in GHC.Core.Opt.DmdAnal.finaliseArgBoxities and
  -- CPR information in GHC.Core.Opt.CprAnal.cprAnalBind, it actually
  -- isn't. That is because we would still perform w/w when:
  --
  -- - An argument is used strictly, and -fworker-wrapper-cbv is
  --   enabled, or,
  -- - When demand analysis marks an argument as absent.
  --
  -- In a debug build we do assert that boxity and CPR information
  -- are actually stripped, since we want to prevent callers of OPAQUE
  -- things to do reboxing. See:
  -- - Note [The OPAQUE pragma and avoiding the reboxing of arguments]
  -- - Note [The OPAQUE pragma and avoiding the reboxing of results]
  | InlinePragma -> Bool
isOpaquePragma (IdInfo -> InlinePragma
inlinePragInfo IdInfo
fn_info)
  = Bool
-> SDoc -> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (DmdSig -> Bool
onlyBoxedArguments (IdInfo -> DmdSig
dmdSigInfo IdInfo
fn_info) Bool -> Bool -> Bool
&&
               CprSig -> Bool
isTopCprSig (IdInfo -> CprSig
cprSigInfo IdInfo
fn_info))
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"OPAQUE fun with boxity" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
               Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
new_fn_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
               DmdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IdInfo -> DmdSig
dmdSigInfo IdInfo
fn_info) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
               CprSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IdInfo -> CprSig
cprSigInfo IdInfo
fn_info) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
               CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
rhs) (UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)])
-> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a b. (a -> b) -> a -> b
$
    [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Var
new_fn_id, CoreExpr
rhs) ]

  -- Do this even if there is a NOINLINE pragma
  -- See Note [Worker/wrapper for NOINLINE functions]
  | Bool
is_fun
  = WwOpts -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)]
splitFun WwOpts
ww_opts Var
new_fn_id CoreExpr
rhs

  -- See Note [Thunk splitting]
  | RecFlag -> Bool
isNonRec RecFlag
is_rec, Bool
is_thunk
  = WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)]
splitThunk WwOpts
ww_opts RecFlag
is_rec Var
new_fn_id CoreExpr
rhs

  | Bool
otherwise
  = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Var
new_fn_id, CoreExpr
rhs) ]

  where
    fn_info :: IdInfo
fn_info        = HasDebugCallStack => Var -> IdInfo
Var -> IdInfo
idInfo Var
fn_id
    ([Demand]
wrap_dmds, Divergence
_) = DmdSig -> ([Demand], Divergence)
splitDmdSig (IdInfo -> DmdSig
dmdSigInfo IdInfo
fn_info)
    new_fn_id :: Var
new_fn_id      = Var -> Var
zap_join_cpr (Var -> Var) -> Var -> Var
forall a b. (a -> b) -> a -> b
$ Var -> Var
zap_usage Var
fn_id

    zap_usage :: Var -> Var
zap_usage = Var -> Var
zapIdUsedOnceInfo (Var -> Var) -> (Var -> Var) -> Var -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Var
zapIdUsageEnvInfo
        -- See Note [Zapping DmdEnv after Demand Analyzer] and
        -- See Note [Zapping Used Once info in WorkWrap]

    zap_join_cpr :: Var -> Var
zap_join_cpr Var
id
      | Var -> Bool
isJoinId Var
id = Var
id Var -> CprSig -> Var
`setIdCprSig` CprSig
topCprSig
      | Bool
otherwise   = Var
id
        -- See Note [Don't w/w join points for CPR]

    is_fun :: Bool
is_fun     = [Demand] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Demand]
wrap_dmds Bool -> Bool -> Bool
|| Var -> Bool
isJoinId Var
fn_id
    is_thunk :: Bool
is_thunk   = Bool -> Bool
not Bool
is_fun Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreExpr -> Bool
exprIsHNF CoreExpr
rhs) Bool -> Bool -> Bool
&& Bool -> Bool
not (Var -> Bool
isJoinId Var
fn_id)
                            Bool -> Bool -> Bool
&& Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Var -> Type
idType Var
fn_id))

{-
Note [Zapping DmdEnv after Demand Analyzer]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the worker-wrapper pass we zap the DmdEnv.  Why?
 (a) it is never used again
 (b) it wastes space
 (c) it becomes incorrect as things are cloned, because
     we don't push the substitution into it

Why here?
 * Because we don’t want to do it in the Demand Analyzer, as we never know
   there when we are doing the last pass.
 * We want them to be still there at the end of DmdAnal, so that
   -ddump-str-anal contains them.
 * We don’t want a second pass just for that.
 * WorkWrap looks at all bindings anyway.

We also need to do it in TidyCore.tidyLetBndr to clean up after the
final, worker/wrapper-less run of the demand analyser (see
Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal).

Note [Zapping Used Once info in WorkWrap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
During the work/wrap pass, using zapIdUsedOnceInfo, we zap the "used once" info
* on every binder (let binders, case binders, lambda binders)
* in both demands and in strictness signatures
* recursively

Why?
 * The simplifier may happen to transform code in a way that invalidates the
   data (see #11731 for an example).
 * It is not used in later passes, up to code generation.

At first it's hard to see how the simplifier might invalidate it (and
indeed for a while I thought it couldn't: #19482), but it's not quite
as simple as I thought.  Consider this:
  {-# STRICTNESS SIG <SP(M,A)> #-}
  f p = let v = case p of (a,b) -> a
        in p `seq` (v,v)

I think we'll give `f` the strictness signature `<SP(M,A)>`, where the
`M` says that we'll evaluate the first component of the pair at most
once.  Why?  Because the RHS of the thunk `v` is evaluated at most
once.

But now let's worker/wrapper f:
  {-# STRICTNESS SIG <M> #-}
  $wf p1 = let p2 = absentError "urk" in
           let p = (p1,p2) in
           let v = case p of (a,b) -> a
           in p `seq` (v,v)

where I've gotten the demand on `p1` by decomposing the P(M,A) argument demand.
This rapidly simplifies to
  {-# STRICTNESS SIG <M> #-}
  $wf p1 = let v = p1 in
           (v,v)

and thence to `(p1,p1)` by inlining the trivial let. Now the demand on `p1` should
not be at most once!!

Conclusion: used-once info is fragile to simplification, because of
the non-monotonic behaviour of let's, which turn used-many into
used-once.  So indeed we should zap this info in worker/wrapper.

Conclusion: kill it during worker/wrapper, using `zapUsedOnceInfo`.
Both the *demand signature* of the binder, and the *demand-info* of
the binder.  Moreover, do so recursively.

You might wonder: why do we generate used-once info if we then throw
it away.  The main reason is that we do a final run of the demand analyser,
immediately before CoreTidy, which is /not/ followed by worker/wrapper; it
is there only to generate used-once info for single-entry thunks.

Note [Don't eta expand in w/w]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A binding where the manifestArity of the RHS is less than idArity of
the binder means GHC.Core.Opt.Arity didn't eta expand that binding
When this happens, it does so for a reason (see Note [Arity invariants for bindings]
in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression
as RHS.

Below is a historical account of what happened when w/w still did eta expansion.
Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing
a demand signature meant for e.g. 2 args to be unleashed for e.g. 1 arg
(manifest arity). That's at least as terrible as doing eta expansion, so don't
do it.
---
When worker/wrapper did eta expansion, it implictly eta expanded the binding to
idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with
divergence, it's also broken for newtypes:

  f = (\xy.blah) |> co
    where
      co :: (Int -> Int -> Char) ~ T

Then idArity is 2 (despite the type T), and it can have a DmdSig based on a
threshold of 2. But we can't w/w it without a type error.

The situation is less grave for PAPs, but the implicit eta expansion caused a
compiler allocation regression in T15164, where huge recursive instance method
groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the
simplifier, when simply waiting for the PAPs to inline arrived at the same
output program.

Note there is the worry here that such PAPs and trivial RHSs might not *always*
be inlined. That would lead to reboxing, because the analysis tacitly assumes
that we W/W'd for idArity and will propagate analysis information under that
assumption. So far, this doesn't seem to matter in practice.
See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.

Note [Inline pragma for certainlyWillInline]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (#19824 comment on 15 May 21):
  f _ (x,y) = ...big...
  v = ...big...
  g x = f v x + 1

So `f` will generate a worker/wrapper split; and `g` (since it is small)
will trigger the certainlyWillInline case of splitFun.  The danger is that
we end up with
  g {- StableUnfolding = \x -> f v x + 1 -}
    = ...blah...

Since (a) that unfolding for g is AlwaysActive
      (b) the unfolding for f's wrapper is ActiveAfterInitial
the call of f will never inline in g's stable unfolding, thereby
keeping `v` alive.

I thought of changing g's unfolding to be ActiveAfterInitial, but that
too is bad: it delays g's inlining into other modules, which makes fewer
specialisations happen. Example in perf/should_run/DeriveNull.

So I decided to live with the problem.  In fact v's RHS will be replaced
by LitRubbish (see Note [Drop absent bindings]) so there is no great harm.
-}


---------------------
splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)]
splitFun :: WwOpts -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)]
splitFun WwOpts
ww_opts Var
fn_id CoreExpr
rhs
  | Just ([Var]
arg_vars, CoreExpr
body) <- Arity -> CoreExpr -> Maybe ([Var], CoreExpr)
collectNValBinders_maybe ([Demand] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Demand]
wrap_dmds) CoreExpr
rhs
  = Bool
-> String
-> SDoc
-> UniqSM [(Var, CoreExpr)]
-> UniqSM [(Var, CoreExpr)]
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not ([Demand]
wrap_dmds [Demand] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` (IdInfo -> Arity
arityInfo IdInfo
fn_info)))
                 String
"splitFun"
                 (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fn_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
wrap_dmds SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Cpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cpr
cpr)) (UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)])
-> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a b. (a -> b) -> a -> b
$
    do { Maybe WwResult
mb_stuff <- WwOpts
-> Var
-> [Var]
-> Type
-> [Demand]
-> Cpr
-> UniqSM (Maybe WwResult)
mkWwBodies WwOpts
ww_opts Var
fn_id [Var]
arg_vars (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body) [Demand]
wrap_dmds Cpr
cpr
       ; case Maybe WwResult
mb_stuff of
            Maybe WwResult
Nothing -> -- No useful wrapper; leave the binding alone
                       [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Var
fn_id, CoreExpr
rhs)]

            Just WwResult
stuff
              | let opt_wwd_rhs :: CoreExpr
opt_wwd_rhs = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr (WwOpts -> SimpleOpts
wo_simple_opts WwOpts
ww_opts) CoreExpr
rhs
                  -- We need to stabilise the WW'd (and optimised) RHS below
              , Just Unfolding
stable_unf <- UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding
certainlyWillInline UnfoldingOpts
uf_opts IdInfo
fn_info CoreExpr
opt_wwd_rhs
                -- We could make a w/w split, but in fact the RHS is small
                -- See Note [Don't w/w inline small non-loop-breaker things]
              , let id_w_unf :: Var
id_w_unf = Var
fn_id Var -> Unfolding -> Var
`setIdUnfolding` Unfolding
stable_unf
                -- See Note [Inline pragma for certainlyWillInline]
              ->  [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Var
id_w_unf, CoreExpr
rhs) ]

              | Bool
otherwise
              -> do { Unique
work_uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
                    ; [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (WwOpts
-> Var
-> IdInfo
-> [Var]
-> CoreExpr
-> Unique
-> Divergence
-> WwResult
-> [(Var, CoreExpr)]
mkWWBindPair WwOpts
ww_opts Var
fn_id IdInfo
fn_info [Var]
arg_vars CoreExpr
body
                                           Unique
work_uniq Divergence
div WwResult
stuff) } }

  | Bool
otherwise    -- See Note [Don't eta expand in w/w]
  = [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Var
fn_id, CoreExpr
rhs)]

  where
    uf_opts :: UnfoldingOpts
uf_opts = SimpleOpts -> UnfoldingOpts
so_uf_opts (WwOpts -> SimpleOpts
wo_simple_opts WwOpts
ww_opts)
    fn_info :: IdInfo
fn_info = HasDebugCallStack => Var -> IdInfo
Var -> IdInfo
idInfo Var
fn_id

    ([Demand]
wrap_dmds, Divergence
div) = DmdSig -> ([Demand], Divergence)
splitDmdSig (IdInfo -> DmdSig
dmdSigInfo IdInfo
fn_info)

    cpr_ty :: CprType
cpr_ty = CprSig -> CprType
getCprSig (IdInfo -> CprSig
cprSigInfo IdInfo
fn_info)
    -- Arity of the CPR sig should match idArity when it's not a join point.
    -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal
    cpr :: Cpr
cpr = Bool -> SDoc -> Cpr -> Cpr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Var -> Bool
isJoinId Var
fn_id Bool -> Bool -> Bool
|| CprType
cpr_ty CprType -> CprType -> Bool
forall a. Eq a => a -> a -> Bool
== CprType
topCprType Bool -> Bool -> Bool
|| CprType -> Arity
ct_arty CprType
cpr_ty Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== IdInfo -> Arity
arityInfo IdInfo
fn_info)
                    (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fn_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ct_arty:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Arity -> SDoc
forall doc. IsLine doc => Arity -> doc
int (CprType -> Arity
ct_arty CprType
cpr_ty)
                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arityInfo:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IdInfo -> Arity
arityInfo IdInfo
fn_info)) (Cpr -> Cpr) -> Cpr -> Cpr
forall a b. (a -> b) -> a -> b
$
          CprType -> Cpr
ct_cpr CprType
cpr_ty

mkWWBindPair :: WwOpts -> Id -> IdInfo
             -> [Var] -> CoreExpr -> Unique -> Divergence
             -> ([Demand],JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)
             -> [(Id, CoreExpr)]
mkWWBindPair :: WwOpts
-> Var
-> IdInfo
-> [Var]
-> CoreExpr
-> Unique
-> Divergence
-> WwResult
-> [(Var, CoreExpr)]
mkWWBindPair WwOpts
ww_opts Var
fn_id IdInfo
fn_info [Var]
fn_args CoreExpr
fn_body Unique
work_uniq Divergence
div
             ([Demand]
work_demands, Arity
join_arity, Var -> CoreExpr
wrap_fn, CoreExpr -> CoreExpr
work_fn)
  = -- pprTrace "mkWWBindPair" (ppr fn_id <+> ppr wrap_id <+> ppr work_id $$ ppr wrap_rhs) $
    [(Var
work_id, CoreExpr
work_rhs), (Var
wrap_id, CoreExpr
wrap_rhs)]
     -- Worker first, because wrapper mentions it
  where
    arity :: Arity
arity = IdInfo -> Arity
arityInfo IdInfo
fn_info
            -- The arity is set by the simplifier using exprEtaExpandArity
            -- So it may be more than the number of top-level-visible lambdas

    simpl_opts :: SimpleOpts
simpl_opts = WwOpts -> SimpleOpts
wo_simple_opts WwOpts
ww_opts

    work_rhs :: CoreExpr
work_rhs = CoreExpr -> CoreExpr
work_fn ([Var] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
fn_args CoreExpr
fn_body)
    work_act :: Activation
work_act = case InlineSpec
fn_inline_spec of  -- See Note [Worker activation]
                   NoInline SourceText
_  -> InlinePragma -> Activation
inl_act InlinePragma
fn_inl_prag
                   InlineSpec
_           -> InlinePragma -> Activation
inl_act InlinePragma
wrap_prag

    work_prag :: InlinePragma
work_prag = InlinePragma { inl_src :: SourceText
inl_src = FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"{-# INLINE"
                             , inl_inline :: InlineSpec
inl_inline = InlineSpec
fn_inline_spec
                             , inl_sat :: Maybe Arity
inl_sat    = Maybe Arity
forall a. Maybe a
Nothing
                             , inl_act :: Activation
inl_act    = Activation
work_act
                             , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatchInfo
FunLike }
      -- inl_inline: copy from fn_id; see Note [Worker/wrapper for INLINABLE functions]
      -- inl_act:    see Note [Worker activation]
      -- inl_rule:   it does not make sense for workers to be constructorlike.

    work_join_arity :: Maybe Arity
work_join_arity | Var -> Bool
isJoinId Var
fn_id = Arity -> Maybe Arity
forall a. a -> Maybe a
Just Arity
join_arity
                    | Bool
otherwise      = Maybe Arity
forall a. Maybe a
Nothing
      -- worker is join point iff wrapper is join point
      -- (see Note [Don't w/w join points for CPR])

    work_id :: Var
work_id  = Var -> Var
asWorkerLikeId (Var -> Var) -> Var -> Var
forall a b. (a -> b) -> a -> b
$
               Unique -> Var -> Type -> Var
mkWorkerId Unique
work_uniq Var
fn_id (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
work_rhs)
                Var -> OccInfo -> Var
`setIdOccInfo` IdInfo -> OccInfo
occInfo IdInfo
fn_info
                        -- Copy over occurrence info from parent
                        -- Notably whether it's a loop breaker
                        -- Doesn't matter much, since we will simplify next, but
                        -- seems right-er to do so

                Var -> InlinePragma -> Var
`setInlinePragma` InlinePragma
work_prag

                Var -> Unfolding -> Var
`setIdUnfolding` SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
mkWorkerUnfolding SimpleOpts
simpl_opts CoreExpr -> CoreExpr
work_fn Unfolding
fn_unfolding
                        -- See Note [Worker/wrapper for INLINABLE functions]

                Var -> DmdSig -> Var
`setIdDmdSig` [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand]
work_demands Divergence
div
                        -- Even though we may not be at top level,
                        -- it's ok to give it an empty DmdEnv

                Var -> CprSig -> Var
`setIdCprSig` CprSig
topCprSig

                Var -> Demand -> Var
`setIdDemandInfo` Demand
worker_demand

                Var -> Arity -> Var
`setIdArity` Arity
work_arity
                        -- Set the arity so that the Core Lint check that the
                        -- arity is consistent with the demand type goes
                        -- through

                Var -> Maybe Arity -> Var
`asJoinId_maybe` Maybe Arity
work_join_arity

    work_arity :: Arity
work_arity = [Demand] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Demand]
work_demands :: Int

    -- See Note [Demand on the worker]
    single_call :: Bool
single_call = Arity -> Demand -> Bool
saturatedByOneShots Arity
arity (IdInfo -> Demand
demandInfo IdInfo
fn_info)
    worker_demand :: Demand
worker_demand | Bool
single_call = Arity -> Demand
mkWorkerDemand Arity
work_arity
                  | Bool
otherwise   = Demand
topDmd

    wrap_rhs :: CoreExpr
wrap_rhs  = Var -> CoreExpr
wrap_fn Var
work_id
    wrap_prag :: InlinePragma
wrap_prag = InlinePragma -> [CoreRule] -> InlinePragma
mkStrWrapperInlinePrag InlinePragma
fn_inl_prag [CoreRule]
fn_rules
    wrap_unf :: Unfolding
wrap_unf  = SimpleOpts -> CoreExpr -> Arity -> Unfolding
mkWrapperUnfolding SimpleOpts
simpl_opts CoreExpr
wrap_rhs Arity
arity

    wrap_id :: Var
wrap_id   = Var
fn_id Var -> Unfolding -> Var
`setIdUnfolding`  Unfolding
wrap_unf
                      Var -> InlinePragma -> Var
`setInlinePragma` InlinePragma
wrap_prag
                      Var -> OccInfo -> Var
`setIdOccInfo`    OccInfo
noOccInfo
                        -- Zap any loop-breaker-ness, to avoid bleating from Lint
                        -- about a loop breaker with an INLINE rule

    fn_inl_prag :: InlinePragma
fn_inl_prag     = IdInfo -> InlinePragma
inlinePragInfo IdInfo
fn_info
    fn_inline_spec :: InlineSpec
fn_inline_spec  = InlinePragma -> InlineSpec
inl_inline InlinePragma
fn_inl_prag
    fn_unfolding :: Unfolding
fn_unfolding    = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
fn_info
    fn_rules :: [CoreRule]
fn_rules        = RuleInfo -> [CoreRule]
ruleInfoRules (IdInfo -> RuleInfo
ruleInfo IdInfo
fn_info)

mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma
mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma
mkStrWrapperInlinePrag (InlinePragma { inl_inline :: InlinePragma -> InlineSpec
inl_inline = InlineSpec
fn_inl
                                     , inl_act :: InlinePragma -> Activation
inl_act    = Activation
fn_act
                                     , inl_rule :: InlinePragma -> RuleMatchInfo
inl_rule   = RuleMatchInfo
rule_info }) [CoreRule]
rules
  = InlinePragma { inl_src :: SourceText
inl_src    = FastString -> SourceText
SourceText (FastString -> SourceText) -> FastString -> SourceText
forall a b. (a -> b) -> a -> b
$ String -> FastString
fsLit String
"{-# INLINE"
                 , inl_sat :: Maybe Arity
inl_sat    = Maybe Arity
forall a. Maybe a
Nothing

                 , inl_inline :: InlineSpec
inl_inline = InlineSpec
fn_inl
                      -- See Note [Worker/wrapper for INLINABLE functions]

                 , inl_act :: Activation
inl_act    = CompilerPhase -> Activation
activeAfter CompilerPhase
wrapper_phase
                      -- See Note [Wrapper activation]

                 , inl_rule :: RuleMatchInfo
inl_rule   = RuleMatchInfo
rule_info }  -- RuleMatchInfo is (and must be) unaffected
  where
    -- See Note [Wrapper activation]
    wrapper_phase :: CompilerPhase
wrapper_phase = (CoreRule -> CompilerPhase -> CompilerPhase)
-> CompilerPhase -> [CoreRule] -> CompilerPhase
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CompilerPhase -> CompilerPhase -> CompilerPhase
laterPhase (CompilerPhase -> CompilerPhase -> CompilerPhase)
-> (CoreRule -> CompilerPhase)
-> CoreRule
-> CompilerPhase
-> CompilerPhase
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreRule -> CompilerPhase
get_rule_phase) CompilerPhase
earliest_inline_phase [CoreRule]
rules
    earliest_inline_phase :: CompilerPhase
earliest_inline_phase = Activation -> CompilerPhase
beginPhase Activation
fn_act CompilerPhase -> CompilerPhase -> CompilerPhase
`laterPhase` CompilerPhase -> CompilerPhase
nextPhase CompilerPhase
InitialPhase
          -- laterPhase (nextPhase InitialPhase) is a temporary hack
          -- to inline no earlier than phase 2.  I got regressions in
          -- 'mate', due to changes in full laziness due to Note [Case
          -- MFEs], when I did earlier inlining.

    get_rule_phase :: CoreRule -> CompilerPhase
    -- The phase /after/ the rule is first active
    get_rule_phase :: CoreRule -> CompilerPhase
get_rule_phase CoreRule
rule = CompilerPhase -> CompilerPhase
nextPhase (Activation -> CompilerPhase
beginPhase (CoreRule -> Activation
ruleActivation CoreRule
rule))

{-
Note [Demand on the worker]
~~~~~~~~~~~~~~~~~~~~~~~~~~~

If the original function is called once, according to its demand info, then
so is the worker. This is important so that the occurrence analyser can
attach OneShot annotations to the worker’s lambda binders.


Example:

  -- Original function
  f [Demand=<L,1*C(1,U)>] :: (a,a) -> a
  f = \p -> ...

  -- Wrapper
  f [Demand=<L,1*C(1,U)>] :: a -> a -> a
  f = \p -> case p of (a,b) -> $wf a b

  -- Worker
  $wf [Demand=<L,1*C(1,C(1,U))>] :: Int -> Int
  $wf = \a b -> ...

We need to check whether the original function is called once, with
sufficiently many arguments. This is done using saturatedByOneShots, which
takes the arity of the original function (resp. the wrapper) and the demand on
the original function.

The demand on the worker is then calculated using mkWorkerDemand, and always of
the form [Demand=<L,1*(C(1,...(C(1,U))))>]

Note [Thunk splitting]
~~~~~~~~~~~~~~~~~~~~~~
Suppose x is used strictly; never mind whether it has the CPR
property.  I'll use a '*' to mean "x* is demanded strictly".

      let
        x* = x-rhs
      in body

splitThunk transforms like this:
      let
        x* = let x = x-rhs in
             case x of { I# a -> I# a }
      in body

This is a little strange: we are re-using the same `x` in the RHS; and
the RHS takes `x` apart and reboxes it. But because the outer 'let' is
strict, and the inner let mentions `x` only once, the simplifier
transform it to
      case x-rhs of
        I# a -> let x* = I# a
                in body

That is good: in `body` we know the form of `x`, which
  * gives the CPR property, and
  * allows case-of-case to happen on x

Notes
* I tried transforming like this:
      let
        x* = let x = x-rhs in
             case x of { I# a -> x }
      in body
  where I return `x` itself, rather than reboxing it.  But this
  turned out to cause some regressions, which I never fully
  investigated.

* Suppose x-rhs is itself a case:
        x-rhs = case e of { T -> I# e1; F -> I# e2 }
  Then we'll get
      join j a = let x* = I# a in body
      in case e of { T -> j e1; F -> j e2 }
  which is good (no boxing).  But in the original, unsplit program
  we would transform
      let x* = case e of ... in body
  ==> join j2 x = body
      in case e of { T -> j2 (I# e1); F -> j (I# e2) }
  which is not good (boxing).

* In fact, splitThunk uses the function argument w/w splitting
  function, mkWWstr_one, so that if x's demand is deeper (say U(U(L,L),L))
  then the splitting will go deeper too.

* For recursive thunks, the Simplifier is unable to float `x-rhs` out of
  `x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it
  back to the original definition, so we just split non-recursive thunks.

Note [Thunk splitting for top-level binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Top-level bindings are never strict. Yet they can be absent, as T14270 shows:

  module T14270 (mkTrApp) where
  mkTrApp x y
    | Just ... <- ... typeRepKind x ...
    = undefined
    | otherwise
    = undefined
  typeRepKind = Tick scc undefined

(T19180 is a profiling-free test case for this)
Note that `typeRepKind` is not exported and its only use site in
`mkTrApp` guards a bottoming expression. Thus, demand analysis
figures out that `typeRepKind` is absent and splits the thunk to

  typeRepKind =
    let typeRepKind = Tick scc undefined in
    let typeRepKind = absentError in
    typeRepKind

But now we have a local binding with an External Name
(See Note [About the NameSorts]). That will trigger a CoreLint error, which we
get around by localising the Id for the auxiliary bindings in 'splitThunk'.
-}

-- | See Note [Thunk splitting].
--
-- splitThunk converts the *non-recursive* binding
--      x = e
-- into
--      x = let x' = e in
--          case x' of I# y -> let x' = I# y in x'
-- See comments above. Is it not beautifully short?
-- Moreover, it works just as well when there are
-- several binders, and if the binders are lifted
-- E.g.     x = e
--     -->  x = let x' = e in
--              case x' of (a,b) -> let x' = (a,b)  in x'
-- Here, x' is a localised version of x, in case x is a
-- top-level Id with an External Name, because Lint rejects local binders with
-- External Names; see Note [About the NameSorts] in GHC.Types.Name.
--
-- How can we do thunk-splitting on a top-level binder?  See
-- Note [Thunk splitting for top-level binders].
splitThunk :: WwOpts -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
splitThunk :: WwOpts -> RecFlag -> Var -> CoreExpr -> UniqSM [(Var, CoreExpr)]
splitThunk WwOpts
ww_opts RecFlag
is_rec Var
x CoreExpr
rhs
  = Bool -> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Var -> Bool
isJoinId Var
x)) (UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)])
-> UniqSM [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a b. (a -> b) -> a -> b
$
    do { let x' :: Var
x' = Var -> Var
localiseId Var
x -- See comment above
       ; (Bool
useful,[(Var, StrictnessMark)]
_args, CoreExpr -> CoreExpr
wrap_fn, CoreExpr
fn_arg)
           <- WwOpts
-> Var
-> StrictnessMark
-> UniqSM
     (Bool, [(Var, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
mkWWstr_one WwOpts
ww_opts Var
x' StrictnessMark
NotMarkedStrict
       ; let res :: [(Var, CoreExpr)]
res = [ (Var
x, CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
x' CoreExpr
rhs) (CoreExpr -> CoreExpr
wrap_fn CoreExpr
fn_arg)) ]
       ; if Bool
useful then Bool
-> SDoc
-> ([(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)])
-> [(Var, CoreExpr)]
-> UniqSM [(Var, CoreExpr)]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (RecFlag -> Bool
isNonRec RecFlag
is_rec) (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
x) -- The thunk must be non-recursive
                   [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Var, CoreExpr)]
res
                   else [(Var, CoreExpr)] -> UniqSM [(Var, CoreExpr)]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Var
x, CoreExpr
rhs)] }