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

A library for the ``worker\/wrapper'' back-end to the strictness analyser
-}


{-# LANGUAGE ViewPatterns #-}

module GHC.Core.Opt.WorkWrap.Utils
   ( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one
   , needsVoidWorkerArg
   , DataConPatContext(..)
   , UnboxingDecision(..), canUnboxArg
   , findTypeShape, IsRecDataConResult(..), isRecDataCon
   , mkAbsentFiller
   , isWorkerSmallEnough, dubiousDataConInstArgTys
   , boringSplit , usefulSplit
   )
where

import GHC.Prelude

import GHC.Core
import GHC.Core.Utils
import GHC.Core.DataCon
import GHC.Core.Make
import GHC.Core.Subst
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.FamInstEnv
import GHC.Core.TyCon
import GHC.Core.TyCon.Set
import GHC.Core.TyCon.RecWalk
import GHC.Core.SimpleOpt( SimpleOpts )

import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Types.Var.Env
import GHC.Types.Basic
import GHC.Types.Unique.Supply
import GHC.Types.Name ( getOccFS )

import GHC.Data.FastString
import GHC.Data.OrdList
import GHC.Data.List.SetOps

import GHC.Builtin.Types ( tupleDataCon )

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain

import Control.Applicative ( (<|>) )
import Control.Monad ( zipWithM )
import Data.List ( unzip4 )

import GHC.Types.RepType
import GHC.Unit.Types

{-
************************************************************************
*                                                                      *
\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
*                                                                      *
************************************************************************

Here's an example.  The original function is:

\begin{verbatim}
g :: forall a . Int -> [a] -> a

g = \/\ a -> \ x ys ->
        case x of
          0 -> head ys
          _ -> head (tail ys)
\end{verbatim}

From this, we want to produce:
\begin{verbatim}
-- wrapper (an unfolding)
g :: forall a . Int -> [a] -> a

g = \/\ a -> \ x ys ->
        case x of
          I# x# -> $wg a x# ys
            -- call the worker; don't forget the type args!

-- worker
$wg :: forall a . Int# -> [a] -> a

$wg = \/\ a -> \ x# ys ->
        let
            x = I# x#
        in
            case x of               -- note: body of g moved intact
              0 -> head ys
              _ -> head (tail ys)
\end{verbatim}

Something we have to be careful about:  Here's an example:

\begin{verbatim}
-- "f" strictness: U(P)U(P)
f (I# a) (I# b) = a +# b

g = f   -- "g" strictness same as "f"
\end{verbatim}

\tr{f} will get a worker all nice and friendly-like; that's good.
{\em But we don't want a worker for \tr{g}}, even though it has the
same strictness as \tr{f}.  Doing so could break laziness, at best.

Consequently, we insist that the number of strictness-info items is
exactly the same as the number of lambda-bound arguments.  (This is
probably slightly paranoid, but OK in practice.)  If it isn't the
same, we ``revise'' the strictness info, so that we won't propagate
the unusable strictness-info into the interfaces.


************************************************************************
*                                                                      *
\subsection{The worker wrapper core}
*                                                                      *
************************************************************************

@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
-}

data WwOpts
  = MkWwOpts
  { -- | Environment of type/data family instances
    WwOpts -> FamInstEnvs
wo_fam_envs          :: !FamInstEnvs
  , -- | Options for the "Simple optimiser"
    WwOpts -> SimpleOpts
wo_simple_opts       :: !SimpleOpts
  , -- | Whether to enable "Constructed Product Result" analysis.
    -- (Originally from DOI: 10.1017/S0956796803004751)
    WwOpts -> Bool
wo_cpr_anal          :: !Bool
  , -- | Used for absent argument error message
    WwOpts -> Module
wo_module            :: !Module
  , -- | Generate workers even if the only effect is some args get passed
    -- unlifted. See Note [WW for calling convention]
    WwOpts -> Bool
wo_unlift_strict     :: !Bool }

type WwResult
  = ([Demand],              -- Demands for worker (value) args
     JoinArity,             -- Number of worker (type OR value) args
     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs

nop_fn :: CoreExpr -> CoreExpr
nop_fn :: CoreExpr -> CoreExpr
nop_fn CoreExpr
body = CoreExpr
body


mkWwBodies :: WwOpts
           -> Id             -- ^ The original function
           -> [Var]          -- ^ Manifest args of original function
           -> Type           -- ^ Result type of the original function,
                             --   after being stripped of args
           -> [Demand]       -- ^ Strictness of original function
           -> Cpr            -- ^ Info about function result
           -> UniqSM (Maybe WwResult)
-- ^ Given a function definition
--
-- > data T = MkT Int Bool Char
-- > f :: (a, b) -> Int -> T
-- > f = \x y -> E
--
-- @mkWwBodies _ 'f' ['x::(a,b)','y::Int'] '(a,b)' ['1P(L,L)', '1P(L)'] '1'@
-- returns
--
--   * The wrapper body context for the call to the worker function, lacking
--     only the 'Id' for the worker function:
--
--     > W[_] :: Id -> CoreExpr
--     > W[work_fn] = \x y ->          -- args of the wrapper    (cloned_arg_vars)
--     >   case x of (a, b) ->         -- unbox wrapper args     (wrap_fn_str)
--     >   case y of I# n ->           --
--     >   case <work_fn> a b n of     -- call to the worker fun (call_work)
--     >   (# i, b, c #) -> MkT i b c  -- rebox result           (wrap_fn_cpr)
--
--   * The worker body context that wraps around its hole reboxing defns for x
--     and y, as well as returning CPR transit variables of the unboxed MkT
--     result in an unboxed tuple:
--
--     > w[_] :: CoreExpr -> CoreExpr
--     > w[fn_rhs] = \a b n ->              -- args of the worker       (work_lam_args)
--     >   let { y = I# n; x = (a, b) } in  -- reboxing wrapper args    (work_fn_str)
--     >   case <fn_rhs> x y of             -- call to the original RHS (call_rhs)
--     >   MkT i b c -> (# i, b, c #)       -- return CPR transit vars  (work_fn_cpr)
--
--     NB: The wrap_rhs hole is to be filled with the original wrapper RHS
--     @\x y -> E@. This is so that we can also use @w@ to transform stable
--     unfoldings, the lambda args of which may be different than x and y.
--
--   * Id details for the worker function like demands on arguments and its join
--     arity.
--
-- All without looking at E (except for beta reduction, see Note [Join points
-- and beta-redexes]), which allows us to apply the same split to function body
-- and its unfolding(s) alike.
--
mkWwBodies :: WwOpts
-> Id -> [Id] -> Kind -> [Demand] -> Cpr -> UniqSM (Maybe WwResult)
mkWwBodies WwOpts
opts Id
fun_id [Id]
arg_vars Kind
res_ty [Demand]
demands Cpr
res_cpr
  = do  { Bool -> SDoc -> UniqSM ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ((Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isId [Id]
arg_vars [Id] -> [Demand] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Demand]
demands)
                     (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"wrong wrapper arity" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
arg_vars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
res_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
demands)

        -- Clone and prepare arg_vars of the original fun RHS
        -- See Note [Freshen WW arguments]
        -- and Note [Zap IdInfo on worker args]
        ; let args_free_tcvs :: TyCoVarSet
args_free_tcvs = [Kind] -> TyCoVarSet
tyCoVarsOfTypes (Kind
res_ty Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
: (Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
varType [Id]
arg_vars)
              empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst (TyCoVarSet -> InScopeSet
mkInScopeSet TyCoVarSet
args_free_tcvs)
              zapped_arg_vars :: [Id]
zapped_arg_vars = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zap_var [Id]
arg_vars
        ; (Subst
subst, [Id]
cloned_arg_vars) <- Subst -> [Id] -> UniqSM (Subst, [Id])
forall (m :: * -> *).
MonadUnique m =>
Subst -> [Id] -> m (Subst, [Id])
cloneBndrs Subst
empty_subst [Id]
zapped_arg_vars
        ; let res_ty' :: Kind
res_ty' = Subst -> Kind -> Kind
substTyUnchecked Subst
subst Kind
res_ty
              init_str_marks :: [StrictnessMark]
init_str_marks = (Id -> StrictnessMark) -> [Id] -> [StrictnessMark]
forall a b. (a -> b) -> [a] -> [b]
map (StrictnessMark -> Id -> StrictnessMark
forall a b. a -> b -> a
const StrictnessMark
NotMarkedStrict) [Id]
cloned_arg_vars

        ; (Bool
useful1, [(Id, StrictnessMark)]
work_args_str, CoreExpr -> CoreExpr
wrap_fn_str, [CoreExpr]
fn_args)
             <- -- pprTrace "mkWWbodies" (ppr fun_id $$ ppr (arg_vars `zip` cloned_arg_vars) $$ ppr demands) $
                WwOpts
-> [Id]
-> [StrictnessMark]
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
mkWWstr WwOpts
opts [Id]
cloned_arg_vars [StrictnessMark]
init_str_marks

        ; let ([Id]
work_args, [StrictnessMark]
work_marks) = [(Id, StrictnessMark)] -> ([Id], [StrictnessMark])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, StrictnessMark)]
work_args_str

        -- Do CPR w/w.  See Note [Always do CPR w/w]
        ; (Bool
useful2, CoreExpr -> CoreExpr
wrap_fn_cpr, CoreExpr -> CoreExpr
work_fn_cpr)
              <- WwOpts
-> Kind
-> Cpr
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_entry WwOpts
opts Kind
res_ty' Cpr
res_cpr

        ; let ([Id]
work_lam_args, [Id]
work_call_args, [StrictnessMark]
work_call_str)
                | Id -> [Id] -> [Id] -> Bool
needsVoidWorkerArg Id
fun_id [Id]
arg_vars [Id]
work_args
                = [Id] -> [StrictnessMark] -> ([Id], [Id], [StrictnessMark])
addVoidWorkerArg [Id]
work_args [StrictnessMark]
work_marks
                | Bool
otherwise
                = ([Id]
work_args, [Id]
work_args, [StrictnessMark]
work_marks)

              call_work :: Id -> CoreExpr
call_work Id
work_fn  = CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
work_fn) [Id]
work_call_args
              call_rhs :: CoreExpr -> CoreExpr
call_rhs CoreExpr
fn_rhs = CoreExpr -> [CoreExpr] -> CoreExpr
mkAppsBeta CoreExpr
fn_rhs [CoreExpr]
fn_args
                                  -- See Note [Join points and beta-redexes]
              wrapper_body :: Id -> CoreExpr
wrapper_body = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
cloned_arg_vars (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn_cpr (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn_str (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> CoreExpr
call_work
                                  -- See Note [Call-by-value for worker args]
              work_seq_str_flds :: CoreExpr -> CoreExpr
work_seq_str_flds = [(Id, StrictnessMark)] -> CoreExpr -> CoreExpr
mkStrictFieldSeqs ([Id] -> [StrictnessMark] -> [(Id, StrictnessMark)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
work_lam_args [StrictnessMark]
work_call_str)
              worker_body :: CoreExpr -> CoreExpr
worker_body = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
work_lam_args (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_seq_str_flds (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_fn_cpr (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
call_rhs
              worker_args_dmds :: [Demand]
worker_args_dmds= [ Id -> Demand
idDemandInfo Id
v | Id
v <- [Id]
work_call_args, Id -> Bool
isId Id
v]

        ; if ((Bool
useful1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
only_one_void_argument) Bool -> Bool -> Bool
|| Bool
useful2)
          then Maybe WwResult -> UniqSM (Maybe WwResult)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (WwResult -> Maybe WwResult
forall a. a -> Maybe a
Just ([Demand]
worker_args_dmds, [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
work_call_args,
                       Id -> CoreExpr
wrapper_body, CoreExpr -> CoreExpr
worker_body))
          else Maybe WwResult -> UniqSM (Maybe WwResult)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe WwResult
forall a. Maybe a
Nothing
        }
        -- We use an INLINE unconditionally, even if the wrapper turns out to be
        -- something trivial like
        --      fw = ...
        --      f = __inline__ (coerce T fw)
        -- The point is to propagate the coerce to f's call sites, so even though
        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
        -- fw from being inlined into f's RHS
  where
    zap_var :: Id -> Id
zap_var Id
v | Id -> Bool
isTyVar Id
v = Id
v
              | Bool
otherwise = HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo IdInfo -> IdInfo
zap_info Id
v
    zap_info :: IdInfo -> IdInfo
zap_info IdInfo
info -- See Note [Zap IdInfo on worker args]
      = IdInfo
info IdInfo -> OccInfo -> IdInfo
`setOccInfo`       OccInfo
noOccInfo

    -- Note [Do not split void functions]
    only_one_void_argument :: Bool
only_one_void_argument
      | [Demand
d] <- [Demand]
demands
      , [Id
v] <- (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isId [Id]
arg_vars
      , Demand -> Bool
isAbsDmd Demand
d Bool -> Bool -> Bool
&& HasDebugCallStack => Kind -> Bool
Kind -> Bool
isZeroBitTy (Id -> Kind
idType Id
v)
      = Bool
True
      | Bool
otherwise
      = Bool
False

-- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly.
-- PRECONDITION: The arg expressions are not free in any of the lambdas binders.
mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr
-- The precondition holds for our call site in mkWwBodies, because all the FVs
-- of as are either cloned_arg_vars (and thus fresh) or fresh worker args.
mkAppsBeta :: CoreExpr -> [CoreExpr] -> CoreExpr
mkAppsBeta (Lam Id
b CoreExpr
body) (CoreExpr
a:[CoreExpr]
as) = HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
b CoreExpr
a (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$! CoreExpr -> [CoreExpr] -> CoreExpr
mkAppsBeta CoreExpr
body [CoreExpr]
as
mkAppsBeta CoreExpr
f            [CoreExpr]
as     = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
f [CoreExpr]
as

-- See Note [Limit w/w arity]
isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool
isWorkerSmallEnough :: Int -> Int -> [Id] -> Bool
isWorkerSmallEnough Int
max_worker_args Int
old_n_args [Id]
vars
  = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
vars Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
old_n_args Int
max_worker_args
    -- We count only Free variables (isId) to skip Type, Kind
    -- variables which have no runtime representation.
    -- Also if the function took 82 arguments before (old_n_args), it's fine if
    -- it takes <= 82 arguments afterwards.

{-
Note [Always do CPR w/w]
~~~~~~~~~~~~~~~~~~~~~~~~
At one time we refrained from doing CPR w/w for thunks, on the grounds that
we might duplicate work.  But that is already handled by the demand analyser,
which doesn't give the CPR property if w/w might waste work: see
Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.

And if something *has* been given the CPR property and we don't w/w, it's
a disaster, because then the enclosing function might say it has the CPR
property, but now doesn't and there a cascade of disaster.  A good example
is #5920.

Note [Limit w/w arity]
~~~~~~~~~~~~~~~~~~~~~~~~
Guard against high worker arity as it generates a lot of stack traffic.
A simplified example is #11565#comment:6

Current strategy is very simple: don't perform w/w transformation at all
if the result produces a wrapper with arity higher than -fmax-worker-args
and the number arguments before w/w (see #18122).

It is a bit all or nothing, consider

        f (x,y) (a,b,c,d,e ... , z) = rhs

Currently we will remove all w/w ness entirely. But actually we could
w/w on the (x,y) pair... it's the huge product that is the problem.

Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd
solve f. But we can get a lot of args from deeply-nested products:

        g (a, (b, (c, (d, ...)))) = rhs

This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
given some "fuel" saying how many arguments it could add; when we ran
out of fuel it would stop w/wing.

Still not very clever because it had a left-right bias.

Note [Zap IdInfo on worker args]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have to zap the following IdInfo when re-using arg variables of the original
function for the worker:

  * OccInfo: Dead wrapper args now occur in Apps of the worker's call to the
    original fun body. Those occurrences will quickly cancel away with the lambdas
    of the fun body in the next run of the Simplifier, but CoreLint will complain
    in the meantime, so zap it.

We zap in mkWwBodies because we need the zapped variables when binding them in
mkWWstr (mkAbsentFiller, specifically).

Note [Do not split void functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this rather common form of binding:
        $j = \x:Void# -> ...no use of x...

Since x is not used it'll be marked as absent.  But there is no point
in w/w-ing because we'll simply add (\y:Void#), see addVoidWorkerArg.

If x has a more interesting type (eg Int, or Int#), there *is* a point
in w/w so that we don't pass the argument at all.

************************************************************************
*                                                                      *
\subsection{Making wrapper args}
*                                                                      *
************************************************************************

During worker-wrapper stuff we may end up with an unlifted thing
which we want to let-bind without losing laziness.  So we
add a void argument.  E.g.

        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z
==>
        fw = /\ a -> \void -> E
        f  = /\ a -> \x y z -> fw realworld

We use the state-token type which generates no code.
-}

-- | Whether the worker needs an additional `Void#` arg as per
-- Note [Protecting the last value argument] or
-- Note [Preserving float barriers].
needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool
needsVoidWorkerArg :: Id -> [Id] -> [Id] -> Bool
needsVoidWorkerArg Id
fn_id [Id]
wrap_args [Id]
work_args
  =  Bool
thunk_problem         -- See Note [Protecting the last value argument]
  Bool -> Bool -> Bool
|| Bool
needs_float_barrier   -- See Note [Preserving float barriers]
  where
    -- thunk_problem: see Note [Protecting the last value argument]
    -- For join points we are only worried about (4), not (1-4).
    -- And (4) can't happen if (null work_args)
    --     (We could be more clever, by looking at the result type, but
    --      this approach is simple and conservative.)
    thunk_problem :: Bool
thunk_problem | Id -> Bool
isJoinId Id
fn_id = Bool
no_value_arg Bool -> Bool -> Bool
&& Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
work_args)
                  | Bool
otherwise      = Bool
no_value_arg
    no_value_arg :: Bool
no_value_arg = Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isId [Id]
work_args)

    -- needs_float_barrier: see Note [Preserving float barriers]
    needs_float_barrier :: Bool
needs_float_barrier = Bool
wrap_had_barrier Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
work_has_barrier
    is_float_barrier :: Id -> Bool
is_float_barrier Id
v  = Id -> Bool
isId Id
v Bool -> Bool -> Bool
&& OneShotInfo -> Bool
hasNoOneShotInfo (Id -> OneShotInfo
idOneShotInfo Id
v)
    wrap_had_barrier :: Bool
wrap_had_barrier    = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
is_float_barrier [Id]
wrap_args
    work_has_barrier :: Bool
work_has_barrier    = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
is_float_barrier [Id]
work_args

-- | Inserts a `Void#` arg as the last argument.
-- Why last? See Note [Worker/wrapper needs to add void arg last]
addVoidWorkerArg :: [Var] -> [StrictnessMark]
                 -> ( [Var]     -- Lambda bound args
                    , [Var]     -- Args at call site
                    , [StrictnessMark]) -- str semantics for the worker args
addVoidWorkerArg :: [Id] -> [StrictnessMark] -> ([Id], [Id], [StrictnessMark])
addVoidWorkerArg [Id]
work_args [StrictnessMark]
str_marks
  = ( [Id]
work_args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId]
    , [Id]
work_args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidPrimId]
    , [StrictnessMark]
str_marks [StrictnessMark] -> [StrictnessMark] -> [StrictnessMark]
forall a. [a] -> [a] -> [a]
++ [StrictnessMark
NotMarkedStrict] )

{-
Note [Protecting the last value argument]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the user writes (\_ -> E), they might be intentionally disallowing
the sharing of E. Since absence analysis and worker-wrapper are keen
to remove such unused arguments, we add in a void argument to prevent
the function from becoming a thunk.  Here are several reasons why turning
a function into a thunk might be bad:

1) It can create a space leak. e.g.
      f x = let y () = [1..x]
            in (sum (y ()) + length (y ()))
   As written it'll calculate [1..x] twice, and avoid keeping a big
   list around.  (Of course let-floating may introduce the leak; but
   at least w/w doesn't.)

2) It can prevent inlining *under a lambda*. e.g.
       g = \y. [1..100]
       f = \t. g ()
   Here we can inline g under the \t.  But we won't if we remove the \y.

3) It can create an unlifted binding.  E.g.
       g :: Int -> Int#
       g = \x. 30#
   Removing the \x would leave an unlifted binding.

4) It can create a worker of ill-kinded type (#22275).  Consider
     f :: forall r (a :: TYPE r). () -> a
     f x = f x
   Here `x` is absent, but if we simply drop it we'd end up with
     $wf :: forall r (a :: TYPE r). a
   But alas $wf's type is ill-kinded: the kind of (/\r (a::TYPE r).a)
   is (TYPE r), which mentions the bound variable `r`.  See also
   Note [Worker/wrapper needs to add void arg last]

See also Note [Preserving float barriers]

NB: Of these, only (1-3) don't apply to a join point, which can be
unlifted even if the RHS is not ok-for-speculation.

Note [Preserving float barriers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
```
let
  t = sum [0..x]
  f a{os} b[Dmd=A] c{os} = ... t ...
in f 1 2 3 + f 4 5 6
```
Here, we would like to drop the argument `b` because it's absent. But doing so
leaves behind only one-shot lambdas, `$wf a{os} c{os} = ...`, and then the
Simplifier will inline `t` into `$wf`, because `$wf` says "I'm only called
once". That's bad, because we lost sharing of `t`! Similarly, FloatIn would
happily float `t` into `$wf`, see Note [Floating in past a lambda group].

Why does floating happen after dropping `b` but not before? Because `b` was the
only non-one-shot value lambda left, acting as our "float barrier".

Definition:  A float barrier is a non-one-shot value lambda.
Key insight: If `f` had a float barrier, `$wf` has to have one, too.

To this end, in `needsVoidWorkerArg`, we check whether the wrapper had a float
barrier and if the worker has none so far. If that is the case, we add a `Void#`
argument at the end as an artificial float barrier.

The issue is tracked in #21150. It came up when compiling GHC itself, in
GHC.Tc.Gen.Bind.mkEdges. There the key_map thunk was inlined after WW dropped a
leading absent non-one-shot arg. Here are some example wrapper arguments of
which some are absent or one-shot and the resulting worker arguments:

  * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...
    Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#
p  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...
    Worker arg `c` is a float barrier.
  * \a.\b{Abs}.\c{os}... ==> \a.\c{os}...
    Worker arg `a` is a float barrier.
  * \a{os}.\b{Abs,os}.\c{os}... ==> \a{os}.\c{os}...
    Wrapper didn't have a float barrier, no need for Void#.
  * \a{Abs,os}.... ==> ... (no value lambda left)
    This examples simply demonstrates that preserving float barriers is not
    enough to subsume Note [Protecting the last value argument].

Executable examples in T21150.

Note [Worker/wrapper needs to add void arg last]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider point (4) of Note [Protecting the last value argument]

  f :: forall r (a :: TYPE r). () -> a
  f x = f x

As pointed out in (4) we need to add a void argument.  But if we add
it /first/ we'd get

  $wf :: Void# -> forall r (a :: TYPE r). a
  $wf = ...

But alas $wf's type is /still/ still-kinded, just as before in (4).
Solution is simple: put the void argument /last/:

  $wf :: forall r (a :: TYPE r). Void# -> a
  $wf = ...

c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr

Note [Join points and beta-redexes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Originally, the worker would invoke the original function by calling it with
arguments, thus producing a beta-redex for the simplifier to munch away:

  \x y z -> e => (\x y z -> e) wx wy wz

Now that we have special rules about join points, however, this is Not Good if
the original function is itself a join point, as then it may contain invocations
of other join points:

  join j1 x = ...
  join j2 y = if y == 0 then 0 else j1 y

  =>

  join j1 x = ...
  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy
  join j2 y = case y of I# y# -> jump $wj2 y#

There can't be an intervening lambda between a join point's declaration and its
occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:

  ...
  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y
  ...

Hence we simply do the beta-reduction here. (This would be harder if we had to
worry about hygiene, but luckily wy is freshly generated.)

Note [Freshen WW arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we do a worker/wrapper split, we must freshen the arg vars of the original
fun RHS because they might shadow each other. E.g.

  f :: forall a. Maybe a -> forall a. Maybe a -> Int -> Int
  f @a x @a y z = case x <|> y of
    Nothing -> z
    Just _  -> z + 1

  ==> {WW split unboxing the Int}

  $wf :: forall a. Maybe a -> forall a. Maybe a -> Int# -> Int
  $wf @a x @a y wz = (\@a x @a y z -> case x <|> y of ...) ??? x @a y (I# wz)

(Notice that the code we actually emit will sort-of ANF-ise the lambda args,
leading to even more shadowing issues. The above demonstrates that even if we
try harder we'll still get shadowing issues.)

What should we put in place for ??? ? Certainly not @a, because that would
reference the wrong, inner a. A similar situation occurred in #12562, we even
saw a type variable in the worker shadowing an outer term-variable binding.

We avoid the issue by freshening the argument variables from the original fun
RHS through 'cloneBndrs', which will also take care of substitution in binder
types. Fortunately, it's sufficient to pick the FVs of the arg vars as in-scope
set, so that we don't need to do a FV traversal over the whole body of the
original function.

At the moment, #12562 has no regression test. As such, this Note is not covered
by any test logic or when bootstrapping the compiler. Yet we clearly want to
freshen the binders, as the example above demonstrates.
Adding a Core pass that maximises shadowing for testing purposes might help,
see #17478.
-}

{-
************************************************************************
*                                                                      *
\subsection{Unboxing Decision for Strictness and CPR}
*                                                                      *
************************************************************************
-}

-- | The information needed to build a pattern for a DataCon to be unboxed.
-- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via
-- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype
-- wrappers.
--
-- If we get @DataConPatContext dc tys co@ for some type @ty@
-- and @dataConRepInstPat ... dc tys = (exs, flds)@, then
--
--   * @dc @exs flds :: T tys@
--   * @co :: T tys ~ ty@
--
-- 's' will be 'Demand' or 'Cpr'.
data DataConPatContext s
  = DataConPatContext
  { forall s. DataConPatContext s -> DataCon
dcpc_dc      :: !DataCon
  , forall s. DataConPatContext s -> [Kind]
dcpc_tc_args :: ![Type]
  , forall s. DataConPatContext s -> Coercion
dcpc_co      :: !Coercion
  , forall s. DataConPatContext s -> [s]
dcpc_args    :: ![s]
  }

-- | Describes the outer shape of an argument to be unboxed or left as-is
-- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr').
data UnboxingDecision unboxing_info
  = DontUnbox               -- ^ We ran out of strictness info. Leave untouched.
  | DoUnbox !unboxing_info  -- ^ The argument is used strictly or the
                            -- returned product was constructed, so unbox it.
  | DropAbsent              -- ^ The argument/field was absent. Drop it.

instance Outputable i => Outputable (UnboxingDecision i) where
  ppr :: UnboxingDecision i -> SDoc
ppr UnboxingDecision i
DontUnbox  = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DontUnbox"
  ppr UnboxingDecision i
DropAbsent = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DropAbsent"
  ppr (DoUnbox i
i) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DoUnbox" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (i -> SDoc
forall a. Outputable a => a -> SDoc
ppr i
i)

-- | Do we want to create workers just for unlifting?
wwUseForUnlifting :: WwOpts -> WwUse
wwUseForUnlifting :: WwOpts -> Bool
wwUseForUnlifting !WwOpts
opts
    -- Always unlift if possible
    | WwOpts -> Bool
wo_unlift_strict WwOpts
opts = Bool
usefulSplit
    -- Don't unlift  it would cause additional W/W splits.
    | Bool
otherwise             = Bool
boringSplit

-- | Is the worker/wrapper split profitable?
type WwUse = Bool

-- | WW split not profitable
boringSplit :: WwUse
boringSplit :: Bool
boringSplit = Bool
False

-- | WW split profitable
usefulSplit :: WwUse
usefulSplit :: Bool
usefulSplit = Bool
True

-- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns
-- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon'
-- to unbox.
canUnboxArg
  :: FamInstEnvs
  -> Type        -- ^ Type of the argument
  -> Demand      -- ^ How the arg was used
  -> UnboxingDecision (DataConPatContext Demand)
-- See Note [Which types are unboxed?]
canUnboxArg :: FamInstEnvs
-> Kind -> Demand -> UnboxingDecision (DataConPatContext Demand)
canUnboxArg FamInstEnvs
fam_envs Kind
ty (Card
n :* SubDemand
sd)
  | Card -> Bool
isAbs Card
n
  = UnboxingDecision (DataConPatContext Demand)
forall unboxing_info. UnboxingDecision unboxing_info
DropAbsent

  -- From here we are strict and not absent
  | Just (TyCon
tc, [Kind]
tc_args, Coercion
co) <- FamInstEnvs -> Kind -> Maybe (TyCon, [Kind], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Kind
ty
  , Just DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
  , let arity :: Int
arity = DataCon -> Int
dataConRepArity DataCon
dc
  , Just (Boxity
Unboxed, [Demand]
dmds) <- Int -> SubDemand -> Maybe (Boxity, [Demand])
viewProd Int
arity SubDemand
sd -- See Note [Boxity analysis]
  , [Demand]
dmds [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` DataCon -> Int
dataConRepArity DataCon
dc
  = DataConPatContext Demand
-> UnboxingDecision (DataConPatContext Demand)
forall unboxing_info.
unboxing_info -> UnboxingDecision unboxing_info
DoUnbox (DataConPatContext { dcpc_dc :: DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: [Kind]
dcpc_tc_args = [Kind]
tc_args
                               , dcpc_co :: Coercion
dcpc_co = Coercion
co, dcpc_args :: [Demand]
dcpc_args = [Demand]
dmds })

  | Bool
otherwise
  = UnboxingDecision (DataConPatContext Demand)
forall unboxing_info. UnboxingDecision unboxing_info
DontUnbox


-- | Unboxing strategy for constructed results.
canUnboxResult :: FamInstEnvs -> Type -> Cpr
               -> UnboxingDecision (DataConPatContext Cpr)
-- See Note [Which types are unboxed?]
canUnboxResult :: FamInstEnvs
-> Kind -> Cpr -> UnboxingDecision (DataConPatContext Cpr)
canUnboxResult FamInstEnvs
fam_envs Kind
ty Cpr
cpr
  | Just (Int
con_tag, [Cpr]
arg_cprs) <- Cpr -> Maybe (Int, [Cpr])
asConCpr Cpr
cpr
  , Just (TyCon
tc, [Kind]
tc_args, Coercion
co) <- FamInstEnvs -> Kind -> Maybe (TyCon, [Kind], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Kind
ty
  , Just [DataCon]
dcs <- TyCon -> Maybe [DataCon]
tyConAlgDataCons_maybe TyCon
tc Maybe [DataCon] -> Maybe [DataCon] -> Maybe [DataCon]
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe [DataCon]
open_body_ty_warning
  , [DataCon]
dcs [DataCon] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
con_tag -- This might not be true if we import the
                                -- type constructor via a .hs-boot file (#8743)
  , let dc :: DataCon
dc = [DataCon]
dcs [DataCon] -> Int -> DataCon
forall a. Outputable a => [a] -> Int -> a
`getNth` (Int
con_tag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fIRST_TAG)
  , [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
dc) -- no existentials;
                                -- See (CPR1) in Note [Which types are unboxed?]
                                -- and GHC.Core.Opt.CprAnal.argCprType
                                -- where we also check this.
  , [Kind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Kind]
dataConTheta DataCon
dc) -- no constraints;
                           -- See (CPR2) in Note [Which types are unboxed?]
  = DataConPatContext Cpr -> UnboxingDecision (DataConPatContext Cpr)
forall unboxing_info.
unboxing_info -> UnboxingDecision unboxing_info
DoUnbox (DataConPatContext { dcpc_dc :: DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: [Kind]
dcpc_tc_args = [Kind]
tc_args
                               , dcpc_co :: Coercion
dcpc_co = Coercion
co, dcpc_args :: [Cpr]
dcpc_args = [Cpr]
arg_cprs })

  | Bool
otherwise
  = UnboxingDecision (DataConPatContext Cpr)
forall unboxing_info. UnboxingDecision unboxing_info
DontUnbox

  where
    -- See Note [non-algebraic or open body type warning]
    open_body_ty_warning :: Maybe [DataCon]
open_body_ty_warning = Bool -> String -> SDoc -> Maybe [DataCon] -> Maybe [DataCon]
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"canUnboxResult: non-algebraic or open body type" (Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
ty) Maybe [DataCon]
forall a. Maybe a
Nothing

{- Note [Which types are unboxed?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Worker/wrapper will unbox

  1. A strict data type argument, that
       * is an algebraic data type (not a newtype)
       * is not recursive (as per 'isRecDataCon')
       * has a single constructor (thus is a "product")
       * that may bind existentials (#18982)
     We can transform
     > data D a = forall b. D a b
     > f (D @ex a b) = e
     to
     > $wf @ex a b = e
     via 'mkWWstr'.

  2. The constructed result of a function, if
       * its type is an algebraic data type (not a newtype)
       * is not recursive (as per 'isRecDataCon')
       * (might have multiple constructors, in contrast to (1))
       * the applied data constructor *does not* bind existentials
       * nor does it bind constraints (equalities or dictionaries)
     We can transform
     > f x y = let ... in D a b
     to
     > $wf x y = let ... in (# a, b #)
     via 'mkWWcpr'.

     (CPR1).  We don't allow existentials for CPR W/W, because we don't have
     unboxed dependent tuples (yet?). Otherwise, we could transform
     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)
     to
     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)

     (CPR2) we don't allow constraints for CPR W/W, because an unboxed tuple
     contains types of kind `TYPE rr`, but not of kind `CONSTRAINT rr`.
     This is annoying; there is no real reason for this except that we don't
     have TYPE/CONSTAINT polymorphism.  See Note [TYPE and CONSTRAINT]
     in GHC.Builtin.Types.Prim.

The respective tests are in 'canUnboxArg' and
'canUnboxResult', respectively.

Note [mkWWstr and unsafeCoerce]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
By using unsafeCoerce, it is possible to make the number of demands fail to
match the number of constructor arguments; this happened in #8037.
If so, the worker/wrapper split doesn't work right and we get a Core Lint
bug.  The fix here is simply to decline to do w/w if that happens.

Note [non-algebraic or open body type warning]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are a few cases where the W/W transformation is told that something
returns a constructor, but the type at hand doesn't really match this. One
real-world example involves unsafeCoerce:
  foo = IO a
  foo = unsafeCoerce c_exit
  foreign import ccall "c_exit" c_exit :: IO ()
Here CPR will tell you that `foo` returns a () constructor for sure, but trying
to create a worker/wrapper for type `a` obviously fails.
(This was a real example until ee8e792  in libraries/base.)

It does not seem feasible to avoid all such cases already in the analyser (and
after all, the analysis is not really wrong), so we simply do nothing here in
mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch
other cases where something went avoidably wrong.

This warning also triggers for the stream fusion library within `text`.
We can't easily W/W constructed results like `Stream` because we have no simple
way to express existential types in the worker's type signature.

Note [WW for calling convention]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we know a function f will always evaluate a particular argument
we might decide that it should rather get evaluated by the caller.
We call this "unlifting" the argument.
Sometimes the caller knows that the argument is already evaluated,
so we won't generate any code to enter/evaluate the argument.
This evaluation avoidance can be quite beneficial.
Especially for recursive functions who pass the same lifted argument
along on each iteration or walk over strict data structures.

One way to achieve this is to do a W/W split, where the wrapper does
the evaluation, and the worker can treat its arguments as unlifted.
The wrapper is small and will be inlined at almost all call sites and
the evaluation code in the wrapper can then cancel out with evaluation
done by the calling context if the argument is evaluated there.
Same idea as W/W to avoid allocation really, just for a different kind
of work.

Performing W/W might not always be a win. In particular it's easy to break
(badly written, but common) rule frameworks by doing additional W/W splits.
See #20364 for a more detailed explanation.

Hence we have the following strategies with different trade-offs:

A) Never do W/W *just* for unlifting of arguments.
  + Very conservative - doesn't break any rules
  - Lot's of performance left on the table

B) Do W/W on just about anything where it might be
  beneficial.
  + Exploits pretty much every opportunity for unlifting.
  - A bit of compile time/code size cost for all the wrappers.
  - Can break rules which would otherwise fire. See #20364.

C) Unlift *any* (non-boot exported) functions arguments if they are strict.
  That is instead of creating a Worker with the new calling convention we
  change the calling convention of the binding itself.
  + Exploits every opportunity for unlifting.
  + Maybe less bad interactions with rules.
  - Requires tracking of boot-exported definitions.
  - Requires either:
    ~ Eta-expansion at *all* call sites in order to generate
      an impedance matcher function. Leading to massive code bloat.
      Essentially we end up creating a impromptu wrapper function
      wherever we wouldn't inline the wrapper with a W/W approach.
    ~ There is the option of achieving this without eta-expansion if we instead expand
      the partial application code to check for demands on the calling convention and
      for it to evaluate the arguments. The main downsides there would be the complexity
      of the implementation and that it carries a certain overhead even for functions who
      don't take advantage of this functionality. I haven't tried this approach because it's
      not trivial to implement and doing W/W splits seems to work well enough.

Currently we use the first approach A) by default, with a flag that allows users to fall back to the
more aggressive approach B).

I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling
code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903.
We could still try to do C) in the future by having PAP calls which will evaluate the required arguments
before calling the partially applied function. But this would be neither a small nor simple change so we
stick with A) and a flag for B) for now.

See also Note [Tag Inference] and Note [CBV Function Ids]

Note [Worker/wrapper for strict arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    f x = case x of
             []     -> blah
             (y:ys) -> f ys

Clearly `f` is strict, but its argument is not a product type, so by default
we don't worker/wrapper it.  But it is arguably valuable to do so.  We could
do this:

   f x = case x of xx { DEFAULT -> $wf xx }
   $wf xx = case xx of
              []     -> blah
              (y:ys) -> f ys

Now the worker `$wf` knows that its argument `xx` will be evaluated
and properly tagged, so the code for the `case xx` does not need to do
an "eval" (see `GHC.StgToCmm.Expr.cgCase`).  A call (f (a:as)) will
have the wrapper inlined, and will drop the `case x`, so no eval
happens at all.

The worker `$wf` is a CBV function (see `Note [CBV Function Ids]`
in GHC.Types.Id.Info) and the code generator guarantees that every
call to `$wf` has a properly tagged argument (see `GHC.Stg.InferTags.Rewrite`).

Is this a win?  Not always:
* It can cause slight codesize increases. This is since we push evals to every
  call sites which there might be many. And the evals will only disappear at
  call sites where we already known that the argument is evaluated.

* It will also cause many more functions to get a worker/wrapper split
  which can play badly with rules (see Ticket #20364).  In particular
  if you depend on rules firing on functions marked as NOINLINE
  without marking use sites of these functions as INLINE or INLINEABLE
  then things will break.
  But if you want a function to match in a RULE, it is /in any case/ good practice to
  have a `INLINE[1]` or `NOINLNE[1]` pragma, to ensure that it doesn't inline until
  the rule has had a chance to fire.

So there is a flag, `-fworker-wrapper-cbv`, to control whether we do
w/w on strict arguments (internally `Opt_WorkerWrapperUnlift`).  The
flag is off by default.  The choice is made in
GHC.Core.Opt.WorkWrape.Utils.wwUseForUnlifting

See also `Note [WW for calling convention]` in GHC.Core.Opt.WorkWrap.Utils
-}

{-
************************************************************************
*                                                                      *
\subsection{Worker/wrapper for Strictness and Absence}
*                                                                      *
************************************************************************
-}

mkWWstr :: WwOpts
        -> [Var]                         -- Wrapper args; have their demand info on them
                                         --  *Includes type variables*
        -> [StrictnessMark]              -- Strictness-mark info for arguments
        -> UniqSM (WwUse,                -- Will this result in a useful worker
                   [(Var,StrictnessMark)],      -- Worker args/their call-by-value semantics.
                   CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
                                         -- and without its lambdas
                                         -- This fn adds the unboxing
                   [CoreExpr])           -- Reboxed args for the call to the
                                         -- original RHS. Corresponds one-to-one
                                         -- with the wrapper arg vars
mkWWstr :: WwOpts
-> [Id]
-> [StrictnessMark]
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
mkWWstr WwOpts
opts [Id]
args [StrictnessMark]
str_marks
  = -- pprTrace "mkWWstr" (ppr args) $
    [Id]
-> [StrictnessMark]
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
go [Id]
args [StrictnessMark]
str_marks
  where
    go :: [Id]
-> [StrictnessMark]
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
go [] [StrictnessMark]
_ = (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, [], CoreExpr -> CoreExpr
nop_fn, [])
    go (Id
arg : [Id]
args) (StrictnessMark
str:[StrictnessMark]
strs)
      = do { (Bool
useful1, [(Id, StrictnessMark)]
args1, CoreExpr -> CoreExpr
wrap_fn1, CoreExpr
wrap_arg)  <- WwOpts
-> Id
-> StrictnessMark
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
mkWWstr_one WwOpts
opts Id
arg StrictnessMark
str
           ; (Bool
useful2, [(Id, StrictnessMark)]
args2, CoreExpr -> CoreExpr
wrap_fn2, [CoreExpr]
wrap_args) <- [Id]
-> [StrictnessMark]
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
go [Id]
args [StrictnessMark]
strs
           ; (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bool
useful1 Bool -> Bool -> Bool
|| Bool
useful2
                    , [(Id, StrictnessMark)]
args1 [(Id, StrictnessMark)]
-> [(Id, StrictnessMark)] -> [(Id, StrictnessMark)]
forall a. [a] -> [a] -> [a]
++ [(Id, StrictnessMark)]
args2
                    , CoreExpr -> CoreExpr
wrap_fn1 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn2
                    , CoreExpr
wrap_argCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
wrap_args ) }
    go [Id]
_ [StrictnessMark]
_ = String
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
forall a. HasCallStack => String -> a
panic String
"mkWWstr: Impossible - str/arg length mismatch"

----------------------
-- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg)
--   *  wrap_fn assumes wrap_var is in scope,
--        brings into scope work_args (via cases)
--   * wrap_arg assumes work_args are in scope, and builds a ConApp that
--        reconstructs the RHS of wrap_var that we pass to the original RHS
-- See Note [Worker/wrapper for Strictness and Absence]
mkWWstr_one :: WwOpts
            -> Var
            -> StrictnessMark
            -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
mkWWstr_one :: WwOpts
-> Id
-> StrictnessMark
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
mkWWstr_one WwOpts
opts Id
arg StrictnessMark
str_mark =
  -- pprTrace "mkWWstr_one" (ppr arg <+> (if isId arg then ppr arg_ty  $$ ppr arg_dmd else text "type arg")) $
  case FamInstEnvs
-> Kind -> Demand -> UnboxingDecision (DataConPatContext Demand)
canUnboxArg FamInstEnvs
fam_envs Kind
arg_ty Demand
arg_dmd of
    UnboxingDecision (DataConPatContext Demand)
_ | Id -> Bool
isTyVar Id
arg -> UniqSM
  (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
do_nothing

    UnboxingDecision (DataConPatContext Demand)
DropAbsent
      | Just CoreExpr
absent_filler <- WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr
mkAbsentFiller WwOpts
opts Id
arg StrictnessMark
str_mark
         -- Absent case.  Drop the argument from the worker.
         -- We can't always handle absence for arbitrary
         -- unlifted types, so we need to choose just the cases we can
         -- (that's what mkAbsentFiller does)
      -> (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
usefulSplit, [], CoreExpr -> CoreExpr
nop_fn, CoreExpr
absent_filler)
      | Bool
otherwise -> UniqSM
  (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
do_nothing

    DoUnbox DataConPatContext Demand
dcpc -> -- pprTrace "mkWWstr_one:1" (ppr (dcpc_dc dcpc) <+> ppr (dcpc_tc_args dcpc) $$ ppr (dcpc_args dcpc)) $
                    WwOpts
-> Id
-> DataConPatContext Demand
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
unbox_one_arg WwOpts
opts Id
arg DataConPatContext Demand
dcpc

    UnboxingDecision (DataConPatContext Demand)
DontUnbox
      | Demand -> Bool
isStrictDmd Demand
arg_dmd Bool -> Bool -> Bool
|| StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str_mark
      , WwOpts -> Bool
wwUseForUnlifting WwOpts
opts  -- See Note [CBV Function Ids]
      , Bool -> Bool
not (Kind -> Bool
isFunTy Kind
arg_ty)
      , Bool -> Bool
not (HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
arg_ty) -- Already unlifted!
        -- NB: function arguments have a fixed RuntimeRep,
        -- so it's OK to call isUnliftedType here
      -> (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Bool
usefulSplit, [(Id
arg, StrictnessMark
MarkedStrict)], CoreExpr -> CoreExpr
nop_fn, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
arg )

      | Bool
otherwise -> UniqSM
  (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
do_nothing

  where
    fam_envs :: FamInstEnvs
fam_envs   = WwOpts -> FamInstEnvs
wo_fam_envs WwOpts
opts
    arg_ty :: Kind
arg_ty     = Id -> Kind
idType Id
arg
    arg_dmd :: Demand
arg_dmd    = Id -> Demand
idDemandInfo Id
arg
    arg_str :: StrictnessMark
arg_str    | Id -> Bool
isTyVar Id
arg = StrictnessMark
NotMarkedStrict -- Type args don't get strictness marks
               | Bool
otherwise   = StrictnessMark
str_mark
    do_nothing :: UniqSM
  (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
do_nothing = (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, [(Id
arg,StrictnessMark
arg_str)], CoreExpr -> CoreExpr
nop_fn, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
arg)

unbox_one_arg :: WwOpts
              -> Var -> DataConPatContext Demand
              -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
unbox_one_arg :: WwOpts
-> Id
-> DataConPatContext Demand
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
unbox_one_arg WwOpts
opts Id
arg_var
              DataConPatContext { dcpc_dc :: forall s. DataConPatContext s -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: forall s. DataConPatContext s -> [Kind]
dcpc_tc_args = [Kind]
tc_args
                                , dcpc_co :: forall s. DataConPatContext s -> Coercion
dcpc_co = Coercion
co, dcpc_args :: forall s. DataConPatContext s -> [s]
dcpc_args = [Demand]
ds }
  = do { [Unique]
pat_bndrs_uniqs <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
       ; let ex_name_fss :: [FastString]
ex_name_fss = (Id -> FastString) -> [Id] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map Id -> FastString
forall a. NamedThing a => a -> FastString
getOccFS ([Id] -> [FastString]) -> [Id] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Id]
dataConExTyCoVars DataCon
dc

             -- Create new arguments we get when unboxing dc
             ([Id]
ex_tvs', [Id]
arg_ids) = [FastString]
-> [Unique] -> Kind -> DataCon -> [Kind] -> ([Id], [Id])
dataConRepFSInstPat ([FastString]
ex_name_fss [FastString] -> [FastString] -> [FastString]
forall a. [a] -> [a] -> [a]
++ FastString -> [FastString]
forall a. a -> [a]
repeat FastString
ww_prefix)
                                            [Unique]
pat_bndrs_uniqs (Id -> Kind
idMult Id
arg_var) DataCon
dc [Kind]
tc_args
             con_str_marks :: [StrictnessMark]
con_str_marks = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc

             -- Apply str info to new args. Also remove OtherCon unfoldings so they
             -- don't end up in lambda binders of the worker.
             -- See Note [Never put `OtherCon` unfoldings on lambda binders]
             arg_ids' :: [Id]
arg_ids' = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zapIdUnfolding ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$
                        String -> (Id -> Demand -> Id) -> [Id] -> [Demand] -> [Id]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"unbox_one_arg" Id -> Demand -> Id
setIdDemandInfo [Id]
arg_ids [Demand]
ds

             unbox_fn :: CoreExpr -> CoreExpr
unbox_fn = CoreExpr
-> Coercion -> Kind -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg_var) Coercion
co (Id -> Kind
idMult Id
arg_var)
                                     DataCon
dc ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids')

             -- Mark arguments coming out of strict fields so we can seq them in the worker
             -- See Note [Call-by-value for worker args]
             all_str_marks :: [StrictnessMark]
all_str_marks = ((Id -> StrictnessMark) -> [Id] -> [StrictnessMark]
forall a b. (a -> b) -> [a] -> [b]
map (StrictnessMark -> Id -> StrictnessMark
forall a b. a -> b -> a
const StrictnessMark
NotMarkedStrict) [Id]
ex_tvs') [StrictnessMark] -> [StrictnessMark] -> [StrictnessMark]
forall a. [a] -> [a] -> [a]
++ [StrictnessMark]
con_str_marks

       ; (Bool
nested_useful, [(Id, StrictnessMark)]
worker_args, CoreExpr -> CoreExpr
wrap_fn, [CoreExpr]
wrap_args)
             <- WwOpts
-> [Id]
-> [StrictnessMark]
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, [CoreExpr])
mkWWstr WwOpts
opts ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids') [StrictnessMark]
all_str_marks

       ; let wrap_arg :: CoreExpr
wrap_arg = DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
dc ((Kind -> CoreExpr) -> [Kind] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> CoreExpr
forall b. Kind -> Expr b
Type [Kind]
tc_args [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
wrap_args) HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
       -- See Note [Unboxing through unboxed tuples]
       ; (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
 -> UniqSM
      (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr))
-> (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-> UniqSM
     (Bool, [(Id, StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
forall a b. (a -> b) -> a -> b
$ if DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
nested_useful
                     then (Bool
boringSplit, [(Id
arg_var,StrictnessMark
NotMarkedStrict)], CoreExpr -> CoreExpr
nop_fn, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
arg_var)
                     else (Bool
usefulSplit, [(Id, StrictnessMark)]
worker_args, CoreExpr -> CoreExpr
unbox_fn (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn, CoreExpr
wrap_arg) }

-- | Tries to find a suitable absent filler to bind the given absent identifier
-- to. See Note [Absent fillers].
--
-- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the
-- same type as @id@. Otherwise, no suitable filler could be found.
mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr
mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr
mkAbsentFiller WwOpts
opts Id
arg StrictnessMark
str
  -- The lifted case: Bind 'absentError' for a nice panic message if we are
  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]
  | Kind -> Bool
mightBeLiftedType Kind
arg_ty
  , Bool -> Bool
not Bool
is_strict
  , Bool -> Bool
not (StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str) -- See (2) in Note [Absent fillers]
  = CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Kind -> String -> CoreExpr
mkAbsentErrorApp Kind
arg_ty String
msg)

  -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty`
  -- See Note [Absent fillers], the main part
  | Bool
otherwise
  = Kind -> Maybe CoreExpr
mkLitRubbish Kind
arg_ty

  where
    arg_ty :: Kind
arg_ty    = Id -> Kind
idType Id
arg
    is_strict :: Bool
is_strict = Demand -> Bool
isStrictDmd (Id -> Demand
idDemandInfo Id
arg)

    msg :: String
msg = SDocContext -> SDoc -> String
renderWithContext
            (SDocContext
defaultSDocContext { sdocSuppressUniques = True })
            ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
              [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
arg
              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
arg_ty
              , SDoc
file_msg ])
              -- We need to suppress uniques here because otherwise they'd
              -- end up in the generated code as strings. This is bad for
              -- determinism, because with different uniques the strings
              -- will have different lengths and hence different costs for
              -- the inliner leading to different inlining.
              -- See also Note [Unique Determinism] in GHC.Types.Unique
    file_msg :: SDoc
file_msg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In module" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> SDoc) -> Module -> SDoc
forall a b. (a -> b) -> a -> b
$ WwOpts -> Module
wo_module WwOpts
opts)

{- Note [Worker/wrapper for Strictness and Absence]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The worker/wrapper transformation, mkWWstr_one, takes concrete action
based on the 'UnboxingDecision' returned by 'canUnboxArg'.
The latter takes into account several possibilities to decide if the
function is worthy for splitting:

1. If an argument is absent, it would be silly to pass it to
   the worker.  Hence the DropAbsent case.  This case must come
   first because the bottom demand B is also strict.
   E.g. B comes from a function like
       f x = error "urk"
   and the absent demand A can come from Note [Unboxing evaluated arguments]
   in GHC.Core.Opt.DmdAnal.

2. If the argument is evaluated strictly (or known to be eval'd),
   we can take a view into the product demand ('viewProd'). In accordance
   with Note [Boxity analysis], 'canUnboxArg' will say 'DoUnbox'.
   'mkWWstr_one' then follows suit it and recurses into the fields of the
   product demand. For example

     f :: (Int, Int) -> Int
     f p = (case p of (a,b) -> a) + 1
   is split to
     f :: (Int, Int) -> Int
     f p = case p of (a,b) -> $wf a

     $wf :: Int -> Int
     $wf a = a + 1

   and
     g :: Bool -> (Int, Int) -> Int
     g c p = case p of (a,b) ->
                if c then a else b
   is split to
     g c p = case p of (a,b) -> $gw c a b
     $gw c a b = if c then a else b

2a But do /not/ unbox if Boxity Analysis said "Boxed".
   In this case, 'canUnboxArg' returns 'DontUnbox'.
   Otherwise we risk decomposing and reboxing a massive
   tuple which is barely used. Example:

        f :: ((Int,Int) -> String) -> (Int,Int) -> a
        f g pr = error (g pr)

        main = print (f fst (1, error "no"))

   Here, f does not take 'pr' apart, and it's stupid to do so.
   Imagine that it had millions of fields. This actually happened
   in GHC itself where the tuple was DynFlags

2b But if e.g. a large tuple or product type is always demanded we might
   decide to "unlift" it. That is tighten the calling convention for that
   argument to require it to be passed as a pointer to the value itself.
   See Note [WW for calling convention].

3. In all other cases (e.g., lazy, used demand and not eval'd),
   'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed'
   (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal)
   and 'canUnboxArg' returns 'DontUnbox' so that 'mkWWstr_one'
   stops unboxing.

Note [Worker/wrapper for bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used not to split if the result is bottom.
[Justification:  there's no efficiency to be gained.]

But it's sometimes bad not to make a wrapper.  Consider
        fw = \x# -> let x = I# x# in case e of
                                        p1 -> error_fn x
                                        p2 -> error_fn x
                                        p3 -> the real stuff
The re-boxing code won't go away unless error_fn gets a wrapper too.
[We don't do reboxing now, but in general it's better to pass an
unboxed thing to f, and have it reboxed in the error cases....]

Note [Record evaluated-ness in worker/wrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have

   data T = MkT !Int Int

   f :: T -> T
   f x = e

and f's is strict, and has the CPR property.  The we are going to generate
this w/w split

   f x = case x of
           MkT x1 x2 -> case $wf x1 x2 of
                           (# r1, r2 #) -> MkT r1 r2

   $wfw x1 x2 = let x = MkT x1 x2 in
                case e of
                  MkT r1 r2 -> (# r1, r2 #)

Note that

* In the worker $wf, inside 'e' we can be sure that x1 will be
  evaluated (it came from unpacking the argument MkT.  But that's no
  immediately apparent in $wf

* In the wrapper 'f', which we'll inline at call sites, we can be sure
  that 'r1' has been evaluated (because it came from unpacking the result
  MkT.  But that is not immediately apparent from the wrapper code.

Missing these facts isn't unsound, but it loses possible future
opportunities for optimisation.

Solution: use setCaseBndrEvald when creating
 (A) The arg binders x1,x2 in mkWstr_one via mkUnpackCase
         See #13077, test T13077
 (B) The result binders r1,r2 in mkWWcpr_entry
         See Trace #13077, test T13077a
         And #13027 comment:20, item (4)
to record that the relevant binder is evaluated.

Note [Absent fillers]
~~~~~~~~~~~~~~~~~~~~~
Consider

  data T = MkT [Int] [Int] ![Int]  -- NB: last field is strict
  f :: T -> Int# -> blah
  f ps w = case ps of MkT xs ys zs -> <body mentioning xs>

Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:

  $wf :: [Int] -> blah
  $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>
    where
      ys = absentError "ys :: [Int]"
      zs = RUBBISH[LiftedRep] @[Int]
      ps = MkT xs ys zs
      w  = RUBBISH[IntRep] @Int#

The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.
And neither should they! They are never used, their value is irrelevant (hence
they are *dead code*) and they are probably discarded after the next run of the
Simplifier (when they are in fact *unreachable code*). Yet, we have to come up
with "filler" values that we bind the absent arg Ids to.

That is exactly what Note [Rubbish literals] are for: A convenient way to
conjure filler values at any type (and any representation or levity!).

Needless to say, there are some wrinkles:

  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk
     instead. If absence analysis was wrong (e.g., #11126) and the binding
     in fact is used, then we get a nice panic message instead of undefined
     runtime behavior (See Modes of failure from Note [Rubbish literals]).

     Obviously, we can't use an error-thunk if the value is of unlifted rep
     (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.

  2. We also mustn't put an error-thunk (that fills in for an absent value of
     lifted rep) in a strict field, because #16970 establishes the invariant
     that strict fields are always evaluated, by possibly (re-)evaluating what is put in
     a strict field. That's the reason why 'zs' binds a rubbish literal instead
     of an error-thunk, see #19133.

     How do we detect when we are about to put an error-thunk in a strict field?
     Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field. So that's
     what we do!

     There are other necessary conditions for strict fields:
     Note [Unboxing evaluated arguments] in DmdAnal makes it so that the demand on
     'zs' is absent and /strict/: It will get cardinality 'C_10', the empty
     interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It further
     guarantees e never fill in an error-thunk for an absent strict field.
     But that also means we emit a rubbish lit for other args that have
     cardinality 'C_10' (say, the arg to a bottoming function) where we could've
     used an error-thunk.
     NB from Andreas: But I think using an error thunk there would be dodgy no matter what
     for example if we decide to pass the argument to the bottoming function cbv.
     As we might do if the function in question is a worker.
     See Note [CBV Function Ids] in GHC.Types.Id.Info. So I just left the strictness check
     in place on top of threading through the marks from the constructor. It's a *really* cheap
     and easy check to make anyway.

  3. We can only emit a LitRubbish if the arg's type @arg_ty@ is mono-rep, e.g.
     of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.
     Why? Because if we don't know its representation (e.g. size in memory,
     register class), we don't know what or how much rubbish to emit in codegen.
     'mkLitRubbish' returns 'Nothing' in this case and we simply fall
     back to passing the original parameter to the worker.

     Note that currently this case should not occur, because binders always
     have to be representation monomorphic. But in the future, we might allow
     levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.

While (1) and (2) are simply an optimisation in terms of compiler debugging
experience, (3) should be irrelevant in most programs, if not all.

Historical note: I did try the experiment of using an error thunk for unlifted
things too, relying on the simplifier to drop it as dead code.  But this is
fragile

 - It fails when profiling is on, which disables various optimisations

 - It fails when reboxing happens. E.g.
      data T = MkT Int Int#
      f p@(MkT a _) = ...g p....
   where g is /lazy/ in 'p', but only uses the first component.  Then
   'f' is /strict/ in 'p', and only uses the first component.  So we only
   pass that component to the worker for 'f', which reconstructs 'p' to
   pass it to 'g'.  Alas we can't say
       ...f (MkT a (absentError Int# "blah"))...
   because `MkT` is strict in its Int# argument, so we get an absentError
   exception when we shouldn't.  Very annoying!

Note [Unboxing through unboxed tuples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We should not to a worker/wrapper split just for unboxing the components of
an unboxed tuple (in the result *or* argument, #22388). Consider
  boring_res x y = (# y, x #)
It's entirely pointless to split for the constructed unboxed pair to
  $wboring_res x y = (# y, x #)
  boring_res = case $wboring_res x y of (# a, b #) -> (# a, b #)
`boring_res` will immediately simplify to an alias for `$wboring_res`!

Similarly, the unboxed tuple might occur in argument position
  boring_arg (# x, y, z #) = (# z, x, y #)
It's entirely pointless to "unbox" the triple
  $wboring_arg x y z = (# z, x, y #)
  boring_arg (# x, y, z #) = $wboring_arg x y z
because after unarisation, `boring_arg` is just an alias for `$wboring_arg`.

Conclusion: Only consider unboxing an unboxed tuple useful when we will
also unbox its components. That is governed by the `usefulSplit` mechanism.

************************************************************************
*                                                                      *
         Type scrutiny that is specific to demand analysis
*                                                                      *
************************************************************************
-}

-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that
-- the 'DataCon' may not have existentials. The lack of cloning the
-- existentials this function \"dubious\"; only use it where type variables
-- aren't substituted for!  Why may the data con bind existentials?
--    See Note [Which types are unboxed?]
dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]
dubiousDataConInstArgTys :: DataCon -> [Kind] -> [Kind]
dubiousDataConInstArgTys DataCon
dc [Kind]
tc_args = [Kind]
arg_tys
  where
    univ_tvs :: [Id]
univ_tvs        = DataCon -> [Id]
dataConUnivTyVars DataCon
dc
    ex_tvs :: [Id]
ex_tvs          = DataCon -> [Id]
dataConExTyCoVars DataCon
dc
    univ_subst :: Subst
univ_subst      = [Id] -> [Kind] -> Subst
HasDebugCallStack => [Id] -> [Kind] -> Subst
zipTvSubst [Id]
univ_tvs [Kind]
tc_args
    (Subst
full_subst, [Id]
_) = HasDebugCallStack => Subst -> [Id] -> (Subst, [Id])
Subst -> [Id] -> (Subst, [Id])
substTyVarBndrs Subst
univ_subst [Id]
ex_tvs
    arg_tys :: [Kind]
arg_tys         = (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => Subst -> Kind -> Kind
Subst -> Kind -> Kind
substTy Subst
full_subst (Kind -> Kind) -> (Scaled Kind -> Kind) -> Scaled Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing) ([Scaled Kind] -> [Kind]) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> a -> b
$
                      DataCon -> [Scaled Kind]
dataConRepArgTys DataCon
dc
    -- NB: use substTyVarBndrs on ex_tvs to ensure that we
    --     substitute in their kinds.  For example (#22849)
    -- Consider data T a where
    --            MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a
    -- Then dubiousDataConInstArgTys MkT [Type, Foo] should return
    --        [Foo (ix::Type)], not [Foo (ix::k)]!

findTypeShape :: FamInstEnvs -> Type -> TypeShape
-- Uncover the arrow and product shape of a type
-- The data type TypeShape is defined in GHC.Types.Demand
-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal
findTypeShape :: FamInstEnvs -> Kind -> TypeShape
findTypeShape FamInstEnvs
fam_envs Kind
ty
  = RecTcChecker -> Kind -> TypeShape
go (Int -> RecTcChecker -> RecTcChecker
setRecTcMaxBound Int
2 RecTcChecker
initRecTc) Kind
ty
       -- You might think this bound of 2 is low, but actually
       -- I think even 1 would be fine.  This only bites for recursive
       -- product types, which are rare, and we really don't want
       -- to look deep into such products -- see #18034
  where
    go :: RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
ty
       | Just (FunTyFlag
_, Kind
_, Kind
_, Kind
res) <- Kind -> Maybe (FunTyFlag, Kind, Kind, Kind)
splitFunTy_maybe Kind
ty
       = TypeShape -> TypeShape
TsFun (RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
res)

       | Just (TyCon
tc, [Kind]
tc_args)  <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
ty
       = RecTcChecker -> TyCon -> [Kind] -> TypeShape
go_tc RecTcChecker
rec_tc TyCon
tc [Kind]
tc_args

       | Just (Id
_, Kind
ty') <- Kind -> Maybe (Id, Kind)
splitForAllTyCoVar_maybe Kind
ty
       = RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
ty'

       | Bool
otherwise
       = TypeShape
TsUnk

    go_tc :: RecTcChecker -> TyCon -> [Kind] -> TypeShape
go_tc RecTcChecker
rec_tc TyCon
tc [Kind]
tc_args
       | Just (HetReduction (Reduction Coercion
_ Kind
rhs) MCoercionN
_) <- FamInstEnvs -> TyCon -> [Kind] -> Maybe HetReduction
topReduceTyFamApp_maybe FamInstEnvs
fam_envs TyCon
tc [Kind]
tc_args
       = RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
rhs

       | Just DataCon
con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
       , Just RecTcChecker
rec_tc <- if TyCon -> Bool
isTupleTyCon TyCon
tc
                        then RecTcChecker -> Maybe RecTcChecker
forall a. a -> Maybe a
Just RecTcChecker
rec_tc
                        else RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_tc TyCon
tc
         -- We treat tuples specially because they can't cause loops.
         -- Maybe we should do so in checkRecTc.
         -- The use of 'dubiousDataConInstArgTys' is OK, since this
         -- function performs no substitution at all, hence the uniques
         -- don't matter.
         -- We really do encounter existentials here, see
         -- Note [Which types are unboxed?] for an example.
       = [TypeShape] -> TypeShape
TsProd ((Kind -> TypeShape) -> [Kind] -> [TypeShape]
forall a b. (a -> b) -> [a] -> [b]
map (RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc) (DataCon -> [Kind] -> [Kind]
dubiousDataConInstArgTys DataCon
con [Kind]
tc_args))

       | Just (Kind
ty', Coercion
_) <- TyCon -> [Kind] -> Maybe (Kind, Coercion)
instNewTyCon_maybe TyCon
tc [Kind]
tc_args
       , Just RecTcChecker
rec_tc <- RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc RecTcChecker
rec_tc TyCon
tc
       = RecTcChecker -> Kind -> TypeShape
go RecTcChecker
rec_tc Kind
ty'

       | Bool
otherwise
       = TypeShape
TsUnk

-- | Returned by 'isRecDataCon'.
-- See also Note [Detecting recursive data constructors].
data IsRecDataConResult
  = DefinitelyRecursive  -- ^ The algorithm detected a loop
  | NonRecursiveOrUnsure -- ^ The algorithm detected no loop, went out of fuel
                         -- or hit an .hs-boot file
  deriving (IsRecDataConResult -> IsRecDataConResult -> Bool
(IsRecDataConResult -> IsRecDataConResult -> Bool)
-> (IsRecDataConResult -> IsRecDataConResult -> Bool)
-> Eq IsRecDataConResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsRecDataConResult -> IsRecDataConResult -> Bool
== :: IsRecDataConResult -> IsRecDataConResult -> Bool
$c/= :: IsRecDataConResult -> IsRecDataConResult -> Bool
/= :: IsRecDataConResult -> IsRecDataConResult -> Bool
Eq, Int -> IsRecDataConResult -> ShowS
[IsRecDataConResult] -> ShowS
IsRecDataConResult -> String
(Int -> IsRecDataConResult -> ShowS)
-> (IsRecDataConResult -> String)
-> ([IsRecDataConResult] -> ShowS)
-> Show IsRecDataConResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IsRecDataConResult -> ShowS
showsPrec :: Int -> IsRecDataConResult -> ShowS
$cshow :: IsRecDataConResult -> String
show :: IsRecDataConResult -> String
$cshowList :: [IsRecDataConResult] -> ShowS
showList :: [IsRecDataConResult] -> ShowS
Show)

instance Outputable IsRecDataConResult where
  ppr :: IsRecDataConResult -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc)
-> (IsRecDataConResult -> String) -> IsRecDataConResult -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsRecDataConResult -> String
forall a. Show a => a -> String
show

combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult
combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult
combineIRDCR IsRecDataConResult
DefinitelyRecursive IsRecDataConResult
_                   = IsRecDataConResult
DefinitelyRecursive
combineIRDCR IsRecDataConResult
_                   IsRecDataConResult
DefinitelyRecursive = IsRecDataConResult
DefinitelyRecursive
combineIRDCR IsRecDataConResult
_                   IsRecDataConResult
_                   = IsRecDataConResult
NonRecursiveOrUnsure

combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs = (IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult)
-> IsRecDataConResult -> [IsRecDataConResult] -> IsRecDataConResult
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult
combineIRDCR IsRecDataConResult
NonRecursiveOrUnsure
{-# INLINE combineIRDCRs #-}

-- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns
--
--   * @DefinitelyRecursive@ if the analysis found that @tc@ is reachable
--     through one of @dc@'s @arg_tys@.
--   * @NonRecursiveOrUnsure@ if the analysis found that @tc@ is not reachable
--     through one of @dc@'s fields (so surely non-recursive).
--   * @NonRecursiveOrUnsure@ when @fuel /= Infinity@
--     and @fuel@ expansions of nested data TyCons were not enough to prove
--     non-recursiveness, nor arrive at an occurrence of @tc@ thus proving
--     recursiveness. (So not sure if non-recursive.)
--   * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without
--     visible DataCons), such as those imported from .hs-boot files.
--     Similarly for stuck type and data families.
--
-- If @fuel = 'Infinity'@ and there are no boot files involved, then the result
-- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int'
-- f@, then the analysis behaves like a depth-limited DFS and returns @Nothing@
-- if the search was inconclusive.
--
-- See Note [Detecting recursive data constructors] for which recursive DataCons
-- we want to flag.
isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult
isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult
isRecDataCon FamInstEnvs
fam_envs IntWithInf
fuel DataCon
orig_dc
  | DataCon -> Bool
isTupleDataCon DataCon
orig_dc Bool -> Bool -> Bool
|| DataCon -> Bool
isUnboxedSumDataCon DataCon
orig_dc
  = IsRecDataConResult
NonRecursiveOrUnsure
  | Bool
otherwise
  = -- pprTraceWith "isRecDataCon" (\answer -> ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) $
    IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
go_dc IntWithInf
fuel TyConSet
emptyTyConSet DataCon
orig_dc
  where
    go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
    go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
go_dc IntWithInf
fuel TyConSet
visited_tcs DataCon
dc =
      [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs [ IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs Kind
arg_ty
                    | Kind
arg_ty <- (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing (DataCon -> [Scaled Kind]
dataConRepArgTys DataCon
dc) ]

    go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult
    go_arg_ty :: IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs Kind
ty
      --- | pprTrace "arg_ty" (ppr ty) False = undefined

      | Just (Id
_tcv, Kind
ty') <- Kind -> Maybe (Id, Kind)
splitForAllTyCoVar_maybe Kind
ty
      = IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs Kind
ty'
          -- See Note [Detecting recursive data constructors], point (A)

      | Just (TyCon
tc, [Kind]
tc_args) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
ty
      = IntWithInf -> TyConSet -> TyCon -> [Kind] -> IsRecDataConResult
go_tc_app IntWithInf
fuel TyConSet
visited_tcs TyCon
tc [Kind]
tc_args

      | Bool
otherwise
      = IsRecDataConResult
NonRecursiveOrUnsure

    go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult
    go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Kind] -> IsRecDataConResult
go_tc_app IntWithInf
fuel TyConSet
visited_tcs TyCon
tc [Kind]
tc_args =
      case TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc of
      --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined
        Maybe [DataCon]
_ | Just (HetReduction (Reduction Coercion
_ Kind
rhs) MCoercionN
_) <- FamInstEnvs -> TyCon -> [Kind] -> Maybe HetReduction
topReduceTyFamApp_maybe FamInstEnvs
fam_envs TyCon
tc [Kind]
tc_args
          -- This is the only place where we look at tc_args, which might have
          -- See Note [Detecting recursive data constructors], point (C) and (5)
          -> IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs Kind
rhs

        Maybe [DataCon]
_ | TyCon
tc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> TyCon
dataConTyCon DataCon
orig_dc
          -> IsRecDataConResult
DefinitelyRecursive -- loop found!

        Just [DataCon]
dcs
          | IsRecDataConResult
DefinitelyRecursive <- [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs [ IntWithInf -> TyConSet -> Kind -> IsRecDataConResult
go_arg_ty IntWithInf
fuel TyConSet
visited_tcs' Kind
ty | Kind
ty <- [Kind]
tc_args ]
              -- Check tc_args, See Note [Detecting recursive data constructors], point (5)
              -- The new visited_tcs', so that we don't recursively check tc,
              -- promising that we will check it below.
              -- Do the tc_args check *before* the dcs check below, otherwise
              -- we might miss an obvious rec occ in tc_args when we run out of
              -- fuel and respond NonRecursiveOrUnsure instead
          -> IsRecDataConResult
DefinitelyRecursive

          | IntWithInf
fuel IntWithInf -> IntWithInf -> Bool
forall a. Ord a => a -> a -> Bool
>= IntWithInf
0
              -- See Note [Detecting recursive data constructors], point (4)
          , Bool -> Bool
not (TyCon
tc TyCon -> TyConSet -> Bool
`elemTyConSet` TyConSet
visited_tcs)
              -- only need to check tc if we haven't visited it already. NB: original visited_tcs
          -> [IsRecDataConResult] -> IsRecDataConResult
combineIRDCRs [ IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
go_dc (IntWithInf -> Int -> IntWithInf
subWithInf IntWithInf
fuel Int
1) TyConSet
visited_tcs' DataCon
dc | DataCon
dc <- [DataCon]
dcs ]
              -- Finally: check ds

        Maybe [DataCon]
_ -> IsRecDataConResult
NonRecursiveOrUnsure
        where
          visited_tcs' :: TyConSet
visited_tcs' = TyConSet -> TyCon -> TyConSet
extendTyConSet TyConSet
visited_tcs TyCon
tc

{-
************************************************************************
*                                                                      *
\subsection{Worker/wrapper for CPR}
*                                                                      *
************************************************************************
See Note [Worker/wrapper for CPR] for an overview.
-}

mkWWcpr_entry
  :: WwOpts
  -> Type                              -- function body
  -> Cpr                               -- CPR analysis results
  -> UniqSM (WwUse,                    -- Is w/w'ing useful?
             CoreExpr -> CoreExpr,     -- New wrapper. 'nop_fn' if not useful
             CoreExpr -> CoreExpr)     -- New worker.  'nop_fn' if not useful
-- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview.
mkWWcpr_entry :: WwOpts
-> Kind
-> Cpr
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_entry WwOpts
opts Kind
body_ty Cpr
body_cpr
  | Bool -> Bool
not (WwOpts -> Bool
wo_cpr_anal WwOpts
opts) = (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
  | Bool
otherwise = do
    -- Part (1)
    Id
res_bndr <- Kind -> UniqSM Id
mk_res_bndr Kind
body_ty
    let bind_res_bndr :: CoreExpr -> CoreExpr -> CoreExpr
bind_res_bndr CoreExpr
body CoreExpr
scope = CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
body Id
res_bndr CoreExpr
scope

    -- Part (2)
    (Bool
useful, OrdList Id -> [Id]
forall a. OrdList a -> [a]
fromOL -> [Id]
transit_vars, CoreExpr
rebuilt_result, CoreExpr -> CoreExpr
work_unpack_res) <-
      WwOpts
-> Id
-> Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_one WwOpts
opts Id
res_bndr Cpr
body_cpr

    -- Part (3)
    let (CoreExpr -> CoreExpr -> CoreExpr
unbox_transit_tup, CoreExpr
transit_tup) = [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)
move_transit_vars [Id]
transit_vars

    -- Stacking unboxer (work_fn) and builder (wrap_fn) together
    let wrap_fn :: CoreExpr -> CoreExpr
wrap_fn      = CoreExpr -> CoreExpr -> CoreExpr
unbox_transit_tup CoreExpr
rebuilt_result                 -- 3 2
        work_fn :: CoreExpr -> CoreExpr
work_fn CoreExpr
body = CoreExpr -> CoreExpr -> CoreExpr
bind_res_bndr CoreExpr
body (CoreExpr -> CoreExpr
work_unpack_res CoreExpr
transit_tup) -- 1 2 3
    (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
 -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr))
-> (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ if Bool -> Bool
not Bool
useful
                then (Bool
boringSplit, CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
                else (Bool
usefulSplit, CoreExpr -> CoreExpr
wrap_fn, CoreExpr -> CoreExpr
work_fn)

-- | Part (1) of Note [Worker/wrapper for CPR].
mk_res_bndr :: Type -> UniqSM Id
mk_res_bndr :: Kind -> UniqSM Id
mk_res_bndr Kind
body_ty = do
  -- See Note [Linear types and CPR]
  Id
bndr <- FastString -> Kind -> Kind -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Id
mkSysLocalOrCoVarM FastString
ww_prefix Kind
cprCaseBndrMult Kind
body_ty
  -- See Note [Record evaluated-ness in worker/wrapper]
  Id -> UniqSM Id
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
MarkedStrict Id
bndr)

-- | What part (2) of Note [Worker/wrapper for CPR] collects.
--
--   1. A 'WwUse' capturing whether the split does anything useful.
--   2. The list of transit variables (see the Note).
--   3. The result builder expression for the wrapper.  The original case binder if not useful.
--   4. The result unpacking expression for the worker. 'nop_fn' if not useful.
type CprWwResultOne  = (WwUse, OrdList Var,  CoreExpr , CoreExpr -> CoreExpr)
type CprWwResultMany = (WwUse, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr)

mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany
mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany
mkWWcpr WwOpts
_opts [Id]
vars []   =
  -- special case: No CPRs means all top (for example from FlatConCpr),
  -- hence stop WW.
  CprWwResultMany -> UniqSM CprWwResultMany
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, [Id] -> OrdList Id
forall a. [a] -> OrdList a
toOL [Id]
vars, (Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr [Id]
vars, CoreExpr -> CoreExpr
nop_fn)
mkWWcpr WwOpts
opts  [Id]
vars [Cpr]
cprs = do
  -- No existentials in 'vars'. 'canUnboxResult' should have checked that.
  Bool -> SDoc -> UniqSM ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isTyVar [Id]
vars)) ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
vars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Cpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Cpr]
cprs)
  Bool -> SDoc -> UniqSM ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ([Id] -> [Cpr] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Id]
vars [Cpr]
cprs) ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
vars SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Cpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Cpr]
cprs)
  ([Bool]
usefuls, [OrdList Id]
varss, [CoreExpr]
rebuilt_results, [CoreExpr -> CoreExpr]
work_unpack_ress) <-
    [(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)]
-> ([Bool], [OrdList Id], [CoreExpr], [CoreExpr -> CoreExpr])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)]
 -> ([Bool], [OrdList Id], [CoreExpr], [CoreExpr -> CoreExpr]))
-> UniqSM [(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)]
-> UniqSM
     ([Bool], [OrdList Id], [CoreExpr], [CoreExpr -> CoreExpr])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id
 -> Cpr
 -> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr))
-> [Id]
-> [Cpr]
-> UniqSM [(Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (WwOpts
-> Id
-> Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_one WwOpts
opts) [Id]
vars [Cpr]
cprs
  CprWwResultMany -> UniqSM CprWwResultMany
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
usefuls
         , [OrdList Id] -> OrdList Id
forall a. [OrdList a] -> OrdList a
concatOL [OrdList Id]
varss
         , [CoreExpr]
rebuilt_results
         , ((CoreExpr -> CoreExpr)
 -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr]
-> CoreExpr
-> CoreExpr
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) CoreExpr -> CoreExpr
nop_fn [CoreExpr -> CoreExpr]
work_unpack_ress )

mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResultOne
-- ^ See if we want to unbox the result and hand off to 'unbox_one_result'.
mkWWcpr_one :: WwOpts
-> Id
-> Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
mkWWcpr_one WwOpts
opts Id
res_bndr Cpr
cpr
  | Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Id -> Bool
isTyVar Id
res_bndr) ) Bool
True
  , DoUnbox DataConPatContext Cpr
dcpc <- FamInstEnvs
-> Kind -> Cpr -> UnboxingDecision (DataConPatContext Cpr)
canUnboxResult (WwOpts -> FamInstEnvs
wo_fam_envs WwOpts
opts) (Id -> Kind
idType Id
res_bndr) Cpr
cpr
  = WwOpts
-> Id
-> DataConPatContext Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
unbox_one_result WwOpts
opts Id
res_bndr DataConPatContext Cpr
dcpc
  | Bool
otherwise
  = (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
boringSplit, Id -> OrdList Id
forall a. a -> OrdList a
unitOL Id
res_bndr, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
res_bndr, CoreExpr -> CoreExpr
nop_fn)

unbox_one_result
  :: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne
-- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR]
unbox_one_result :: WwOpts
-> Id
-> DataConPatContext Cpr
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
unbox_one_result WwOpts
opts Id
res_bndr
                 DataConPatContext { dcpc_dc :: forall s. DataConPatContext s -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: forall s. DataConPatContext s -> [Kind]
dcpc_tc_args = [Kind]
tc_args
                                   , dcpc_co :: forall s. DataConPatContext s -> Coercion
dcpc_co = Coercion
co, dcpc_args :: forall s. DataConPatContext s -> [s]
dcpc_args = [Cpr]
arg_cprs } = do
  -- unboxer (free in `res_bndr`):       |   builder (where <i> builds what was
  --   ( case res_bndr of (i, j) -> )    |            bound to i)
  --   ( case i of I# a ->          )    |
  --   ( case j of I# b ->          )    |     (      (<i>, <j>)      )
  --   ( <hole>                     )    |
  [Unique]
pat_bndrs_uniqs <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
  let ([Id]
_exs, [Id]
arg_ids) =
        [FastString]
-> [Unique] -> Kind -> DataCon -> [Kind] -> ([Id], [Id])
dataConRepFSInstPat (FastString -> [FastString]
forall a. a -> [a]
repeat FastString
ww_prefix) [Unique]
pat_bndrs_uniqs Kind
cprCaseBndrMult DataCon
dc [Kind]
tc_args
  Bool -> UniqSM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
_exs) -- Should have been caught by canUnboxResult

  (Bool
nested_useful, OrdList Id
transit_vars, [CoreExpr]
con_args, CoreExpr -> CoreExpr
work_unbox_res) <-
    WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany
mkWWcpr WwOpts
opts [Id]
arg_ids [Cpr]
arg_cprs

  let -- rebuilt_result = (C a b |> sym co)
      rebuilt_result :: CoreExpr
rebuilt_result = DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
dc ((Kind -> CoreExpr) -> [Kind] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> CoreExpr
forall b. Kind -> Expr b
Type [Kind]
tc_args [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ [CoreExpr]
con_args) HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
      -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> <alt>[a,b])
      this_work_unbox_res :: CoreExpr -> CoreExpr
this_work_unbox_res = CoreExpr
-> Coercion -> Kind -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
res_bndr) Coercion
co Kind
cprCaseBndrMult DataCon
dc [Id]
arg_ids

  -- See Note [Unboxing through unboxed tuples]
  (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
 -> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr))
-> (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, OrdList Id, CoreExpr, CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ if DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
nested_useful
              then ( Bool
boringSplit, Id -> OrdList Id
forall a. a -> OrdList a
unitOL Id
res_bndr, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
res_bndr, CoreExpr -> CoreExpr
nop_fn )
              else ( Bool
usefulSplit
                   , OrdList Id
transit_vars
                   , CoreExpr
rebuilt_result
                   , CoreExpr -> CoreExpr
this_work_unbox_res (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_unbox_res
                   )

-- | Implements part (3) of Note [Worker/wrapper for CPR].
--
-- If `move_transit_vars [a,b] = (unbox, tup)` then
--     * `a` and `b` are the *transit vars* to be returned from the worker
--       to the wrapper
--     * `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)`
--     * `tup = (# a, b #)`
-- There is a special case for when there's 1 transit var,
-- see Note [No unboxed tuple for single, unlifted transit var].
move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)
move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)
move_transit_vars [Id]
vars
  | [Id
var] <- [Id]
vars
  , let var_ty :: Kind
var_ty = Id -> Kind
idType Id
var
  , HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
var_ty Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprIsHNF (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var)
  -- See Note [No unboxed tuple for single, unlifted transit var]
  --   * Wrapper: `unbox scrut alt = (case <scrut> of a -> <alt>)`
  --   * Worker:  `tup = a`
  = ( \CoreExpr
build_res CoreExpr
wkr_call -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
wkr_call Id
var CoreExpr
build_res
    , Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
var ) -- varToCoreExpr important here: var can be a coercion
                          -- Lacking this caused #10658
  | Bool
otherwise
  -- The general case: Just return an unboxed tuple from the worker
  --   * Wrapper: `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)`
  --   * Worker:  `tup = (# a, b #)`
  = ( \CoreExpr
build_res CoreExpr
wkr_call -> CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
wkr_call Id
case_bndr
                                    (DataCon -> AltCon
DataAlt DataCon
tup_con) [Id]
vars CoreExpr
build_res
    , CoreExpr
ubx_tup_app )
   where
    ubx_tup_app :: CoreExpr
ubx_tup_app = [CoreExpr] -> CoreExpr
mkCoreUnboxedTuple ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr [Id]
vars)
    tup_con :: DataCon
tup_con     = Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
vars)
    -- See also Note [Linear types and CPR]
    case_bndr :: Id
case_bndr   = Kind -> Kind -> Id
mkWildValBinder Kind
cprCaseBndrMult (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
ubx_tup_app)


{- Note [Worker/wrapper for CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'mkWWcpr_entry' is the entry-point to the worker/wrapper transformation that
exploits CPR info. Here's an example:
```
  f :: ... -> (Int, Int)
  f ... = <body>
```
Let's assume the CPR info `body_cpr` for the body of `f` says
"unbox the pair and its components" and `body_ty` is the type of the function
body `body` (i.e., `(Int, Int)`). Then `mkWWcpr_entry body_ty body_cpr` returns

  * A result-unpacking expression for the worker, with a hole for the fun body:
    ```
      unpack body = ( case <body> of r __DEFAULT -> )    -- (1)
                    ( case r of (i, j) ->           )    -- (2)
                    ( case i of I# a ->             )    -- (2)
                    ( case j of I# b ->             )    -- (2)
                    ( (# a, b #)                    )    -- (3)
    ```
  * A result-building expression for the wrapper, with a hole for the worker call:
    ```
      build wkr_call = ( case <wkr_call> of (# a, b #) -> )    -- (3)
                       ( (I# a, I# b)                     )    -- (2)
    ```
  * The result type of the worker, e.g., `(# Int#, Int# #)` above.

To achieve said transformation, 'mkWWcpr_entry'

  1. First allocates a fresh result binder `r`, giving a name to the `body`
     expression and contributing part (1) of the unpacker and builder.
  2. Then it delegates to 'mkWWcpr_one', which recurses into all result fields
     to unbox, contributing the parts marked with (2). Crucially, it knows
     what belongs in the case scrutinee of the unpacker through the communicated
     Id `r`: The unpacking expression will be free in that variable.
     (This is a similar contract as that of 'mkWWstr_one' for strict args.)
  3. 'mkWWstr_one' produces a bunch of *transit vars*: Those result variables
     that have to be transferred from the worker to the wrapper, where the
     constructed result can be rebuilt, `a` and `b` above. Part (3) is
     responsible for tupling them up in the worker and taking the tuple apart
     in the wrapper. This is implemented in 'move_transit_vars'.

Note [No unboxed tuple for single, unlifted transit var]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When there's only a single, unlifted transit var (Note [Worker/wrapper for CPR]),
we don't wrap an unboxed singleton tuple around it (which otherwise would be
needed to suspend evaluation) and return the unlifted thing directly. E.g.
```
  f :: Int -> Int
  f x = x+1
```
We certainly want `$wf :: Int# -> Int#`, not `$wf :: Int# -> (# Int# #)`.
This is OK as long as we know that evaluation of the returned thing terminates
quickly, as is the case for fields of unlifted type like `Int#`.

But more generally, this should also be true for *lifted* types that terminate
quickly! Consider from `T18109`:
```
  data F = F (Int -> Int)
  f :: Int -> F
  f n = F (+n)

  data T = T (Int, Int)
  g :: T -> T
  g t@(T p) = p `seq` t

  data U = U ![Int]
  h :: Int -> U
  h n = U [0..n]
```
All of the nested fields are actually ok-for-speculation and thus OK to
return unboxed instead of in an unboxed singleton tuple:

 1. The field of `F` is a HNF.
    We want `$wf :: Int -> Int -> Int`.
    We get  `$wf :: Int -> (# Int -> Int #)`.
 2. The field of `T` is `seq`'d in `g`.
    We want `$wg :: (Int, Int) -> (Int, Int)`.
    We get  `$wg :: (Int, Int) -> (# (Int, Int) #)`.
 3. The field of `U` is strict and thus always evaluated.
    We want  `$wh :: Int# -> [Int]`.
    We'd get `$wh :: Int# -> (# [Int] #)`.

By considering vars as unlifted that satisfy 'exprIsHNF', we catch (3).
Why not check for 'exprOkForSpeculation'? Quite perplexingly, evaluated vars
are not ok-for-spec, see Note [exprOkForSpeculation and evaluated variables].
For (1) and (2) we would have to look at the term. WW only looks at the
type and the CPR signature, so the only way to fix (1) and (2) would be to
have a nested termination signature, like in MR !1866.

Note [Linear types and CPR]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Remark on linearity: in both the case of the wrapper and the worker,
we build a linear case to unpack constructed products. All the
multiplicity information is kept in the constructors (both C and (#, #)).
In particular (#,#) is parameterised by the multiplicity of its fields.
Specifically, in this instance, the multiplicity of the fields of (#,#)
is chosen to be the same as those of C.


************************************************************************
*                                                                      *
\subsection{Utilities}
*                                                                      *
************************************************************************
-}

mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr
-- (mkUnpackCase e co Con args body)
--      returns
-- case e |> co of _dead { Con args -> body }
mkUnpackCase :: CoreExpr
-> Coercion -> Kind -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase (Tick CoreTickish
tickish CoreExpr
e) Coercion
co Kind
mult DataCon
con [Id]
args CoreExpr
body   -- See Note [Profiling and unpacking]
  = CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish (CoreExpr
-> Coercion -> Kind -> DataCon -> [Id] -> CoreExpr -> CoreExpr
mkUnpackCase CoreExpr
e Coercion
co Kind
mult DataCon
con [Id]
args CoreExpr
body)
mkUnpackCase CoreExpr
scrut Coercion
co Kind
mult DataCon
boxing_con [Id]
unpk_args CoreExpr
body
  = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
casted_scrut Id
bndr
                    (DataCon -> AltCon
DataAlt DataCon
boxing_con) [Id]
unpk_args CoreExpr
body
  where
    casted_scrut :: CoreExpr
casted_scrut = CoreExpr
scrut HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
co
    bndr :: Id
bndr = Kind -> Kind -> Id
mkWildValBinder Kind
mult (HasDebugCallStack => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
casted_scrut)

-- | The multiplicity of a case binder unboxing a constructed result.
-- See Note [Linear types and CPR]
cprCaseBndrMult :: Mult
cprCaseBndrMult :: Kind
cprCaseBndrMult = Kind
OneTy

ww_prefix :: FastString
ww_prefix :: FastString
ww_prefix = String -> FastString
fsLit String
"ww"

{- Note [Profiling and unpacking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If the original function looked like
        f = \ x -> {-# SCC "foo" #-} E

then we want the CPR'd worker to look like
        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
and definitely not
        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)

This transform doesn't move work or allocation
from one cost centre to another.

Later [SDM]: presumably this is because we want the simplifier to
eliminate the case, and the scc would get in the way?  I'm ok with
including the case itself in the cost centre, since it is morally
part of the function (post transformation) anyway.
-}