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

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

{-# LANGUAGE CPP #-}

module GHC.Core.Opt.WorkWrap.Utils
   ( mkWwBodies, mkWWstr, mkWorkerArgs
   , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox
   , findTypeShape
   , isWorkerSmallEnough
   )
where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Core
import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase
                        , dataConRepFSInstPat )
import GHC.Types.Id
import GHC.Types.Id.Info ( JoinArity )
import GHC.Core.DataCon
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup
                        , mkCoreApp, mkCoreLet )
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Builtin.Types      ( tupleDataCon, unboxedUnitTy )
import GHC.Types.Literal ( absentLiteralOf, rubbishLit )
import GHC.Types.Var.Env ( mkInScopeSet )
import GHC.Types.Var.Set ( VarSet )
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Predicate ( isClassPred )
import GHC.Types.RepType  ( isVoidTy, typePrimRep )
import GHC.Core.Coercion
import GHC.Core.FamInstEnv
import GHC.Types.Basic       ( Boxity(..) )
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
import GHC.Types.Unique.Supply
import GHC.Types.Unique
import GHC.Types.Name ( getOccFS )
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Data.FastString
import GHC.Data.List.SetOps

{-
************************************************************************
*                                                                      *
\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.
-}

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

mkWwBodies :: DynFlags
           -> FamInstEnvs
           -> VarSet         -- Free vars of RHS
                             -- See Note [Freshen WW arguments]
           -> Id             -- The original function
           -> [Demand]       -- Strictness of original function
           -> Cpr            -- Info about function result
           -> UniqSM (Maybe WwResult)

-- wrap_fn_args E       = \x y -> E
-- work_fn_args E       = E x y

-- wrap_fn_str E        = case x of { (a,b) ->
--                        case a of { (a1,a2) ->
--                        E a1 a2 b y }}
-- work_fn_str E        = \a1 a2 b y ->
--                        let a = (a1,a2) in
--                        let x = (a,b) in
--                        E

mkWwBodies :: DynFlags
-> FamInstEnvs
-> VarSet
-> Id
-> [Demand]
-> Cpr
-> UniqSM (Maybe WwResult)
mkWwBodies DynFlags
dflags FamInstEnvs
fam_envs VarSet
rhs_fvs Id
fun_id [Demand]
demands Cpr
cpr_info
  = do  { let empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet VarSet
rhs_fvs)
                -- See Note [Freshen WW arguments]

        ; ([Id]
wrap_args, CoreExpr -> CoreExpr
wrap_fn_args, CoreExpr -> CoreExpr
work_fn_args, Kind
res_ty)
             <- TCvSubst
-> Kind
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWargs TCvSubst
empty_subst Kind
fun_ty [Demand]
demands
        ; (Bool
useful1, [Id]
work_args, CoreExpr -> CoreExpr
wrap_fn_str, CoreExpr -> CoreExpr
work_fn_str)
             <- DynFlags
-> FamInstEnvs
-> Bool
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr DynFlags
dflags FamInstEnvs
fam_envs Bool
has_inlineable_prag [Id]
wrap_args

        -- Do CPR w/w.  See Note [Always do CPR w/w]
        ; (Bool
useful2, CoreExpr -> CoreExpr
wrap_fn_cpr, CoreExpr -> CoreExpr
work_fn_cpr, Kind
cpr_res_ty)
              <- Bool
-> FamInstEnvs
-> Kind
-> Cpr
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWcpr (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CprAnal DynFlags
dflags) FamInstEnvs
fam_envs Kind
res_ty Cpr
cpr_info

        ; let ([Id]
work_lam_args, [Id]
work_call_args) = DynFlags -> [Id] -> Kind -> ([Id], [Id])
mkWorkerArgs DynFlags
dflags [Id]
work_args Kind
cpr_res_ty
              worker_args_dmds :: [Demand]
worker_args_dmds = [Id -> Demand
idDemandInfo Id
v | Id
v <- [Id]
work_call_args, Id -> Bool
isId Id
v]
              wrapper_body :: Id -> CoreExpr
wrapper_body = CoreExpr -> CoreExpr
wrap_fn_args (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 -> CoreExpr
applyToVars [Id]
work_call_args (CoreExpr -> CoreExpr) -> (Id -> CoreExpr) -> Id -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> CoreExpr
forall b. Id -> Expr b
Var
              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_fn_str (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
work_fn_args

        ; if DynFlags -> Int -> [Id] -> Bool
isWorkerSmallEnough DynFlags
dflags ([Demand] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Demand]
demands) [Id]
work_args
             Bool -> Bool -> Bool
&& Bool -> Bool
not ([Id] -> Bool
too_many_args_for_join_point [Id]
wrap_args)
             Bool -> Bool -> Bool
&& ((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 (m :: * -> *) a. Monad m => a -> m a
return (WwResult -> Maybe WwResult
forall a. a -> Maybe a
Just ([Demand]
worker_args_dmds, [Id] -> 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 (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
    fun_ty :: Kind
fun_ty        = Id -> Kind
idType Id
fun_id
    mb_join_arity :: Maybe Int
mb_join_arity = Id -> Maybe Int
isJoinId_maybe Id
fun_id
    has_inlineable_prag :: Bool
has_inlineable_prag = Unfolding -> Bool
isStableUnfolding (Id -> Unfolding
realIdUnfolding Id
fun_id)
                          -- See Note [Do not unpack class dictionaries]

    -- Note [Do not split void functions]
    only_one_void_argument :: Bool
only_one_void_argument
      | [Demand
d] <- [Demand]
demands
      , Just (Kind
_, Kind
arg_ty1, Kind
_) <- Kind -> Maybe (Kind, Kind, Kind)
splitFunTy_maybe Kind
fun_ty
      , Demand -> Bool
isAbsDmd Demand
d Bool -> Bool -> Bool
&& Kind -> Bool
isVoidTy Kind
arg_ty1
      = Bool
True
      | Bool
otherwise
      = Bool
False

    -- Note [Join points returning functions]
    too_many_args_for_join_point :: [Id] -> Bool
too_many_args_for_join_point [Id]
wrap_args
      | Just Int
join_arity <- Maybe Int
mb_join_arity
      , [Id]
wrap_args [Id] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
join_arity
      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>
                     int join_arity <+> text "but" <+>
                     int (length wrap_args) <+> text "args")
        Bool
True
      | Bool
otherwise
      = Bool
False

-- See Note [Limit w/w arity]
isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool
isWorkerSmallEnough :: DynFlags -> Int -> [Id] -> Bool
isWorkerSmallEnough DynFlags
dflags 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 (DynFlags -> Int
maxWorkerArgs DynFlags
dflags)
    -- 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.

************************************************************************
*                                                                      *
\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.
-}

mkWorkerArgs :: DynFlags -> [Var]
             -> Type    -- Type of body
             -> ([Var], -- Lambda bound args
                 [Var]) -- Args at call site
mkWorkerArgs :: DynFlags -> [Id] -> Kind -> ([Id], [Id])
mkWorkerArgs DynFlags
dflags [Id]
args Kind
res_ty
    | (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
isId [Id]
args Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
needsAValueLambda
    = ([Id]
args, [Id]
args)
    | Bool
otherwise
    = ([Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId], [Id]
args [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidPrimId])
    where
      -- See "Making wrapper args" section above
      needsAValueLambda :: Bool
needsAValueLambda =
        Bool
lifted
        -- We may encounter a levity-polymorphic result, in which case we
        -- conservatively assume that we have laziness that needs preservation.
        -- See #15186.
        Bool -> Bool -> Bool
|| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FunToThunk DynFlags
dflags)
           -- see Note [Protecting the last value argument]

      -- Might the result be lifted?
      lifted :: Bool
lifted =
        case HasDebugCallStack => Kind -> Maybe Bool
Kind -> Maybe Bool
isLiftedType_maybe Kind
res_ty of
          Just Bool
lifted -> Bool
lifted
          Maybe Bool
Nothing     -> Bool
True

{-
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.

The user can avoid adding the void argument with the -ffun-to-thunk
flag. However, this can create sharing, which may be bad in two ways. 1) It can
create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
removes the last argument from a function f, then f now looks like a thunk, and
so f can't be inlined *under a lambda*.

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 [Join points returning functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

It is crucial that the arity of a join point depends on its *callers,* not its
own syntax. What this means is that a join point can have "extra lambdas":

f :: Int -> Int -> (Int, Int) -> Int
f x y = join j (z, w) = \(u, v) -> ...
        in jump j (x, y)

Typically this happens with functions that are seen as computing functions,
rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.)

When we create the wrapper, it *must* be in "eta-contracted" form so that the
jump has the right number of arguments:

f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
             j (z, w)  = jump $wj z w

(See Note [Join points and beta-redexes] for where the lets come from.) If j
were a function, we would instead say

f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
            j (z, w) (u, v) = $wj z w u v

Notice that the worker ends up with the same lambdas; it's only the wrapper we
have to be concerned about.

FIXME Currently the functionality to produce "eta-contracted" wrappers is
unimplemented; we simply give up.

************************************************************************
*                                                                      *
\subsection{Coercion stuff}
*                                                                      *
************************************************************************

We really want to "look through" coerces.
Reason: I've seen this situation:

        let f = coerce T (\s -> E)
        in \x -> case x of
                    p -> coerce T' f
                    q -> \s -> E2
                    r -> coerce T' f

If only we w/w'd f, we'd get
        let f = coerce T (\s -> fw s)
            fw = \s -> E
        in ...

Now we'll inline f to get

        let fw = \s -> E
        in \x -> case x of
                    p -> fw
                    q -> \s -> E2
                    r -> fw

Now we'll see that fw has arity 1, and will arity expand
the \x to get what we want.
-}

-- mkWWargs just does eta expansion
-- is driven off the function type and arity.
-- It chomps bites off foralls, arrows, newtypes
-- and keeps repeating that until it's satisfied the supplied arity

mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type
                                --   See Note [Freshen WW arguments]
         -> Type                -- The type of the function
         -> [Demand]     -- Demands and one-shot info for value arguments
         -> UniqSM  ([Var],            -- Wrapper args
                     CoreExpr -> CoreExpr,      -- Wrapper fn
                     CoreExpr -> CoreExpr,      -- Worker fn
                     Type)                      -- Type of wrapper body

mkWWargs :: TCvSubst
-> Kind
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWargs TCvSubst
subst Kind
fun_ty [Demand]
demands
  | [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
demands
  = ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, HasCallStack => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
substTy TCvSubst
subst Kind
fun_ty)

  | (Demand
dmd:[Demand]
demands') <- [Demand]
demands
  , Just (Kind
mult, Kind
arg_ty, Kind
fun_ty') <- Kind -> Maybe (Kind, Kind, Kind)
splitFunTy_maybe Kind
fun_ty
  = do  { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
        ; let arg_ty' :: Scaled Kind
arg_ty' = HasCallStack => TCvSubst -> Scaled Kind -> Scaled Kind
TCvSubst -> Scaled Kind -> Scaled Kind
substScaledTy TCvSubst
subst (Kind -> Kind -> Scaled Kind
forall a. Kind -> a -> Scaled a
Scaled Kind
mult Kind
arg_ty)
              id :: Id
id = Unique -> Scaled Kind -> Demand -> Id
mk_wrap_arg Unique
uniq Scaled Kind
arg_ty' Demand
dmd
        ; ([Id]
wrap_args, CoreExpr -> CoreExpr
wrap_fn_args, CoreExpr -> CoreExpr
work_fn_args, Kind
res_ty)
              <- TCvSubst
-> Kind
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWargs TCvSubst
subst Kind
fun_ty' [Demand]
demands'
        ; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
id Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
wrap_args,
                  Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
id (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn_args,
                  (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
apply_or_bind_then CoreExpr -> CoreExpr
work_fn_args (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
id),
                  Kind
res_ty) }

  | Just (Id
tv, Kind
fun_ty') <- Kind -> Maybe (Id, Kind)
splitForAllTyCoVar_maybe Kind
fun_ty
  = do  { Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
        ; let (TCvSubst
subst', Id
tv') = TCvSubst -> Id -> Unique -> (TCvSubst, Id)
cloneTyVarBndr TCvSubst
subst Id
tv Unique
uniq
                -- See Note [Freshen WW arguments]
        ; ([Id]
wrap_args, CoreExpr -> CoreExpr
wrap_fn_args, CoreExpr -> CoreExpr
work_fn_args, Kind
res_ty)
             <- TCvSubst
-> Kind
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWargs TCvSubst
subst' Kind
fun_ty' [Demand]
demands
        ; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
tv' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
wrap_args,
                  Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
tv' (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap_fn_args,
                  (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
apply_or_bind_then CoreExpr -> CoreExpr
work_fn_args (Kind -> CoreExpr
forall b. Kind -> Expr b
mkTyArg (Id -> Kind
mkTyVarTy Id
tv')),
                  Kind
res_ty) }

  | Just (Coercion
co, Kind
rep_ty) <- Kind -> Maybe (Coercion, Kind)
topNormaliseNewType_maybe Kind
fun_ty
        -- The newtype case is for when the function has
        -- a newtype after the arrow (rare)
        --
        -- It's also important when we have a function returning (say) a pair
        -- wrapped in a  newtype, at least if CPR analysis can look
        -- through such newtypes, which it probably can since they are
        -- simply coerces.

  = do { ([Id]
wrap_args, CoreExpr -> CoreExpr
wrap_fn_args, CoreExpr -> CoreExpr
work_fn_args, Kind
res_ty)
            <-  TCvSubst
-> Kind
-> [Demand]
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWargs TCvSubst
subst Kind
rep_ty [Demand]
demands
       ; let co' :: Coercion
co' = HasCallStack => TCvSubst -> Coercion -> Coercion
TCvSubst -> Coercion -> Coercion
substCo TCvSubst
subst Coercion
co
       ; ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
wrap_args,
                  \CoreExpr
e -> CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast (CoreExpr -> CoreExpr
wrap_fn_args CoreExpr
e) (Coercion -> Coercion
mkSymCo Coercion
co'),
                  \CoreExpr
e -> CoreExpr -> CoreExpr
work_fn_args (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e Coercion
co'),
                  Kind
res_ty) }

  | Bool
otherwise
  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand
    ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, HasCallStack => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
substTy TCvSubst
subst Kind
fun_ty)   -- then there should be a function arrow
  where
    -- See Note [Join points and beta-redexes]
    apply_or_bind_then :: (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr
apply_or_bind_then CoreExpr -> CoreExpr
k CoreExpr
arg (Lam Id
bndr CoreExpr
body)
      = CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr CoreExpr
arg) (CoreExpr -> CoreExpr
k CoreExpr
body)    -- Important that arg is fresh!
    apply_or_bind_then CoreExpr -> CoreExpr
k CoreExpr
arg CoreExpr
fun
      = CoreExpr -> CoreExpr
k (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp (String -> SDoc
text String
"mkWWargs") CoreExpr
fun CoreExpr
arg
applyToVars :: [Var] -> CoreExpr -> CoreExpr
applyToVars :: [Id] -> CoreExpr -> CoreExpr
applyToVars [Id]
vars CoreExpr
fn = CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps CoreExpr
fn [Id]
vars

mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id
mk_wrap_arg :: Unique -> Scaled Kind -> Demand -> Id
mk_wrap_arg Unique
uniq (Scaled Kind
w Kind
ty) Demand
dmd
  = FastString -> Unique -> Kind -> Kind -> Id
mkSysLocalOrCoVar (String -> FastString
fsLit String
"w") Unique
uniq Kind
w Kind
ty
       Id -> Demand -> Id
`setIdDemandInfo` Demand
dmd

{- Note [Freshen WW arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Wen we do a worker/wrapper split, we must not in-scope names as the arguments
of the worker, else we'll get name capture.  E.g.

   -- y1 is in scope from further out
   f x = ..y1..

If we accidentally choose y1 as a worker argument disaster results:

   fww y1 y2 = let x = (y1,y2) in ...y1...

To avoid this:

  * We use a fresh unique for both type-variable and term-variable binders
    Originally we lacked this freshness for type variables, and that led
    to the very obscure #12562.  (A type variable in the worker shadowed
    an outer term-variable binding.)

  * Because of this cloning we have to substitute in the type/kind of the
    new binders.  That's why we carry the TCvSubst through mkWWargs.

    So we need a decent in-scope set, just in case that type/kind
    itself has foralls.  We get this from the free vars of the RHS of the
    function since those are the only variables that might be captured.
    It's a lazy thunk, which will only be poked if the type/kind has a forall.

    Another tricky case was when f :: forall a. a -> forall a. a->a
    (i.e. with shadowing), and then the worker used the same 'a' twice.
-}

{-
************************************************************************
*                                                                      *
\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@
data DataConPatContext
  = DataConPatContext
  { DataConPatContext -> DataCon
dcpc_dc      :: !DataCon
  , DataConPatContext -> [Kind]
dcpc_tc_args :: ![Type]
  , DataConPatContext -> Coercion
dcpc_co      :: !Coercion
  }

-- | If @splitArgType_maybe ty = Just (dc, tys, co)@
-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
-- and  @co :: ty ~ tc tys@
-- where underscore prefixes are holes, e.g. yet unspecified.
--
-- See Note [Which types are unboxed?].
splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext
splitArgType_maybe :: FamInstEnvs -> Kind -> Maybe DataConPatContext
splitArgType_maybe FamInstEnvs
fam_envs Kind
ty
  | let (Coercion
co, Kind
ty1) = FamInstEnvs -> Kind -> Maybe (Coercion, Kind)
topNormaliseType_maybe FamInstEnvs
fam_envs Kind
ty
                    Maybe (Coercion, Kind) -> (Coercion, Kind) -> (Coercion, Kind)
forall a. Maybe a -> a -> a
`orElse` (Kind -> Coercion
mkRepReflCo Kind
ty, Kind
ty)
  , Just (TyCon
tc, [Kind]
tc_args) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
ty1
  , Just DataCon
con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
  = DataConPatContext -> Maybe DataConPatContext
forall a. a -> Maybe a
Just DataConPatContext { dcpc_dc :: DataCon
dcpc_dc      = DataCon
con
                           , dcpc_tc_args :: [Kind]
dcpc_tc_args = [Kind]
tc_args
                           , dcpc_co :: Coercion
dcpc_co      = Coercion
co }
splitArgType_maybe FamInstEnvs
_ Kind
_ = Maybe DataConPatContext
forall a. Maybe a
Nothing

-- | If @splitResultType_maybe n ty = Just (dc, tys, co)@
-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@
-- and  @co :: ty ~ tc tys@
-- where underscore prefixes are holes, e.g. yet unspecified.
-- @dc@ is the @n@th data constructor of @tc@.
--
-- See Note [Which types are unboxed?].
splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext
splitResultType_maybe :: FamInstEnvs -> Int -> Kind -> Maybe DataConPatContext
splitResultType_maybe FamInstEnvs
fam_envs Int
con_tag Kind
ty
  | let (Coercion
co, Kind
ty1) = FamInstEnvs -> Kind -> Maybe (Coercion, Kind)
topNormaliseType_maybe FamInstEnvs
fam_envs Kind
ty
                    Maybe (Coercion, Kind) -> (Coercion, Kind) -> (Coercion, Kind)
forall a. Maybe a -> a -> a
`orElse` (Kind -> Coercion
mkRepReflCo Kind
ty, Kind
ty)
  , Just (TyCon
tc, [Kind]
tc_args) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
ty1
  , TyCon -> Bool
isDataTyCon TyCon
tc -- NB: rules out unboxed sums and pairs!
  , let cons :: [DataCon]
cons = TyCon -> [DataCon]
tyConDataCons TyCon
tc
  , [DataCon]
cons [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 con :: DataCon
con = [DataCon]
cons [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 (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Id]
dataConExTyCoVars DataCon
con) -- no existentials;
                                 -- See Note [Which types are unboxed?]
                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt
                                 -- where we also check this.
  , (Scaled Kind -> Bool) -> [Scaled Kind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Scaled Kind -> Bool
forall a. Scaled a -> Bool
isLinear (DataCon -> [Kind] -> [Scaled Kind]
dataConInstArgTys DataCon
con [Kind]
tc_args)
  -- Deactivates CPR worker/wrapper splits on constructors with non-linear
  -- arguments, for the moment, because they require unboxed tuple with variable
  -- multiplicity fields.
  = DataConPatContext -> Maybe DataConPatContext
forall a. a -> Maybe a
Just DataConPatContext { dcpc_dc :: DataCon
dcpc_dc = DataCon
con
                           , dcpc_tc_args :: [Kind]
dcpc_tc_args = [Kind]
tc_args
                           , dcpc_co :: Coercion
dcpc_co = Coercion
co }
splitResultType_maybe FamInstEnvs
_ Int
_ Kind
_ = Maybe DataConPatContext
forall a. Maybe a
Nothing

isLinear :: Scaled a -> Bool
isLinear :: forall a. Scaled a -> Bool
isLinear (Scaled Kind
w a
_ ) =
  case Kind
w of
    Kind
One -> Bool
True
    Kind
_ -> Bool
False

-- | Describes the outer shape of an argument to be unboxed or left as-is
-- Depending on how @s@ is instantiated (e.g., 'Demand').
data UnboxingDecision s
  = StopUnboxing
  -- ^ We ran out of strictness info. Leave untouched.
  | Unbox !DataConPatContext [s]
  -- ^ The argument is used strictly or the returned product was constructed, so
  -- unbox it.
  -- The 'DataConPatContext' carries the bits necessary for
  -- instantiation with 'dataConRepInstPat'.
  -- The @[s]@ carries the bits of information with which we can continue
  -- unboxing, e.g. @s@ will be 'Demand'.

wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand
-- See Note [Which types are unboxed?]
wantToUnbox :: FamInstEnvs -> Bool -> Kind -> Demand -> UnboxingDecision Demand
wantToUnbox FamInstEnvs
fam_envs Bool
has_inlineable_prag Kind
ty Demand
dmd =
  case FamInstEnvs -> Kind -> Maybe DataConPatContext
splitArgType_maybe FamInstEnvs
fam_envs Kind
ty of
    Just dcpc :: DataConPatContext
dcpc@DataConPatContext{ dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc = DataCon
dc }
      | Demand -> Bool
isStrUsedDmd Demand
dmd Bool -> Bool -> Bool
|| HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
ty
      , let arity :: Int
arity = DataCon -> Int
dataConRepArity DataCon
dc
      -- See Note [Unpacking arguments with product and polymorphic demands]
      , Just [Demand]
cs <- Demand -> Int -> Maybe [Demand]
split_prod_dmd_arity Demand
dmd Int
arity
      -- See Note [Do not unpack class dictionaries]
      , Bool -> Bool
not (Bool
has_inlineable_prag Bool -> Bool -> Bool
&& Kind -> Bool
isClassPred Kind
ty)
      -- See Note [mkWWstr and unsafeCoerce]
      , [Demand]
cs [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
arity
      -- See Note [Add demands for strict constructors]
      , let cs' :: [Demand]
cs' = DataCon -> [Demand] -> [Demand]
addDataConStrictness DataCon
dc [Demand]
cs
      -> DataConPatContext -> [Demand] -> UnboxingDecision Demand
forall s. DataConPatContext -> [s] -> UnboxingDecision s
Unbox DataConPatContext
dcpc [Demand]
cs'
    Maybe DataConPatContext
_ -> UnboxingDecision Demand
forall s. UnboxingDecision s
StopUnboxing
  where
    split_prod_dmd_arity :: Demand -> Int -> Maybe [Demand]
split_prod_dmd_arity Demand
dmd Int
arity
      -- For seqDmd, it should behave like <S(AAAA)>, for some
      -- suitable arity
      | Demand -> Bool
isSeqDmd Demand
dmd        = [Demand] -> Maybe [Demand]
forall a. a -> Maybe a
Just (Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate Int
arity Demand
absDmd)
      | Card
_ :* Prod [Demand]
ds <- Demand
dmd = [Demand] -> Maybe [Demand]
forall a. a -> Maybe a
Just [Demand]
ds
      | Bool
otherwise           = Maybe [Demand]
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)
       * has a single constructor (thus is a "product")
       * that may bind existentials
     We can transform
     > 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)
       * (might have multiple constructors, in contrast to (1))
       * the applied data constructor *does not* bind existentials
     We can transform
     > f x y = let ... in D a b
     to
     > $wf x y = let ... in (# a, b #)
     via 'mkWWcpr'.

     NB: 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..) #)

The respective tests are in 'splitArgType_maybe' and
'splitResultType_maybe', respectively.

Note that the data constructor /can/ have evidence arguments: equality
constraints, type classes etc.  So it can be GADT.  These evidence
arguments are simply value arguments, and should not get in the way.

Note [Unpacking arguments with product and polymorphic demands]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The argument is unpacked in a case if it has a product type and has a
strict *and* used demand put on it. I.e., arguments, with demands such
as the following ones:

   <S,U(U, L)>
   <S(L,S),U>

will be unpacked, but

   <S,U> or <B,U>

will not, because the pieces aren't used. This is quite important otherwise
we end up unpacking massive tuples passed to the bottoming function. Example:

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

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

Does 'main' print "error 1" or "error no"?  We don't really want 'f'
to unbox its second argument.  This actually happened in GHC's onwn
source code, in Packages.applyPackageFlag, which ended up un-boxing
the enormous DynFlags tuple, and being strict in the
as-yet-un-filled-in unitState files.

Note [Do not unpack class dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have
   f :: Ord a => [a] -> Int -> a
   {-# INLINABLE f #-}
and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
which can still be specialised by the type-class specialiser, something like
   fw :: Ord a => [a] -> Int# -> a

BUT if f is strict in the Ord dictionary, we might unpack it, to get
   fw :: (a->a->Bool) -> [a] -> Int# -> a
and the type-class specialiser can't specialise that. An example is #6056.

But in any other situation a dictionary is just an ordinary value,
and can be unpacked.  So we track the INLINABLE pragma, and switch
off the unpacking in mkWWstr_one (see the isClassPred test).

Historical note: #14955 describes how I got this fix wrong the first time.

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 [Add demands for strict constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this program (due to Roman):

    data X a = X !a

    foo :: X Int -> Int -> Int
    foo (X a) n = go 0
     where
       go i | i < n     = a + go (i+1)
            | otherwise = 0

We want the worker for 'foo' too look like this:

    $wfoo :: Int# -> Int# -> Int#

with the first argument unboxed, so that it is not eval'd each time
around the 'go' loop (which would otherwise happen, since 'foo' is not
strict in 'a').  It is sound for the wrapper to pass an unboxed arg
because X is strict, so its argument must be evaluated.  And if we
*don't* pass an unboxed argument, we can't even repair it by adding a
`seq` thus:

    foo (X a) n = a `seq` go 0

because the seq is discarded (very early) since X is strict!

So here's what we do

* We leave the demand-analysis alone.  The demand on 'a' in the
  definition of 'foo' is <L, U(U)>; the strictness info is Lazy
  because foo's body may or may not evaluate 'a'; but the usage info
  says that 'a' is unpacked and its content is used.

* During worker/wrapper, if we unpack a strict constructor (as we do
  for 'foo'), we use 'addDataConStrictness' to bump up the strictness on
  the strict arguments of the data constructor.

* That in turn means that, if the usage info supports doing so
  (i.e. splitProdDmd_maybe returns Just), we will unpack that argument
  -- even though the original demand (e.g. on 'a') was lazy.

* What does "bump up the strictness" mean?  Just add a head-strict
  demand to the strictness!  Even for a demand like <L,A> we can
  safely turn it into <S,A>; remember case (1) of
  Note [How to do the worker/wrapper split].

The net effect is that the w/w transformation is more aggressive about
unpacking the strict arguments of a data constructor, when that
eagerness is supported by the usage info.

There is the usual danger of reboxing, which as usual we ignore. But
if X is monomorphic, and has an UNPACK pragma, then this optimisation
is even more important.  We don't want the wrapper to rebox an unboxed
argument, and pass an Int to $wfoo!

This works in nested situations like

    data family Bar a
    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
    newtype instance Bar Int = Bar Int

    foo :: Bar ((Int, Int), Int) -> Int -> Int
    foo f k = case f of BarPair x y ->
              case burble of
                 True -> case x of
                           BarPair p q -> ...
                 False -> ...

The extra eagerness lets us produce a worker of type:
     $wfoo :: Int# -> Int# -> Int# -> Int -> Int
     $wfoo p# q# y# = ...

even though the `case x` is only lazily evaluated.

--------- Historical note ------------
We used to add data-con strictness demands when demand analysing case
expression. However, it was noticed in #15696 that this misses some cases. For
instance, consider the program (from T10482)

    data family Bar a
    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
    newtype instance Bar Int = Bar Int

    foo :: Bar ((Int, Int), Int) -> Int -> Int
    foo f k =
      case f of
        BarPair x y -> case burble of
                          True -> case x of
                                    BarPair p q -> ...
                          False -> ...

We really should be able to assume that `p` is already evaluated since it came
from a strict field of BarPair. This strictness would allow us to produce a
worker of type:

    $wfoo :: Int# -> Int# -> Int# -> Int -> Int
    $wfoo p# q# y# = ...

even though the `case x` is only lazily evaluated

Indeed before we fixed #15696 this would happen since we would float the inner
`case x` through the `case burble` to get:

    foo f k =
      case f of
        BarPair x y -> case x of
                          BarPair p q -> case burble of
                                          True -> ...
                                          False -> ...

However, after fixing #15696 this could no longer happen (for the reasons
discussed in ticket:15696#comment:76). This means that the demand placed on `f`
would then be significantly weaker (since the False branch of the case on
`burble` is not strict in `p` or `q`).

Consequently, we now instead account for data-con strictness in mkWWstr_one,
applying the strictness demands to the final result of DmdAnal. The result is
that we get the strict demand signature we wanted even if we can't float
the case on `x` up through the case on `burble`.
-}

{-
************************************************************************
*                                                                      *
\subsection{Strictness stuff}
*                                                                      *
************************************************************************
-}

mkWWstr :: DynFlags
        -> FamInstEnvs
        -> Bool    -- True <=> INLINEABLE pragma on this function defn
                   -- See Note [Do not unpack class dictionaries]
        -> [Var]                                -- Wrapper args; have their demand info on them
                                                --  *Includes type variables*
        -> UniqSM (Bool,                        -- Is this useful
                   [Var],                       -- Worker args
                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call
                                                -- and without its lambdas
                                                -- This fn adds the unboxing

                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,
                                                -- and lacking its lambdas.
                                                -- This fn does the reboxing
mkWWstr :: DynFlags
-> FamInstEnvs
-> Bool
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr DynFlags
dflags FamInstEnvs
fam_envs Bool
has_inlineable_prag [Id]
args
  = [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go [Id]
args
  where
    go_one :: Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go_one Id
arg = DynFlags
-> FamInstEnvs
-> Bool
-> Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one DynFlags
dflags FamInstEnvs
fam_envs Bool
has_inlineable_prag Id
arg

    go :: [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go []           = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [], CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)
    go (Id
arg : [Id]
args) = do { (Bool
useful1, [Id]
args1, CoreExpr -> CoreExpr
wrap_fn1, CoreExpr -> CoreExpr
work_fn1) <- Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go_one Id
arg
                         ; (Bool
useful2, [Id]
args2, CoreExpr -> CoreExpr
wrap_fn2, CoreExpr -> CoreExpr
work_fn2) <- [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
go [Id]
args
                         ; (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bool
useful1 Bool -> Bool -> Bool
|| Bool
useful2
                                  , [Id]
args1 [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
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 -> CoreExpr
work_fn1 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
work_fn2) }

----------------------
-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
--   *  wrap_fn assumes wrap_arg is in scope,
--        brings into scope work_args (via cases)
--   * work_fn assumes work_args are in scope, a
--        brings into scope wrap_arg (via lets)
-- See Note [How to do the worker/wrapper split]
mkWWstr_one :: DynFlags -> FamInstEnvs
            -> Bool    -- True <=> INLINEABLE pragma on this function defn
                       -- See Note [Do not unpack class dictionaries]
            -> Var
            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one :: DynFlags
-> FamInstEnvs
-> Bool
-> Id
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one DynFlags
dflags FamInstEnvs
fam_envs Bool
has_inlineable_prag Id
arg
  | Id -> Bool
isTyVar Id
arg
  = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [Id
arg],  CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)

  | Demand -> Bool
isAbsDmd Demand
dmd
  , Just CoreExpr -> CoreExpr
work_fn <- DynFlags
-> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let DynFlags
dflags FamInstEnvs
fam_envs Id
arg Demand
dmd
     -- Absent case.  We can't always handle absence for arbitrary
     -- unlifted types, so we need to choose just the cases we can
     -- (that's what mk_absent_let does)
  = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [], CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
work_fn)

  | Unbox DataConPatContext
dcpc [Demand]
cs <- FamInstEnvs -> Bool -> Kind -> Demand -> UnboxingDecision Demand
wantToUnbox FamInstEnvs
fam_envs Bool
has_inlineable_prag Kind
arg_ty Demand
dmd
  = DynFlags
-> FamInstEnvs
-> Id
-> [Demand]
-> DataConPatContext
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one DynFlags
dflags FamInstEnvs
fam_envs Id
arg [Demand]
cs DataConPatContext
dcpc

  | Bool
otherwise   -- Other cases
  = (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [Id
arg], CoreExpr -> CoreExpr
nop_fn, CoreExpr -> CoreExpr
nop_fn)

  where
    arg_ty :: Kind
arg_ty = Id -> Kind
idType Id
arg
    dmd :: Demand
dmd    = Id -> Demand
idDemandInfo Id
arg

unbox_one :: DynFlags -> FamInstEnvs -> Var
          -> [Demand]
          -> DataConPatContext
          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one :: DynFlags
-> FamInstEnvs
-> Id
-> [Demand]
-> DataConPatContext
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
unbox_one DynFlags
dflags FamInstEnvs
fam_envs Id
arg [Demand]
cs
          DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: DataConPatContext -> [Kind]
dcpc_tc_args = [Kind]
tc_args
                            , dcpc_co :: DataConPatContext -> Coercion
dcpc_co = Coercion
co }
  = do { (Unique
case_bndr_uniq:[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
             ([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) DataCon
dc [Kind]
tc_args
             arg_ids' :: [Id]
arg_ids'  = String -> (Id -> Demand -> Id) -> [Id] -> [Demand] -> [Id]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"unbox_one" Id -> Demand -> Id
setIdDemandInfo [Id]
arg_ids [Demand]
cs
             unbox_fn :: CoreExpr -> CoreExpr
unbox_fn  = CoreExpr
-> Coercion
-> Kind
-> Unique
-> DataCon
-> [Id]
-> CoreExpr
-> CoreExpr
mkUnpackCase (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
arg) Coercion
co (Id -> Kind
idMult Id
arg) Unique
case_bndr_uniq
                                      DataCon
dc ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids')
             arg_no_unf :: Id
arg_no_unf = Id -> Id
zapStableUnfolding Id
arg
                          -- See Note [Zap unfolding when beta-reducing]
                          -- in GHC.Core.Opt.Simplify; and see #13890
             rebox_fn :: CoreExpr -> CoreExpr
rebox_fn   = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg_no_unf CoreExpr
con_app)
             con_app :: CoreExpr
con_app    = DataCon -> [Kind] -> [Id] -> CoreExpr
forall b. DataCon -> [Kind] -> [Id] -> Expr b
mkConApp2 DataCon
dc [Kind]
tc_args ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids') CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
       ; (Bool
_, [Id]
worker_args, CoreExpr -> CoreExpr
wrap_fn, CoreExpr -> CoreExpr
work_fn) <- DynFlags
-> FamInstEnvs
-> Bool
-> [Id]
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr DynFlags
dflags FamInstEnvs
fam_envs Bool
False ([Id]
ex_tvs' [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
arg_ids')
       ; (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
-> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [Id]
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 -> CoreExpr
work_fn (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
rebox_fn) }
                          -- Don't pass the arg, rebox instead

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

addDataConStrictness :: DataCon -> [Demand] -> [Demand]
-- See Note [Add demands for strict constructors]
addDataConStrictness :: DataCon -> [Demand] -> [Demand]
addDataConStrictness DataCon
con [Demand]
ds
  | Maybe Id
Nothing <- DataCon -> Maybe Id
dataConWrapId_maybe DataCon
con
  -- DataCon worker=wrapper. Implies no strict fields, so nothing to do
  = [Demand]
ds
addDataConStrictness DataCon
con [Demand]
ds
  = String
-> (Demand -> StrictnessMark -> Demand)
-> [Demand]
-> [StrictnessMark]
-> [Demand]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"addDataConStrictness" Demand -> StrictnessMark -> Demand
add [Demand]
ds [StrictnessMark]
strs
  where
    strs :: [StrictnessMark]
strs = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con
    add :: Demand -> StrictnessMark -> Demand
add Demand
dmd StrictnessMark
str | StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str = Demand -> Demand
strictifyDmd Demand
dmd
                | Bool
otherwise          = Demand
dmd

{- Note [How to do the worker/wrapper split]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The worker-wrapper transformation, mkWWstr_one, 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 isAbsDmd case.  This case must come
   first because a demand like <S,A> or <B,A> is possible.
   E.g. <B,A> comes from a function like
       f x = error "urk"
   and <S,A> can come from Note [Add demands for strict constructors]

2. If the argument is evaluated strictly, and we can split the
   product demand (splitProdDmd_maybe), then unbox it and w/w its
   pieces.  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/ split if the components are not used; that is, the
   usage is just 'Used' rather than 'UProd'. In this case
   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing
   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

3. A plain 'seqDmd', which is head-strict with usage UHead, can't
   be split by splitProdDmd_maybe.  But we want it to behave just
   like U(AAAA) for suitable number of absent demands. So we have
   a special case for it, with arity coming from the data constructor.

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
         See #13077, test T13077
 (B) The result binders r1,r2 in mkWWcpr_help
         See Trace #13077, test T13077a
         And #13027 comment:20, item (4)
to record that the relevant binder is evaluated.


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

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 (Kind
_, Kind
_, Kind
res) <- Kind -> Maybe (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 (Coercion
_, Kind
rhs, MCoercion
_) <- FamInstEnvs -> TyCon -> [Kind] -> Maybe (Coercion, Kind, MCoercion)
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.
       = [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

-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that
-- the 'DataCon' may not have existentials. The lack of cloning the existentials
-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";
-- only use it where type variables aren't substituted for!
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
    subst :: TCvSubst
subst    = TCvSubst -> [Id] -> TCvSubst
extendTCvInScopeList ([Id] -> [Kind] -> TCvSubst
HasDebugCallStack => [Id] -> [Kind] -> TCvSubst
zipTvSubst [Id]
univ_tvs [Kind]
tc_args) [Id]
ex_tvs
    arg_tys :: [Kind]
arg_tys  = (Scaled Kind -> Kind) -> [Scaled Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map (HasCallStack => TCvSubst -> Kind -> Kind
TCvSubst -> Kind -> Kind
substTy TCvSubst
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) (DataCon -> [Scaled Kind]
dataConRepArgTys DataCon
dc)

{-
************************************************************************
*                                                                      *
\subsection{CPR stuff}
*                                                                      *
************************************************************************


@mkWWcpr@ takes the worker/wrapper pair produced from the strictness
info and adds in the CPR transformation.  The worker returns an
unboxed tuple containing non-CPR components.  The wrapper takes this
tuple and re-produces the correct structured output.

The non-CPR results appear ordered in the unboxed tuple as if by a
left-to-right traversal of the result structure.
-}

mkWWcpr :: Bool
        -> FamInstEnvs
        -> Type                              -- function body type
        -> Cpr                               -- CPR analysis results
        -> UniqSM (Bool,                     -- Is w/w'ing useful?
                   CoreExpr -> CoreExpr,     -- New wrapper
                   CoreExpr -> CoreExpr,     -- New worker
                   Type)                     -- Type of worker's body

mkWWcpr :: Bool
-> FamInstEnvs
-> Kind
-> Cpr
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWcpr Bool
opt_CprAnal FamInstEnvs
fam_envs Kind
body_ty Cpr
cpr
    -- CPR explicitly turned off (or in -O0)
  | Bool -> Bool
not Bool
opt_CprAnal = (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, Kind
body_ty)
    -- CPR is turned on by default for -O and O2
  | Bool
otherwise
  = case Cpr -> Maybe (Int, [Cpr])
asConCpr Cpr
cpr of
       Maybe (Int, [Cpr])
Nothing      -> (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, Kind
body_ty)  -- No CPR info
       Just (Int
con_tag, [Cpr]
_cprs)
         | Just DataConPatContext
dcpc <- FamInstEnvs -> Int -> Kind -> Maybe DataConPatContext
splitResultType_maybe FamInstEnvs
fam_envs Int
con_tag Kind
body_ty
         -> DataConPatContext
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWcpr_help DataConPatContext
dcpc
         |  Bool
otherwise
         -- See Note [non-algebraic or open body type warning]
         -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
            (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, CoreExpr -> CoreExpr
forall a. a -> a
id, CoreExpr -> CoreExpr
forall a. a -> a
id, Kind
body_ty)

mkWWcpr_help :: DataConPatContext
             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)

mkWWcpr_help :: DataConPatContext
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
mkWWcpr_help (DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc = DataCon
dc, dcpc_tc_args :: DataConPatContext -> [Kind]
dcpc_tc_args = [Kind]
tc_args
                                , dcpc_co :: DataConPatContext -> Coercion
dcpc_co = Coercion
co })
  | [Scaled Kind
arg_ty]   <- DataCon -> [Kind] -> [Scaled Kind]
dataConInstArgTys DataCon
dc [Kind]
tc_args -- NB: No existentials!
  , [StrictnessMark
str_mark] <- DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc
  , HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType (Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing Scaled Kind
arg_ty)
  , Scaled Kind -> Bool
forall a. Scaled a -> Bool
isLinear Scaled Kind
arg_ty
        -- Special case when there is a single result of unlifted, linear, type
        --
        -- Wrapper:     case (..call worker..) of x -> C x
        -- Worker:      case (   ..body..    ) of C x -> x
  = do { (Unique
work_uniq : Unique
arg_uniq : [Unique]
_) <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
       ; let arg_id :: Id
arg_id    = Unique -> StrictnessMark -> Scaled Kind -> Id
mk_ww_local Unique
arg_uniq StrictnessMark
str_mark Scaled Kind
arg_ty
             con_app :: CoreExpr
con_app   = DataCon -> [Kind] -> [Id] -> CoreExpr
forall b. DataCon -> [Kind] -> [Id] -> Expr b
mkConApp2 DataCon
dc [Kind]
tc_args [Id
arg_id] CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co

       ; (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Bool
True
                , \ CoreExpr
wkr_call -> CoreExpr -> Id -> CoreExpr -> CoreExpr
mkDefaultCase CoreExpr
wkr_call Id
arg_id CoreExpr
con_app
                , \ CoreExpr
body     -> CoreExpr
-> Coercion
-> Kind
-> Unique
-> DataCon
-> [Id]
-> CoreExpr
-> CoreExpr
mkUnpackCase CoreExpr
body Coercion
co Kind
One Unique
work_uniq DataCon
dc [Id
arg_id] (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
arg_id)
                                -- varToCoreExpr important here: arg can be a coercion
                                -- Lacking this caused #10658
                , Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing Scaled Kind
arg_ty ) }

  | Bool
otherwise   -- The general case
        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)
        --
        -- Remark on linearity: in both the case of the wrapper and the worker,
        -- we build a linear case. All the multiplicity information is kept in
        -- the constructors (both C and (#, #)). In particular (#,#) is
        -- parametrised 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.
  = do { (Unique
work_uniq : Unique
wild_uniq : [Unique]
pat_bndrs_uniqs) <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
       ; let case_mult :: Kind
case_mult       = Kind
One -- see above
             ([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
case_mult DataCon
dc [Kind]
tc_args
             wrap_wild :: Id
wrap_wild       = Unique -> StrictnessMark -> Scaled Kind -> Id
mk_ww_local Unique
wild_uniq StrictnessMark
MarkedStrict (Kind -> Kind -> Scaled Kind
forall a. Kind -> a -> Scaled a
Scaled Kind
case_mult Kind
ubx_tup_ty)
             ubx_tup_ty :: Kind
ubx_tup_ty      = CoreExpr -> Kind
exprType CoreExpr
ubx_tup_app
             ubx_tup_app :: CoreExpr
ubx_tup_app     = [Kind] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup ((Id -> Kind) -> [Id] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Kind
idType [Id]
arg_ids) ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr [Id]
arg_ids)
             con_app :: CoreExpr
con_app         = DataCon -> [Kind] -> [Id] -> CoreExpr
forall b. DataCon -> [Kind] -> [Id] -> Expr b
mkConApp2 DataCon
dc [Kind]
tc_args [Id]
arg_ids CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co
             tup_con :: DataCon
tup_con         = Boxity -> Int -> DataCon
tupleDataCon Boxity
Unboxed ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
arg_ids)

       ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe

       ; (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
-> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True
                , \ CoreExpr
wkr_call -> CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
wkr_call Id
wrap_wild
                                                (DataCon -> AltCon
DataAlt DataCon
tup_con) [Id]
arg_ids CoreExpr
con_app
                , \ CoreExpr
body     -> CoreExpr
-> Coercion
-> Kind
-> Unique
-> DataCon
-> [Id]
-> CoreExpr
-> CoreExpr
mkUnpackCase CoreExpr
body Coercion
co Kind
case_mult Unique
work_uniq DataCon
dc [Id]
arg_ids CoreExpr
ubx_tup_app
                , Kind
ubx_tup_ty ) }

mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
-- (mkUnpackCase e co uniq Con args body)
--      returns
-- case e |> co of bndr { Con args -> body }

mkUnpackCase :: CoreExpr
-> Coercion
-> Kind
-> Unique
-> DataCon
-> [Id]
-> CoreExpr
-> CoreExpr
mkUnpackCase (Tick CoreTickish
tickish CoreExpr
e) Coercion
co Kind
mult Unique
uniq 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
-> Unique
-> DataCon
-> [Id]
-> CoreExpr
-> CoreExpr
mkUnpackCase CoreExpr
e Coercion
co Kind
mult Unique
uniq DataCon
con [Id]
args CoreExpr
body)
mkUnpackCase CoreExpr
scrut Coercion
co Kind
mult Unique
uniq 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 CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
co
    bndr :: Id
bndr = Unique -> StrictnessMark -> Scaled Kind -> Id
mk_ww_local Unique
uniq StrictnessMark
MarkedStrict (Kind -> Kind -> Scaled Kind
forall a. Kind -> a -> Scaled a
Scaled Kind
mult (CoreExpr -> Kind
exprType CoreExpr
casted_scrut))
      -- An unpacking case can always be chosen linear, because the variables
      -- are always passed to a constructor. This limits the
{-
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'easily W/W constructed results like `Stream` because we have no simple
way to express existential types in the worker's type signature.

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.


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

Note [Absent errors]
~~~~~~~~~~~~~~~~~~~~
Consider
  data T = MkT [Int] [Int] ![Int]
  f :: T -> Int# -> blah
  f ps w = case ps of MkT xs _ _ -> <body mentioning xs>
Then f gets a strictness sig of <S(L,A,A)><A>. We make worker $wf thus:

$wf :: [Int] -> blah
$wf xs = case ps of MkT xs _ _ -> <body mentioning xs>
  where
    ys = absentError "ys :: [Int]"
    zs = LitRubbish True
    ps = MkT xs ys zs
    w  = 0#

We make a let-binding for Absent arguments, such as ys and w, that are not even
passed to the worker. They should, of course, never be used. We distinguish four
cases:

1. Ordinary boxed, lifted arguments, like 'ys' We make a new binding for Ids
   that are marked absent, thus
      let ys = absentError "ys :: [Int]"
   The idea is that this binding will never be used; but if it
   buggily is used we'll get a runtime error message.

2. Boxed, lifted types, with a strict demand, like 'zs'.  You may ask: how the
   demand be both absent and strict?  That's exactly what happens for 'zs': it
   is not used, so its demand is Absent, but then during w/w, in
   addDataConStrictness, we strictify the demand.  So it gets cardinality C_10,
   the empty interval.

   We don't want to use an error-thunk for 'zs' because MkT's third argument has
   a bang, and hence should be always evaluated. This turned out to be
   important when fixing #16970, which establishes the invariant that strict
   constructor arguments are always evaluated. So we use LitRubbish instead
   of an error thunk -- see #19133.

   These first two cases are distinguished by isStrictDmd in lifted_rhs.

3. Unboxed types, like 'w', with a type like Float#, Int#. Coping with absence
   for unboxed types is important; see, for example, #4306 and #15627.  We
   simply find a suitable literal, using Literal.absentLiteralOf.  We don't have
   literals for every primitive type, so the function is partial.

4. Boxed, unlifted types, like (Array# t).  We can't use absentError because
   unlifted bindings ares strict.  So we use LitRubbish, which we need to apply
   to the required type.

Case (2) and (4) crucially use LitRubbish as the placeholder: see Note [Rubbish
literals] in GHC.Types.Literal.  We could do that in case (1) as well, but we
get slightly better self-checking with an error thunk.

Suppose we use LitRubbish and absence analysis is Wrong, so that the "absent"
value is used after all.  Then in case (2) we could get a seg-fault, because we
may have replaced, say, a [Either Int Bool] by (), and that will fail if we do
case analysis on it.  Similarly with boxed unlifted types, case (4).

In case (3), if absence analysis is wrong we could conceivably get an exception,
from a divide-by-zero with the absent value.  But it's very unlikely.

Only in case (1) can we guarantee a civilised runtime error.  Not much we can do
about this; we really rely on absence analysis to be correct.


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!
-}

-- | Tries to find a suitable dummy RHS to bind the given absent identifier to.
--
-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding
-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be
-- found (currently only happens for bindings of 'VecRep' representation).
mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let :: DynFlags
-> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)
mk_absent_let DynFlags
dflags FamInstEnvs
fam_envs Id
arg Demand
dmd

  -- The lifted case: Bind 'absentError'
  -- See Note [Absent errors]
  | Bool -> Bool
not (HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
arg_ty)
  = (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
lifted_arg CoreExpr
lifted_rhs))
  -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@
  -- See Note [Absent errors]

  | [PrimRep
UnliftedRep] <- HasDebugCallStack => Kind -> [PrimRep]
Kind -> [PrimRep]
typePrimRep Kind
arg_ty
  = (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg CoreExpr
unlifted_rhs))

  -- The monomorphic unlifted cases: Bind to some literal, if possible
  -- See Note [Absent errors]
  | Just TyCon
tc <- Kind -> Maybe TyCon
tyConAppTyCon_maybe Kind
nty
  , Just Literal
lit <- TyCon -> Maybe Literal
absentLiteralOf TyCon
tc
  = (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co)))

  | Kind
nty Kind -> Kind -> Bool
`eqType` Kind
unboxedUnitTy
  = (CoreExpr -> CoreExpr) -> Maybe (CoreExpr -> CoreExpr)
forall a. a -> Maybe a
Just (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
arg (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
voidPrimId CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion -> Coercion
mkSymCo Coercion
co)))

  | Bool
otherwise
  = WARN( True, text "No absent value for" <+> ppr arg_ty )
    Maybe (CoreExpr -> CoreExpr)
forall a. Maybe a
Nothing -- Can happen for 'State#' and things of 'VecRep'
  where
    lifted_arg :: Id
lifted_arg   = Id
arg Id -> StrictSig -> Id
`setIdStrictness` StrictSig
botSig Id -> CprSig -> Id
`setIdCprInfo` Int -> Cpr -> CprSig
mkCprSig Int
0 Cpr
botCpr
              -- Note in strictness signature that this is bottoming
              -- (for the sake of the "empty case scrutinee not known to
              -- diverge for sure lint" warning)

    lifted_rhs :: CoreExpr
lifted_rhs | Demand -> Bool
isStrictDmd Demand
dmd = CoreExpr -> [Kind] -> CoreExpr
forall b. Expr b -> [Kind] -> Expr b
mkTyApps (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Bool -> Literal
rubbishLit Bool
True))  [Kind
arg_ty]
               | Bool
otherwise       = Kind -> String -> CoreExpr
mkAbsentErrorApp Kind
arg_ty String
msg
    unlifted_rhs :: CoreExpr
unlifted_rhs = CoreExpr -> [Kind] -> CoreExpr
forall b. Expr b -> [Kind] -> Expr b
mkTyApps (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Bool -> Literal
rubbishLit Bool
False)) [Kind
arg_ty]

    arg_ty :: Kind
arg_ty       = Id -> Kind
idType Id
arg

    -- Normalise the type to have best chance of finding an absent literal
    -- e.g. (#17852)   data unlifted N = MkN Int#
    --                 f :: N -> a -> a
    --                 f _ x = x
    (Coercion
co, Kind
nty)    = FamInstEnvs -> Kind -> Maybe (Coercion, Kind)
topNormaliseType_maybe FamInstEnvs
fam_envs Kind
arg_ty
                   Maybe (Coercion, Kind) -> (Coercion, Kind) -> (Coercion, Kind)
forall a. Maybe a -> a -> a
`orElse` (Kind -> Coercion
mkRepReflCo Kind
arg_ty, Kind
arg_ty)

    msg :: String
msg          = DynFlags -> SDoc -> String
showSDoc (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_SuppressUniques)
                            ([SDoc] -> SDoc
vcat
                              [ String -> SDoc
text String
"Arg:" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
arg
                              , String -> SDoc
text String
"Type:" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
arg_ty
                              , SDoc
file_msg
                              ])
    file_msg :: SDoc
file_msg     = case DynFlags -> Maybe String
outputFile DynFlags
dflags of
                     Maybe String
Nothing -> SDoc
empty
                     Just String
f  -> String -> SDoc
text String
"In output file " SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
f)
              -- 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

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

mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id
-- The StrictnessMark comes form the data constructor and says
-- whether this field is strict
-- See Note [Record evaluated-ness in worker/wrapper]
mk_ww_local :: Unique -> StrictnessMark -> Scaled Kind -> Id
mk_ww_local Unique
uniq StrictnessMark
str (Scaled Kind
w Kind
ty)
  = StrictnessMark -> Id -> Id
setCaseBndrEvald StrictnessMark
str (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
    FastString -> Unique -> Kind -> Kind -> Id
mkSysLocalOrCoVar FastString
ww_prefix Unique
uniq Kind
w Kind
ty