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


                        -----------------
                        A demand analysis
                        -----------------
-}


module GHC.Core.Opt.DmdAnal
   ( DmdAnalOpts(..)
   , dmdAnalProgram
   )
where

import GHC.Prelude

import GHC.Core.Opt.WorkWrap.Utils
import GHC.Types.Demand   -- All of it
import GHC.Core
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Utils.Outputable
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Basic
import Data.List        ( mapAccumL )
import GHC.Core.DataCon
import GHC.Types.ForeignCall ( isSafeForeignCall )
import GHC.Types.Id
import GHC.Core.Utils
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Predicate ( isClassPred )
import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
import GHC.Core.Coercion ( Coercion )
import GHC.Core.TyCo.FVs ( coVarsOfCos )
import GHC.Core.FamInstEnv
import GHC.Core.Opt.Arity ( typeArity )
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.Maybe
import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Types.Unique.Set
import GHC.Types.Unique.MemoFun

import GHC.Utils.Trace
String -> SDoc -> Any -> Any
_ = String -> SDoc -> Any -> Any
forall a. String -> SDoc -> a -> a
pprTrace -- Tired of commenting out the import all the time

{-
************************************************************************
*                                                                      *
\subsection{Top level stuff}
*                                                                      *
************************************************************************
-}

-- | Options for the demand analysis
data DmdAnalOpts = DmdAnalOpts
   { DmdAnalOpts -> Bool
dmd_strict_dicts    :: !Bool -- ^ Use strict dictionaries
   , DmdAnalOpts -> Arity
dmd_unbox_width     :: !Int  -- ^ Use strict dictionaries
   , DmdAnalOpts -> Arity
dmd_max_worker_args :: !Int
   }

-- This is a strict alternative to (,)
-- See Note [Space Leaks in Demand Analysis]
data WithDmdType a = WithDmdType !DmdType !a

getAnnotated :: WithDmdType a -> a
getAnnotated :: forall a. WithDmdType a -> a
getAnnotated (WithDmdType DmdType
_ a
a) = a
a

data DmdResult a b = R !a !b

-- | Outputs a new copy of the Core program in which binders have been annotated
-- with demand and strictness information.
--
-- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note
-- [Stamp out space leaks in demand analysis])
dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
dmdAnalProgram :: DmdAnalOpts
-> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
dmdAnalProgram DmdAnalOpts
opts FamInstEnvs
fam_envs [CoreRule]
rules CoreProgram
binds
  = WithDmdType CoreProgram -> CoreProgram
forall a. WithDmdType a -> a
getAnnotated (WithDmdType CoreProgram -> CoreProgram)
-> WithDmdType CoreProgram -> CoreProgram
forall a b. (a -> b) -> a -> b
$ AnalEnv -> CoreProgram -> WithDmdType CoreProgram
go (DmdAnalOpts -> FamInstEnvs -> AnalEnv
emptyAnalEnv DmdAnalOpts
opts FamInstEnvs
fam_envs) CoreProgram
binds
  where
    -- See Note [Analysing top-level bindings]
    -- and Note [Why care for top-level demand annotations?]
    go :: AnalEnv -> CoreProgram -> WithDmdType CoreProgram
go AnalEnv
_   []     = DmdType -> CoreProgram -> WithDmdType CoreProgram
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
nopDmdType []
    go AnalEnv
env (Bind Var
b:CoreProgram
bs) = WithDmdType (DmdResult (Bind Var) CoreProgram)
-> WithDmdType CoreProgram
forall b. WithDmdType (DmdResult b [b]) -> WithDmdType [b]
cons_up (WithDmdType (DmdResult (Bind Var) CoreProgram)
 -> WithDmdType CoreProgram)
-> WithDmdType (DmdResult (Bind Var) CoreProgram)
-> WithDmdType CoreProgram
forall a b. (a -> b) -> a -> b
$ TopLevelFlag
-> AnalEnv
-> SubDemand
-> Bind Var
-> (AnalEnv -> WithDmdType CoreProgram)
-> WithDmdType (DmdResult (Bind Var) CoreProgram)
forall a.
TopLevelFlag
-> AnalEnv
-> SubDemand
-> Bind Var
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
dmdAnalBind TopLevelFlag
TopLevel AnalEnv
env SubDemand
topSubDmd Bind Var
b AnalEnv -> WithDmdType CoreProgram
anal_body
      where
        anal_body :: AnalEnv -> WithDmdType CoreProgram
anal_body AnalEnv
env'
          | WithDmdType DmdType
body_ty CoreProgram
bs' <- AnalEnv -> CoreProgram -> WithDmdType CoreProgram
go AnalEnv
env' CoreProgram
bs
          = DmdType -> CoreProgram -> WithDmdType CoreProgram
forall a. DmdType -> a -> WithDmdType a
WithDmdType (DmdType
body_ty DmdType -> DmdEnv -> DmdType
`plusDmdType` AnalEnv -> [Var] -> DmdEnv
keep_alive_roots AnalEnv
env' (Bind Var -> [Var]
forall b. Bind b -> [b]
bindersOf Bind Var
b)) CoreProgram
bs'

    cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]
    cons_up :: forall b. WithDmdType (DmdResult b [b]) -> WithDmdType [b]
cons_up (WithDmdType DmdType
dmd_ty (R b
b' [b]
bs')) = DmdType -> [b] -> WithDmdType [b]
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
dmd_ty (b
b' b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
bs')

    keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv
    -- See Note [Absence analysis for stable unfoldings and RULES]
    -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in
    -- orphan RULES
    keep_alive_roots :: AnalEnv -> [Var] -> DmdEnv
keep_alive_roots AnalEnv
env [Var]
ids = [DmdEnv] -> DmdEnv
plusDmdEnvs ((Var -> DmdEnv) -> [Var] -> [DmdEnv]
forall a b. (a -> b) -> [a] -> [b]
map (AnalEnv -> Var -> DmdEnv
demandRoot AnalEnv
env) ((Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
is_root [Var]
ids))

    is_root :: Id -> Bool
    is_root :: Var -> Bool
is_root Var
id = Var -> Bool
isExportedId Var
id Bool -> Bool -> Bool
|| Var -> VarSet -> Bool
elemVarSet Var
id VarSet
rule_fvs

    rule_fvs :: IdSet
    rule_fvs :: VarSet
rule_fvs = [CoreRule] -> VarSet
rulesRhsFreeIds [CoreRule]
rules

demandRoot :: AnalEnv -> Id -> DmdEnv
-- See Note [Absence analysis for stable unfoldings and RULES]
demandRoot :: AnalEnv -> Var -> DmdEnv
demandRoot AnalEnv
env Var
id = (DmdEnv, CoreExpr) -> DmdEnv
forall a b. (a, b) -> a
fst (AnalEnv -> Demand -> CoreExpr -> (DmdEnv, CoreExpr)
dmdAnalStar AnalEnv
env Demand
topDmd (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
id))

demandRoots :: AnalEnv -> [Id] -> DmdEnv
-- See Note [Absence analysis for stable unfoldings and RULES]
demandRoots :: AnalEnv -> [Var] -> DmdEnv
demandRoots AnalEnv
env [Var]
roots = [DmdEnv] -> DmdEnv
plusDmdEnvs ((Var -> DmdEnv) -> [Var] -> [DmdEnv]
forall a b. (a -> b) -> [a] -> [b]
map (AnalEnv -> Var -> DmdEnv
demandRoot AnalEnv
env) [Var]
roots)

demandRootSet :: AnalEnv -> IdSet -> DmdEnv
demandRootSet :: AnalEnv -> VarSet -> DmdEnv
demandRootSet AnalEnv
env VarSet
ids = AnalEnv -> [Var] -> DmdEnv
demandRoots AnalEnv
env (VarSet -> [Var]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet VarSet
ids)
  -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative

-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings
-- that satisfy this function.
--
-- Basically, we want to know how top-level *functions* are *used*
-- (e.g. called). The information will always be lazy.
-- Any other top-level bindings are boring.
--
-- See also Note [Why care for top-level demand annotations?].
isInterestingTopLevelFn :: Id -> Bool
-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642
-- (which is dominated by the Simplifier) at no gain in analysis precision.
-- If there was a gain, that regression might be acceptable.
-- Plus, we could use LetUp for thunks and share some code with local let
-- bindings.
isInterestingTopLevelFn :: Var -> Bool
isInterestingTopLevelFn Var
id =
  Type -> [OneShotInfo]
typeArity (Var -> Type
idType Var
id) [OneShotInfo] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthExceeds` Arity
0

{- Note [Stamp out space leaks in demand analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The demand analysis pass outputs a new copy of the Core program in
which binders have been annotated with demand and strictness
information. It's tiresome to ensure that this information is fully
evaluated everywhere that we produce it, so we just run a single
seqBinds over the output before returning it, to ensure that there are
no references holding on to the input Core program.

This makes a ~30% reduction in peak memory usage when compiling
DynFlags (cf #9675 and #13426).

This is particularly important when we are doing late demand analysis,
since we don't do a seqBinds at any point thereafter. Hence code
generation would hold on to an extra copy of the Core program, via
unforced thunks in demand or strictness information; and it is the
most memory-intensive part of the compilation process, so this added
seqBinds makes a big difference in peak memory usage.

Note [Analysing top-level bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a CoreProgram like
  e1 = ...
  n1 = ...
  e2 = \a b -> ... fst (n1 a b) ...
  n2 = \c d -> ... snd (e2 c d) ...
  ...
where e* are exported, but n* are not.
Intuitively, we can see that @n1@ is only ever called with two arguments
and in every call site, the first component of the result of the call
is evaluated. Thus, we'd like it to have idDemandInfo @LCL(CM(P(1L,A))@.
NB: We may *not* give e2 a similar annotation, because it is exported and
external callers might use it in arbitrary ways, expressed by 'topDmd'.
This can then be exploited by Nested CPR and eta-expansion,
see Note [Why care for top-level demand annotations?].

How do we get this result? Answer: By analysing the program as if it was a let
expression of this form:
  let e1 = ... in
  let n1 = ... in
  let e2 = ... in
  let n2 = ... in
  (e1,e2, ...)
E.g. putting all bindings in nested lets and returning all exported binders in a tuple.
Of course, we will not actually build that CoreExpr! Instead we faithfully
simulate analysis of said expression by adding the free variable 'DmdEnv'
of @e*@'s strictness signatures to the 'DmdType' we get from analysing the
nested bindings.

And even then the above form blows up analysis performance in T10370:
If @e1@ uses many free variables, we'll unnecessarily carry their demands around
with us from the moment we analyse the pair to the moment we bubble back up to
the binding for @e1@. So instead we analyse as if we had
  let e1 = ... in
  (e1, let n1 = ... in
  (    let e2 = ... in
  (e2, let n2 = ... in
  (    ...))))
That is, a series of right-nested pairs, where the @fst@ are the exported
binders of the last enclosing let binding and @snd@ continues the nested
lets.

Variables occurring free in RULE RHSs are to be handled the same as exported Ids.
See also Note [Absence analysis for stable unfoldings and RULES].

Note [Why care for top-level demand annotations?]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Reading Note [Analysing top-level bindings], you might think that we go through
quite some trouble to get useful demands for top-level bindings. They can never
be strict, for example, so why bother?

First, we get to eta-expand top-level bindings that we weren't able to
eta-expand before without Call Arity. From T18894b:
  module T18894b (f) where
  eta :: Int -> Int -> Int
  eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ...
  f m = ... eta m 2 ... eta 2 m ...
Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to
arity 2.

The call demands we get for some top-level bindings will also allow Nested CPR
to unbox deeper. From T18894:
  module T18894 (h) where
  g m n = (2 * m, 2 `div` n)
  {-# NOINLINE g #-}
  h :: Int -> Int
  h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ...
Only @h@ is exported, hence we see that @g@ is always called in contexts were we
also force the division in the second component of the pair returned by @g@.
This allows Nested CPR to evaluate the division eagerly and return an I# in its
position.
-}

{-
************************************************************************
*                                                                      *
\subsection{The analyser itself}
*                                                                      *
************************************************************************
-}

-- | Analyse a binding group and its \"body\", e.g. where it is in scope.
--
-- It calls a function that knows how to analyse this \"body\" given
-- an 'AnalEnv' with updated demand signatures for the binding group
-- (reflecting their 'idDmdSigInfo') and expects to receive a
-- 'DmdType' in return, which it uses to annotate the binding group with their
-- 'idDemandInfo'.
dmdAnalBind
  :: TopLevelFlag
  -> AnalEnv
  -> SubDemand                 -- ^ Demand put on the "body"
                               --   (important for join points)
  -> CoreBind
  -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g.
                               --   where the binding is in scope
  -> WithDmdType (DmdResult CoreBind a)
dmdAnalBind :: forall a.
TopLevelFlag
-> AnalEnv
-> SubDemand
-> Bind Var
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
dmdAnalBind TopLevelFlag
top_lvl AnalEnv
env SubDemand
dmd Bind Var
bind AnalEnv -> WithDmdType a
anal_body = case Bind Var
bind of
  NonRec Var
id CoreExpr
rhs
    | TopLevelFlag -> Var -> Bool
useLetUp TopLevelFlag
top_lvl Var
id
    -> TopLevelFlag
-> AnalEnv
-> Var
-> CoreExpr
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
forall a.
TopLevelFlag
-> AnalEnv
-> Var
-> CoreExpr
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
dmdAnalBindLetUp   TopLevelFlag
top_lvl AnalEnv
env_rhs     Var
id CoreExpr
rhs AnalEnv -> WithDmdType a
anal_body
  Bind Var
_ -> TopLevelFlag
-> AnalEnv
-> SubDemand
-> Bind Var
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
forall a.
TopLevelFlag
-> AnalEnv
-> SubDemand
-> Bind Var
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
dmdAnalBindLetDown TopLevelFlag
top_lvl AnalEnv
env_rhs SubDemand
dmd Bind Var
bind   AnalEnv -> WithDmdType a
anal_body
  where
    env_rhs :: AnalEnv
env_rhs = Bind Var -> AnalEnv -> AnalEnv
enterDFun Bind Var
bind AnalEnv
env

-- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')
-- with 'topDmd', the rest with the given demand.
setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id
setBindIdDemandInfo :: TopLevelFlag -> Var -> Demand -> Var
setBindIdDemandInfo TopLevelFlag
top_lvl Var
id Demand
dmd = Var -> Demand -> Var
setIdDemandInfo Var
id (Demand -> Var) -> Demand -> Var
forall a b. (a -> b) -> a -> b
$ case TopLevelFlag
top_lvl of
  TopLevelFlag
TopLevel | Bool -> Bool
not (Var -> Bool
isInterestingTopLevelFn Var
id) -> Demand
topDmd
  TopLevelFlag
_                                           -> Demand
dmd

-- | Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
-- This function handles the up variant.
--
-- It is very simple. For  let x = rhs in body
--   * Demand-analyse 'body' in the current environment
--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
--   * Demand-analyse 'rhs' in 'rhs_dmd'
--
-- This is used for a non-recursive local let without manifest lambdas (see
-- 'useLetUp').
--
-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnalBindLetUp :: TopLevelFlag
                 -> AnalEnv
                 -> Id
                 -> CoreExpr
                 -> (AnalEnv -> WithDmdType a)
                 -> WithDmdType (DmdResult CoreBind a)
dmdAnalBindLetUp :: forall a.
TopLevelFlag
-> AnalEnv
-> Var
-> CoreExpr
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
dmdAnalBindLetUp TopLevelFlag
top_lvl AnalEnv
env Var
id CoreExpr
rhs AnalEnv -> WithDmdType a
anal_body = DmdType
-> DmdResult (Bind Var) a -> WithDmdType (DmdResult (Bind Var) a)
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
final_ty (Bind Var -> a -> DmdResult (Bind Var) a
forall a b. a -> b -> DmdResult a b
R (Var -> CoreExpr -> Bind Var
forall b. b -> Expr b -> Bind b
NonRec Var
id' CoreExpr
rhs') (a
body'))
  where
    WithDmdType DmdType
body_ty a
body'   = AnalEnv -> WithDmdType a
anal_body (AnalEnv -> Var -> AnalEnv
addInScopeAnalEnv AnalEnv
env Var
id)
    -- See Note [Bringing a new variable into scope]
    WithDmdType DmdType
body_ty' Demand
id_dmd = AnalEnv -> DmdType -> Var -> WithDmdType Demand
findBndrDmd AnalEnv
env DmdType
body_ty Var
id
    -- See Note [Finalising boxity for demand signatures]

    id_dmd' :: Demand
id_dmd'            = FamInstEnvs -> Type -> Demand -> Demand
finaliseLetBoxity (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) (Var -> Type
idType Var
id) Demand
id_dmd
    !id' :: Var
id'               = TopLevelFlag -> Var -> Demand -> Var
setBindIdDemandInfo TopLevelFlag
top_lvl Var
id Demand
id_dmd'
    (DmdEnv
rhs_ty, CoreExpr
rhs')     = AnalEnv -> Demand -> CoreExpr -> (DmdEnv, CoreExpr)
dmdAnalStar AnalEnv
env (CoreExpr -> Demand -> Demand
dmdTransformThunkDmd CoreExpr
rhs Demand
id_dmd') CoreExpr
rhs

    -- See Note [Absence analysis for stable unfoldings and RULES]
    rule_fvs :: VarSet
rule_fvs           = Var -> VarSet
bndrRuleAndUnfoldingIds Var
id
    final_ty :: DmdType
final_ty           = DmdType
body_ty' DmdType -> DmdEnv -> DmdType
`plusDmdType` DmdEnv
rhs_ty DmdType -> DmdEnv -> DmdType
`plusDmdType` AnalEnv -> VarSet -> DmdEnv
demandRootSet AnalEnv
env VarSet
rule_fvs

-- | Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
-- This function handles the down variant.
--
-- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses
-- that at call sites in the body.
--
-- It is used for toplevel definitions, recursive definitions and local
-- non-recursive definitions that have manifest lambdas (cf. 'useLetUp').
-- Local non-recursive definitions without a lambda are handled with LetUp.
--
-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a)
dmdAnalBindLetDown :: forall a.
TopLevelFlag
-> AnalEnv
-> SubDemand
-> Bind Var
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
dmdAnalBindLetDown TopLevelFlag
top_lvl AnalEnv
env SubDemand
dmd Bind Var
bind AnalEnv -> WithDmdType a
anal_body = case Bind Var
bind of
  NonRec Var
id CoreExpr
rhs
    | (AnalEnv
env', WeakDmds
weak_fv, Var
id1, CoreExpr
rhs1) <-
        TopLevelFlag
-> RecFlag
-> AnalEnv
-> SubDemand
-> Var
-> CoreExpr
-> (AnalEnv, WeakDmds, Var, CoreExpr)
dmdAnalRhsSig TopLevelFlag
top_lvl RecFlag
NonRecursive AnalEnv
env SubDemand
dmd Var
id CoreExpr
rhs
    -> AnalEnv
-> WeakDmds
-> [(Var, CoreExpr)]
-> ([(Var, CoreExpr)] -> Bind Var)
-> WithDmdType (DmdResult (Bind Var) a)
do_rest AnalEnv
env' WeakDmds
weak_fv [(Var
id1, CoreExpr
rhs1)] ((Var -> CoreExpr -> Bind Var) -> (Var, CoreExpr) -> Bind Var
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Var -> CoreExpr -> Bind Var
forall b. b -> Expr b -> Bind b
NonRec ((Var, CoreExpr) -> Bind Var)
-> ([(Var, CoreExpr)] -> (Var, CoreExpr))
-> [(Var, CoreExpr)]
-> Bind Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Var, CoreExpr)] -> (Var, CoreExpr)
forall a. [a] -> a
only)
  Rec [(Var, CoreExpr)]
pairs
    | (AnalEnv
env', WeakDmds
weak_fv, [(Var, CoreExpr)]
pairs') <- TopLevelFlag
-> AnalEnv
-> SubDemand
-> [(Var, CoreExpr)]
-> (AnalEnv, WeakDmds, [(Var, CoreExpr)])
dmdFix TopLevelFlag
top_lvl AnalEnv
env SubDemand
dmd [(Var, CoreExpr)]
pairs
    -> AnalEnv
-> WeakDmds
-> [(Var, CoreExpr)]
-> ([(Var, CoreExpr)] -> Bind Var)
-> WithDmdType (DmdResult (Bind Var) a)
do_rest AnalEnv
env' WeakDmds
weak_fv [(Var, CoreExpr)]
pairs' [(Var, CoreExpr)] -> Bind Var
forall b. [(b, Expr b)] -> Bind b
Rec
  where
    do_rest :: AnalEnv
-> WeakDmds
-> [(Var, CoreExpr)]
-> ([(Var, CoreExpr)] -> Bind Var)
-> WithDmdType (DmdResult (Bind Var) a)
do_rest AnalEnv
env' WeakDmds
weak_fv [(Var, CoreExpr)]
pairs1 [(Var, CoreExpr)] -> Bind Var
build_bind = DmdType
-> DmdResult (Bind Var) a -> WithDmdType (DmdResult (Bind Var) a)
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
final_ty (Bind Var -> a -> DmdResult (Bind Var) a
forall a b. a -> b -> DmdResult a b
R ([(Var, CoreExpr)] -> Bind Var
build_bind [(Var, CoreExpr)]
pairs2) a
body')
      where
        WithDmdType DmdType
body_ty a
body'        = AnalEnv -> WithDmdType a
anal_body AnalEnv
env'
        -- see Note [Lazy and unleashable free variables]
        dmd_ty :: DmdType
dmd_ty                          = DmdType -> WeakDmds -> DmdType
addWeakFVs DmdType
body_ty WeakDmds
weak_fv
        WithDmdType DmdType
final_ty [Demand]
id_dmds    = AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
findBndrsDmds AnalEnv
env' DmdType
dmd_ty (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
strictMap (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
pairs1)
        -- Important to force this as build_bind might not force it.
        !pairs2 :: [(Var, CoreExpr)]
pairs2                         = ((Var, CoreExpr) -> Demand -> (Var, CoreExpr))
-> [(Var, CoreExpr)] -> [Demand] -> [(Var, CoreExpr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
strictZipWith (Var, CoreExpr) -> Demand -> (Var, CoreExpr)
do_one [(Var, CoreExpr)]
pairs1 [Demand]
id_dmds
        do_one :: (Var, CoreExpr) -> Demand -> (Var, CoreExpr)
do_one (Var
id', CoreExpr
rhs') Demand
dmd          = ((,) (Var -> CoreExpr -> (Var, CoreExpr))
-> Var -> CoreExpr -> (Var, CoreExpr)
forall a b. (a -> b) -> a -> b
$! TopLevelFlag -> Var -> Demand -> Var
setBindIdDemandInfo TopLevelFlag
top_lvl Var
id' Demand
dmd) (CoreExpr -> (Var, CoreExpr)) -> CoreExpr -> (Var, CoreExpr)
forall a b. (a -> b) -> a -> b
$! CoreExpr
rhs'
        -- If the actual demand is better than the vanilla call
        -- demand, you might think that we might do better to re-analyse
        -- the RHS with the stronger demand.
        -- But (a) That seldom happens, because it means that *every* path in
        --         the body of the let has to use that stronger demand
        -- (b) It often happens temporarily in when fixpointing, because
        --     the recursive function at first seems to place a massive demand.
        --     But we don't want to go to extra work when the function will
        --     probably iterate to something less demanding.
        -- In practice, all the times the actual demand on id2 is more than
        -- the vanilla call demand seem to be due to (b).  So we don't
        -- bother to re-analyse the RHS.

-- If e is complicated enough to become a thunk, its contents will be evaluated
-- at most once, so oneify it.
dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
dmdTransformThunkDmd CoreExpr
e
  | CoreExpr -> Bool
exprIsTrivial CoreExpr
e = Demand -> Demand
forall a. a -> a
id
  | Bool
otherwise       = Demand -> Demand
oneifyDmd

-- Do not process absent demands
-- Otherwise act like in a normal demand analysis
-- See ↦* relation in the Cardinality Analysis paper
dmdAnalStar :: AnalEnv
            -> Demand   -- This one takes a *Demand*
            -> CoreExpr
            -> (DmdEnv, CoreExpr)
dmdAnalStar :: AnalEnv -> Demand -> CoreExpr -> (DmdEnv, CoreExpr)
dmdAnalStar AnalEnv
env (Card
n :* SubDemand
sd) CoreExpr
e
  -- NB: (:*) expands AbsDmd and BotDmd as needed
  -- See Note [Analysing with absent demand]
  | WithDmdType DmdType
dmd_ty CoreExpr
e' <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
sd CoreExpr
e
  = Bool -> SDoc -> (DmdEnv, CoreExpr) -> (DmdEnv, CoreExpr)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Type -> Bool
mightBeLiftedType ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e) Bool -> Bool -> Bool
|| CoreExpr -> Bool
exprOkForSpeculation CoreExpr
e) (CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)
    -- The argument 'e' should satisfy the let/app invariant
    (DmdType -> DmdEnv
discardArgDmds (DmdType -> DmdEnv) -> DmdType -> DmdEnv
forall a b. (a -> b) -> a -> b
$ Card -> DmdType -> DmdType
multDmdType Card
n DmdType
dmd_ty, CoreExpr
e')

-- Main Demand Analsysis machinery
dmdAnal, dmdAnal' :: AnalEnv
        -> SubDemand         -- The main one takes a *SubDemand*
        -> CoreExpr -> WithDmdType CoreExpr

dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
d CoreExpr
e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
                  AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal' AnalEnv
env SubDemand
d CoreExpr
e

dmdAnal' :: AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal' AnalEnv
_ SubDemand
_ (Lit Literal
lit)     = DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
nopDmdType (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit Literal
lit)
dmdAnal' AnalEnv
_ SubDemand
_ (Type Type
ty)     = DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
nopDmdType (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty) -- Doesn't happen, in fact
dmdAnal' AnalEnv
_ SubDemand
_ (Coercion Coercion
co)
  = DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType (DmdEnv -> DmdType
noArgsDmdType (Coercion -> DmdEnv
coercionDmdEnv Coercion
co)) (Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co)

dmdAnal' AnalEnv
env SubDemand
dmd (Var Var
var)
  = DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType (AnalEnv -> Var -> SubDemand -> DmdType
dmdTransform AnalEnv
env Var
var SubDemand
dmd) (Var -> CoreExpr
forall b. Var -> Expr b
Var Var
var)

dmdAnal' AnalEnv
env SubDemand
dmd (Cast CoreExpr
e Coercion
co)
  = DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType (DmdType
dmd_ty DmdType -> DmdEnv -> DmdType
`plusDmdType` Coercion -> DmdEnv
coercionDmdEnv Coercion
co) (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e' Coercion
co)
  where
    WithDmdType DmdType
dmd_ty CoreExpr
e' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
dmd CoreExpr
e

dmdAnal' AnalEnv
env SubDemand
dmd (Tick CoreTickish
t CoreExpr
e)
  = DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
dmd_ty (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t CoreExpr
e')
  where
    WithDmdType DmdType
dmd_ty CoreExpr
e' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
dmd CoreExpr
e

dmdAnal' AnalEnv
env SubDemand
dmd (App CoreExpr
fun (Type Type
ty))
  = DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
fun_ty (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty))
  where
    WithDmdType DmdType
fun_ty CoreExpr
fun' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
dmd CoreExpr
fun

-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
dmdAnal' AnalEnv
env SubDemand
dmd (App CoreExpr
fun CoreExpr
arg)
  = -- This case handles value arguments (type args handled above)
    -- Crucially, coercions /are/ handled here, because they are
    -- value arguments (#10288)
    let
        call_dmd :: SubDemand
call_dmd          = SubDemand -> SubDemand
mkCalledOnceDmd SubDemand
dmd
        WithDmdType DmdType
fun_ty CoreExpr
fun' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
call_dmd CoreExpr
fun
        (Demand
arg_dmd, DmdType
res_ty) = DmdType -> (Demand, DmdType)
splitDmdTy DmdType
fun_ty
        (DmdEnv
arg_ty, CoreExpr
arg')    = AnalEnv -> Demand -> CoreExpr -> (DmdEnv, CoreExpr)
dmdAnalStar AnalEnv
env (CoreExpr -> Demand -> Demand
dmdTransformThunkDmd CoreExpr
arg Demand
arg_dmd) CoreExpr
arg
    in
--    pprTrace "dmdAnal:app" (vcat
--         [ text "dmd =" <+> ppr dmd
--         , text "expr =" <+> ppr (App fun arg)
--         , text "fun dmd_ty =" <+> ppr fun_ty
--         , text "arg dmd =" <+> ppr arg_dmd
--         , text "arg dmd_ty =" <+> ppr arg_ty
--         , text "res dmd_ty =" <+> ppr res_ty
--         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
    DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType (DmdType
res_ty DmdType -> DmdEnv -> DmdType
`plusDmdType` DmdEnv
arg_ty) (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' CoreExpr
arg')

dmdAnal' AnalEnv
env SubDemand
dmd (Lam Var
var CoreExpr
body)
  | Var -> Bool
isTyVar Var
var
  = let
        WithDmdType DmdType
body_ty CoreExpr
body' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal (AnalEnv -> Var -> AnalEnv
addInScopeAnalEnv AnalEnv
env Var
var) SubDemand
dmd CoreExpr
body
        -- See Note [Bringing a new variable into scope]
    in
    DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
body_ty (Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
var CoreExpr
body')

  | Bool
otherwise
  = let (Card
n, SubDemand
body_dmd)    = SubDemand -> (Card, SubDemand)
peelCallDmd SubDemand
dmd
          -- body_dmd: a demand to analyze the body

        WithDmdType DmdType
body_ty CoreExpr
body' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal (AnalEnv -> Var -> AnalEnv
addInScopeAnalEnv AnalEnv
env Var
var) SubDemand
body_dmd CoreExpr
body
        -- See Note [Bringing a new variable into scope]
        WithDmdType DmdType
lam_ty Var
var'   = AnalEnv -> DmdType -> Var -> WithDmdType Var
annotateLamIdBndr AnalEnv
env DmdType
body_ty Var
var
        new_dmd_type :: DmdType
new_dmd_type = Card -> DmdType -> DmdType
multDmdType Card
n DmdType
lam_ty
    in
    DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
new_dmd_type (Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
var' CoreExpr
body')

dmdAnal' AnalEnv
env SubDemand
dmd (Case CoreExpr
scrut Var
case_bndr Type
ty [Alt AltCon
alt [Var]
bndrs CoreExpr
rhs])
  -- Only one alternative.
  -- If it's a DataAlt, it should be the only constructor of the type and we
  -- can consider its field demands when analysing the scrutinee.
  | AltCon -> Bool
want_precise_field_dmds AltCon
alt
  = let
        rhs_env :: AnalEnv
rhs_env = AnalEnv -> [Var] -> AnalEnv
addInScopeAnalEnvs AnalEnv
env (Var
case_bndrVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
bndrs)
        -- See Note [Bringing a new variable into scope]
        WithDmdType DmdType
rhs_ty CoreExpr
rhs'           = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
rhs_env SubDemand
dmd CoreExpr
rhs
        WithDmdType DmdType
alt_ty1 [Demand]
fld_dmds      = AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
findBndrsDmds AnalEnv
env DmdType
rhs_ty [Var]
bndrs
        WithDmdType DmdType
alt_ty2 Demand
case_bndr_dmd = AnalEnv -> DmdType -> Var -> WithDmdType Demand
findBndrDmd AnalEnv
env DmdType
alt_ty1 Var
case_bndr
        !case_bndr' :: Var
case_bndr'                       = Var -> Demand -> Var
setIdDemandInfo Var
case_bndr Demand
case_bndr_dmd
        -- Evaluation cardinality on the case binder is irrelevant and a no-op.
        -- What matters is its nested sub-demand!
        -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is
        -- what we want, because then `seq` will put a `seqDmd` on its scrut.
        (Card
_ :* SubDemand
case_bndr_sd) = Demand
case_bndr_dmd
        -- Compute demand on the scrutinee
        -- FORCE the result, otherwise thunks will end up retaining the
        -- whole DmdEnv
        !(![Var]
bndrs', !SubDemand
scrut_sd)
          | DataAlt DataCon
_ <- AltCon
alt
          -- See Note [Demand on the scrutinee of a product case]
          , let !scrut_sd :: SubDemand
scrut_sd = SubDemand -> [Demand] -> SubDemand
scrutSubDmd SubDemand
case_bndr_sd [Demand]
fld_dmds
          -- See Note [Demand on case-alternative binders]
          , let !fld_dmds' :: [Demand]
fld_dmds' = SubDemand -> Arity -> [Demand]
fieldBndrDmds SubDemand
scrut_sd ([Demand] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Demand]
fld_dmds)
          , let !bndrs' :: [Var]
bndrs' = HasCallStack => [Var] -> [Demand] -> [Var]
[Var] -> [Demand] -> [Var]
setBndrsDemandInfo [Var]
bndrs [Demand]
fld_dmds'
          = ([Var]
bndrs', SubDemand
scrut_sd)
          | Bool
otherwise
          -- __DEFAULT and literal alts. Simply add demands and discard the
          -- evaluation cardinality, as we evaluate the scrutinee exactly once.
          = Bool -> ([Var], SubDemand) -> ([Var], SubDemand)
forall a. HasCallStack => Bool -> a -> a
assert ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
bndrs) ([Var]
bndrs, SubDemand
case_bndr_sd)
        alt_ty3 :: DmdType
alt_ty3
          -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
          | FamInstEnvs -> CoreExpr -> Bool
exprMayThrowPreciseException (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) CoreExpr
scrut
          = DmdType -> DmdType
deferAfterPreciseException DmdType
alt_ty2
          | Bool
otherwise
          = DmdType
alt_ty2

        WithDmdType DmdType
scrut_ty CoreExpr
scrut' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
scrut_sd CoreExpr
scrut
        res_ty :: DmdType
res_ty             = DmdType
alt_ty3 DmdType -> DmdEnv -> DmdType
`plusDmdType` DmdType -> DmdEnv
discardArgDmds DmdType
scrut_ty
    in
--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
--                                   , text "dmd" <+> ppr dmd
--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
--                                   , text "scrut_sd" <+> ppr scrut_sd
--                                   , text "scrut_ty" <+> ppr scrut_ty
--                                   , text "alt_ty" <+> ppr alt_ty2
--                                   , text "res_ty" <+> ppr res_ty ]) $
    DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
res_ty (CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' Var
case_bndr' Type
ty [AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
alt [Var]
bndrs' CoreExpr
rhs'])
    where
      want_precise_field_dmds :: AltCon -> Bool
want_precise_field_dmds AltCon
alt = case AltCon
alt of
        (DataAlt DataCon
dc)
          | Maybe DataCon
Nothing <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe (TyCon -> Maybe DataCon) -> TyCon -> Maybe DataCon
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
dc -> Bool
False
          | IsRecDataConResult
DefinitelyRecursive <- AnalEnv -> DataCon -> IsRecDataConResult
ae_rec_dc AnalEnv
env DataCon
dc                  -> Bool
False
              -- See Note [Demand analysis for recursive data constructors]
        AltCon
_                                                            -> Bool
True




dmdAnal' AnalEnv
env SubDemand
dmd (Case CoreExpr
scrut Var
case_bndr Type
ty [Alt Var]
alts)
  = let      -- Case expression with multiple alternatives
        WithDmdType DmdType
alt_ty [Alt Var]
alts'     = [Alt Var] -> WithDmdType [Alt Var]
combineAltDmds [Alt Var]
alts

        combineAltDmds :: [Alt Var] -> WithDmdType [Alt Var]
combineAltDmds [] = DmdType -> [Alt Var] -> WithDmdType [Alt Var]
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
botDmdType []
        combineAltDmds (Alt Var
a:[Alt Var]
as) =
          let
            WithDmdType DmdType
cur_ty Alt Var
a' = AnalEnv -> SubDemand -> Var -> Alt Var -> WithDmdType (Alt Var)
dmdAnalSumAlt AnalEnv
env SubDemand
dmd Var
case_bndr Alt Var
a
            WithDmdType DmdType
rest_ty [Alt Var]
as' = [Alt Var] -> WithDmdType [Alt Var]
combineAltDmds [Alt Var]
as
          in DmdType -> [Alt Var] -> WithDmdType [Alt Var]
forall a. DmdType -> a -> WithDmdType a
WithDmdType (DmdType -> DmdType -> DmdType
lubDmdType DmdType
cur_ty DmdType
rest_ty) (Alt Var
a'Alt Var -> [Alt Var] -> [Alt Var]
forall a. a -> [a] -> [a]
:[Alt Var]
as')

        WithDmdType DmdType
alt_ty1 Demand
case_bndr_dmd = AnalEnv -> DmdType -> Var -> WithDmdType Demand
findBndrDmd AnalEnv
env DmdType
alt_ty Var
case_bndr
        !case_bndr' :: Var
case_bndr'                       = Var -> Demand -> Var
setIdDemandInfo Var
case_bndr Demand
case_bndr_dmd
        WithDmdType DmdType
scrut_ty CoreExpr
scrut'       = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
topSubDmd CoreExpr
scrut
                               -- NB: Base case is botDmdType, for empty case alternatives
                               --     This is a unit for lubDmdType, and the right result
                               --     when there really are no alternatives
        fam_envs :: FamInstEnvs
fam_envs             = AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env
        alt_ty2 :: DmdType
alt_ty2
          -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
          | FamInstEnvs -> CoreExpr -> Bool
exprMayThrowPreciseException FamInstEnvs
fam_envs CoreExpr
scrut
          = DmdType -> DmdType
deferAfterPreciseException DmdType
alt_ty1
          | Bool
otherwise
          = DmdType
alt_ty1
        res_ty :: DmdType
res_ty               = DmdType
scrut_ty DmdType -> DmdEnv -> DmdType
`plusDmdType` DmdType -> DmdEnv
discardArgDmds DmdType
alt_ty2

    in
--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
--                                   , text "scrut_ty" <+> ppr scrut_ty
--                                   , text "alt_tys" <+> ppr alt_tys
--                                   , text "alt_ty2" <+> ppr alt_ty2
--                                   , text "res_ty" <+> ppr res_ty ]) $
    DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
res_ty (CoreExpr -> Var -> Type -> [Alt Var] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' Var
case_bndr' Type
ty [Alt Var]
alts')

dmdAnal' AnalEnv
env SubDemand
dmd (Let Bind Var
bind CoreExpr
body)
  = DmdType -> CoreExpr -> WithDmdType CoreExpr
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
final_ty (Bind Var -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let Bind Var
bind' CoreExpr
body')
  where
    !(WithDmdType DmdType
final_ty (R Bind Var
bind' CoreExpr
body')) = TopLevelFlag
-> AnalEnv
-> SubDemand
-> Bind Var
-> (AnalEnv -> WithDmdType CoreExpr)
-> WithDmdType (DmdResult (Bind Var) CoreExpr)
forall a.
TopLevelFlag
-> AnalEnv
-> SubDemand
-> Bind Var
-> (AnalEnv -> WithDmdType a)
-> WithDmdType (DmdResult (Bind Var) a)
dmdAnalBind TopLevelFlag
NotTopLevel AnalEnv
env SubDemand
dmd Bind Var
bind AnalEnv -> WithDmdType CoreExpr
go'
    go' :: AnalEnv -> WithDmdType CoreExpr
go' !AnalEnv
env'                 = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env' SubDemand
dmd CoreExpr
body

-- | A simple, syntactic analysis of whether an expression MAY throw a precise
-- exception when evaluated. It's always sound to return 'True'.
-- See Note [Which scrutinees may throw precise exceptions].
exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool
exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool
exprMayThrowPreciseException FamInstEnvs
envs CoreExpr
e
  | Bool -> Bool
not (FamInstEnvs -> Type -> Bool
forcesRealWorld FamInstEnvs
envs ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e))
  = Bool
False -- 1. in the Note
  | (Var Var
f, [CoreExpr]
_) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e
  , Just PrimOp
op    <- Var -> Maybe PrimOp
isPrimOpId_maybe Var
f
  , PrimOp
op PrimOp -> PrimOp -> Bool
forall a. Eq a => a -> a -> Bool
/= PrimOp
RaiseIOOp
  = Bool
False -- 2. in the Note
  | (Var Var
f, [CoreExpr]
_) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e
  , Just ForeignCall
fcall <- Var -> Maybe ForeignCall
isFCallId_maybe Var
f
  , Bool -> Bool
not (ForeignCall -> Bool
isSafeForeignCall ForeignCall
fcall)
  = Bool
False -- 3. in the Note
  | Bool
otherwise
  = Bool
True  -- _. in the Note

-- | Recognises types that are
--    * @State# RealWorld@
--    * Unboxed tuples with a @State# RealWorld@ field
-- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See
-- T13380e) and user-written variants thereof by their type.
forcesRealWorld :: FamInstEnvs -> Type -> Bool
forcesRealWorld :: FamInstEnvs -> Type -> Bool
forcesRealWorld FamInstEnvs
fam_envs Type
ty
  | Type
ty Type -> Type -> Bool
`eqType` Type
realWorldStatePrimTy
  = Bool
True
  | Just (TyCon
tc, [Type]
tc_args, Coercion
_co)  <- FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
normSplitTyConApp_maybe FamInstEnvs
fam_envs Type
ty
  , TyCon -> Bool
isUnboxedTupleTyCon TyCon
tc
  , let field_tys :: [Scaled Type]
field_tys = DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys (TyCon -> DataCon
tyConSingleDataCon TyCon
tc) [Type]
tc_args
  = (Scaled Type -> Bool) -> [Scaled Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Type -> Type -> Bool
eqType Type
realWorldStatePrimTy (Type -> Bool) -> (Scaled Type -> Type) -> Scaled Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scaled Type -> Type
forall a. Scaled a -> a
scaledThing) [Scaled Type]
field_tys
  | Bool
otherwise
  = Bool
False

dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType CoreAlt
dmdAnalSumAlt :: AnalEnv -> SubDemand -> Var -> Alt Var -> WithDmdType (Alt Var)
dmdAnalSumAlt AnalEnv
env SubDemand
dmd Var
case_bndr (Alt AltCon
con [Var]
bndrs CoreExpr
rhs)
  | let rhs_env :: AnalEnv
rhs_env = AnalEnv -> [Var] -> AnalEnv
addInScopeAnalEnvs AnalEnv
env (Var
case_bndrVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
bndrs)
    -- See Note [Bringing a new variable into scope]
  , WithDmdType DmdType
rhs_ty CoreExpr
rhs' <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
rhs_env SubDemand
dmd CoreExpr
rhs
  , WithDmdType DmdType
alt_ty [Demand]
dmds <- AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
findBndrsDmds AnalEnv
env DmdType
rhs_ty [Var]
bndrs
  , let (Card
_ :* SubDemand
case_bndr_sd) = DmdType -> Var -> Demand
findIdDemand DmdType
alt_ty Var
case_bndr
        -- See Note [Demand on case-alternative binders]
        -- we can't use the scrut_sd, because it says 'Prod' and we'll use
        -- topSubDmd anyway for scrutinees of sum types.
        scrut_sd :: SubDemand
scrut_sd = SubDemand -> [Demand] -> SubDemand
scrutSubDmd SubDemand
case_bndr_sd [Demand]
dmds
        dmds' :: [Demand]
dmds' = SubDemand -> Arity -> [Demand]
fieldBndrDmds SubDemand
scrut_sd ([Demand] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Demand]
dmds)
        -- Do not put a thunk into the Alt
        !new_ids :: [Var]
new_ids            = HasCallStack => [Var] -> [Demand] -> [Var]
[Var] -> [Demand] -> [Var]
setBndrsDemandInfo [Var]
bndrs [Demand]
dmds'
  = DmdType -> Alt Var -> WithDmdType (Alt Var)
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
alt_ty (AltCon -> [Var] -> CoreExpr -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Var]
new_ids CoreExpr
rhs')

-- See Note [Demand on the scrutinee of a product case]
scrutSubDmd :: SubDemand -> [Demand] -> SubDemand
scrutSubDmd :: SubDemand -> [Demand] -> SubDemand
scrutSubDmd SubDemand
case_sd [Demand]
fld_dmds =
  -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $
  SubDemand
case_sd SubDemand -> SubDemand -> SubDemand
`plusSubDmd` Boxity -> [Demand] -> SubDemand
mkProd Boxity
Unboxed [Demand]
fld_dmds

-- See Note [Demand on case-alternative binders]
fieldBndrDmds :: SubDemand -- on the scrutinee
              -> Arity
              -> [Demand]  -- Final demands for the components of the DataCon
fieldBndrDmds :: SubDemand -> Arity -> [Demand]
fieldBndrDmds SubDemand
scrut_sd Arity
n_flds =
  case Arity -> SubDemand -> Maybe (Boxity, [Demand])
viewProd Arity
n_flds SubDemand
scrut_sd of
    Just (Boxity
_, [Demand]
ds) -> [Demand]
ds
    Maybe (Boxity, [Demand])
Nothing      -> Arity -> Demand -> [Demand]
forall a. Arity -> a -> [a]
replicate Arity
n_flds Demand
topDmd
                      -- Either an arity mismatch or scrut_sd was a call demand.
                      -- See Note [Untyped demand on case-alternative binders]

{-
Note [Analysing with absent demand]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we analyse an expression with demand A.  The "A" means
"absent", so this expression will never be needed. What should happen?
There are several wrinkles:

* We *do* want to analyse the expression regardless.
  Reason: Note [Always analyse in virgin pass]

  But we can post-process the results to ignore all the usage
  demands coming back. This is done by multDmdType.

* Nevertheless, which sub-demand should we pick for analysis?
  Since the demand was absent, any would do. Worker/wrapper will replace
  absent bindings with an absent filler anyway, so annotations in the RHS
  of an absent binding don't matter much.
  Picking 'botSubDmd' would be the most useful, but would also look a bit
  misleading in the Core output of DmdAnal, because all nested annotations would
  be bottoming. Better pick 'seqSubDmd', so that we annotate many of those
  nested bindings with A themselves.

* In a previous incarnation of GHC we needed to be extra careful in the
  case of an *unlifted type*, because unlifted values are evaluated
  even if they are not used.  Example (see #9254):
     f :: (() -> (# Int#, () #)) -> ()
          -- Strictness signature is
          --    <CS(S(A,SU))>
          -- I.e. calls k, but discards first component of result
     f k = case k () of (# _, r #) -> r

     g :: Int -> ()
     g y = f (\n -> (# case y of I# y2 -> y2, n #))

  Here f's strictness signature says (correctly) that it calls its
  argument function and ignores the first component of its result.
  This is correct in the sense that it'd be fine to (say) modify the
  function so that always returned 0# in the first component.

  But in function g, we *will* evaluate the 'case y of ...', because
  it has type Int#.  So 'y' will be evaluated.  So we must record this
  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that
  'y' is bound to an aBSENT_ERROR thunk.

  However, the argument of toSubDmd always satisfies the let/app
  invariant; so if it is unlifted it is also okForSpeculation, and so
  can be evaluated in a short finite time -- and that rules out nasty
  cases like the one above.  (I'm not quite sure why this was a
  problem in an earlier version of GHC, but it isn't now.)

Note [Always analyse in virgin pass]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Tricky point: make sure that we analyse in the 'virgin' pass. Consider
   rec { f acc x True  = f (...rec { g y = ...g... }...)
         f acc x False = acc }
In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.
That might mean that we analyse the sub-expression containing the
E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*
E, but just returned botType.

Then in the *next* (non-virgin) iteration for 'f', we might analyse E
in a weaker demand, and that will trigger doing a fixpoint iteration
for g.  But *because it's not the virgin pass* we won't start g's
iteration at bottom.  Disaster.  (This happened in $sfibToList' of
nofib/spectral/fibheaps.)

So in the virgin pass we make sure that we do analyse the expression
at least once, to initialise its signatures.

Note [Which scrutinees may throw precise exceptions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This is the specification of 'exprMayThrowPreciseExceptions',
which is important for Scenario 2 of
Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.

For an expression @f a1 ... an :: ty@ we determine that
  1. False  If ty is *not* @State# RealWorld@ or an unboxed tuple thereof.
            This check is done by 'forcesRealWorld'.
            (Why not simply unboxed pairs as above? This is motivated by
            T13380{d,e}.)
  2. False  If f is a PrimOp, and it is *not* raiseIO#
  3. False  If f is an unsafe FFI call ('PlayRisky')
  _. True   Otherwise "give up".

It is sound to return False in those cases, because
  1. We don't give any guarantees for unsafePerformIO, so no precise exceptions
     from pure code.
  2. raiseIO# is the only primop that may throw a precise exception.
  3. Unsafe FFI calls may not interact with the RTS (to throw, for example).
     See haddock on GHC.Types.ForeignCall.PlayRisky.

We *need* to return False in those cases, because
  1. We would lose too much strictness in pure code, all over the place.
  2. We would lose strictness for primops like getMaskingState#, which
     introduces a substantial regression in
     GHC.IO.Handle.Internals.wantReadableHandle.
  3. We would lose strictness for code like GHC.Fingerprint.fingerprintData,
     where an intermittent FFI call to c_MD5Init would otherwise lose
     strictness on the arguments len and buf, leading to regressions in T9203
     (2%) and i386's haddock.base (5%). Tested by T13380f.

In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic)
to the Divergence lattice, but in practice it turned out to be hard to untaint
from 'topDiv' to 'conDiv', leading to bugs, performance regressions and
complexity that didn't justify the single fixed testcase T13380c.

Note [Demand analysis for recursive data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
T11545 features a single-product, recursive data type
  data A = A A A ... A
    deriving Eq
Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That
leads to very large (exponential in the depth) demand signatures and fruitless
churn in boxity analysis, demand analysis and worker/wrapper.
So we detect `A` as a recursive data constructor
(see Note [Detecting recursive data constructors]) analysing `case x of A ...`
and simply assume L for the demand on field binders, which is the same code
path as we take for sum types.
Combined with the B demand on the case binder, we get the very small demand
signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545
tenfold! See also Note [CPR for recursive data constructors] which describes the
sibling mechanism in CPR analysis.

Note [Demand on the scrutinee of a product case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When figuring out the demand on the scrutinee of a product case,
we use the demands of the case alternative, i.e. id_dmds.
But note that these include the demand on the case binder;
see Note [Demand on case-alternative binders].
This is crucial. Example:
   f x = case x of y { (a,b) -> k y a }
If we just take scrut_demand = 1P(L,A), then we won't pass x to the
worker, so the worker will rebuild
     x = (a, absent-error)
and that'll crash.

Note [Demand on case-alternative binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The demand on a binder in a case alternative comes
  (a) From the demand on the binder itself
  (b) From the demand on the case binder
Forgetting (b) led directly to #10148.

Example. Source code:
  f x@(p,_) = if p then foo x else True

  foo (p,True) = True
  foo (p,q)    = foo (q,p)

After strictness analysis, forgetting (b):
  f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->
      case x_an1
      of wild_X7 [Dmd=MP(ML,ML)]
      { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->
      case p_an2 of _ {
        False -> GHC.Types.True;
        True -> foo wild_X7 }

Note that ds_dnz is syntactically dead, but the expression bound to it is
reachable through the case binder wild_X7. Now watch what happens if we inline
foo's wrapper:
  f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->
      case x_an1
      of _ [Dmd=MP(ML,ML)]
      { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->
      case p_an2 of _ {
        False -> GHC.Types.True;
        True -> $wfoo_soq GHC.Types.True ds_dnz }

Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second
run of demand analysis would no longer infer ds_dnz to be absent.
But unlike occurrence analysis, which infers properties of the *syntactic*
shape of the program, the results of demand analysis describe expressions
*semantically* and are supposed to be mostly stable across Simplification.
That's why we should better account for (b).
In #10148, we ended up emitting a single-entry thunk instead of an updateable
thunk for a let binder that was an an absent case-alt binder during DmdAnal.

This is needed even for non-product types, in case the case-binder
is used but the components of the case alternative are not.

Note [Untyped demand on case-alternative binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder
may be a call demand or have a different number of fields than the constructor
of the case alternative it is used in. From T22039:

  blarg :: (Int, Int) -> Int
  blarg (x,y) = x+y
  -- blarg :: <1!P(1L,1L)>

  f :: Either Int Int -> Int
  f Left{} = 0
  f e = blarg (unsafeCoerce e)
  ==> { desugars to }
  f = \ (ds_d1nV :: Either Int Int) ->
      case ds_d1nV of wild_X1 {
        Left ds_d1oV -> lvl_s1Q6;
        Right ipv_s1Pl ->
          blarg
            (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of
             { UnsafeRefl co_a1oT ->
             wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int))
             })
      }

The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call
to `blarg`, but `Right` only has one field. Although the code will crash when
executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively
approximate with Top instead of panicking because of the mismatch.
In #22039, this kind of code was guarded behind a safe `cast` and thus dead
code, but nevertheless led to a panic of the compiler.

You might wonder why the same problem doesn't come up when scrutinising a
product type instead of a sum type. It appears that for products, `wild_X1`
will be inlined before DmdAnal.

See also Note [mkWWstr and unsafeCoerce] for a related issue.

Note [Aggregated demand for cardinality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FIXME: This Note should be named [LetUp vs. LetDown] and probably predates
said separation. SG

We use different strategies for strictness and usage/cardinality to
"unleash" demands captured on free variables by bindings. Let us
consider the example:

f1 y = let {-# NOINLINE h #-}
           h = y
       in  (h, h)

We are interested in obtaining cardinality demand U1 on |y|, as it is
used only in a thunk, and, therefore, is not going to be updated any
more. Therefore, the demand on |y|, captured and unleashed by usage of
|h| is U1. However, if we unleash this demand every time |h| is used,
and then sum up the effects, the ultimate demand on |y| will be U1 +
U1 = U. In order to avoid it, we *first* collect the aggregate demand
on |h| in the body of let-expression, and only then apply the demand
transformer:

transf[x](U) = {y |-> U1}

so the resulting demand on |y| is U1.

The situation is, however, different for strictness, where this
aggregating approach exhibits worse results because of the nature of
|both| operation for strictness. Consider the example:

f y c =
  let h x = y |seq| x
   in case of
        True  -> h True
        False -> y

It is clear that |f| is strict in |y|, however, the suggested analysis
will infer from the body of |let| that |h| is used lazily (as it is
used in one branch only), therefore lazy demand will be put on its
free variable |y|. Conversely, if the demand on |h| is unleashed right
on the spot, we will get the desired result, namely, that |f| is
strict in |y|.


************************************************************************
*                                                                      *
                    Demand transformer
*                                                                      *
************************************************************************
-}

dmdTransform :: AnalEnv   -- ^ The analysis environment
             -> Id        -- ^ The variable
             -> SubDemand -- ^ The evaluation context of the var
             -> DmdType   -- ^ The demand type unleashed by the variable in this
                          -- context. The returned DmdEnv includes the demand on
                          -- this function plus demand on its free variables
-- See Note [What are demand signatures?] in "GHC.Types.Demand"
dmdTransform :: AnalEnv -> Var -> SubDemand -> DmdType
dmdTransform AnalEnv
env Var
var SubDemand
sd
  -- Data constructors
  | Just DataCon
con <- Var -> Maybe DataCon
isDataConWorkId_maybe Var
var
  = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $
    [StrictnessMark] -> SubDemand -> DmdType
dmdTransformDataConSig (DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
con) SubDemand
sd
  -- Dictionary component selectors
  -- Used to be controlled by a flag.
  -- See #18429 for some perf measurements.
  | Just Class
_ <- Var -> Maybe Class
isClassOpId_maybe Var
var
  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $
    DmdSig -> SubDemand -> DmdType
dmdTransformDictSelSig (Var -> DmdSig
idDmdSig Var
var) SubDemand
sd
  -- Imported functions
  | Var -> Bool
isGlobalId Var
var
  , let res :: DmdType
res = DmdSig -> SubDemand -> DmdType
dmdTransformSig (Var -> DmdSig
idDmdSig Var
var) SubDemand
sd
  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res])
    DmdType
res
  -- Top-level or local let-bound thing for which we use LetDown ('useLetUp').
  -- In that case, we have a strictness signature to unleash in our AnalEnv.
  | Just (DmdSig
sig, TopLevelFlag
top_lvl) <- AnalEnv -> Var -> Maybe (DmdSig, TopLevelFlag)
lookupSigEnv AnalEnv
env Var
var
  , let fn_ty :: DmdType
fn_ty = DmdSig -> SubDemand -> DmdType
dmdTransformSig DmdSig
sig SubDemand
sd
  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $
    case TopLevelFlag
top_lvl of
      TopLevelFlag
NotTopLevel -> DmdType -> Var -> Demand -> DmdType
addVarDmd DmdType
fn_ty Var
var (Card
C_11 (() :: Constraint) => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
sd)
      TopLevelFlag
TopLevel
        | Var -> Bool
isInterestingTopLevelFn Var
var
        -- Top-level things will be used multiple times or not at
        -- all anyway, hence the multDmd below: It means we don't
        -- have to track whether @var@ is used strictly or at most
        -- once, because ultimately it never will.
        -> DmdType -> Var -> Demand -> DmdType
addVarDmd DmdType
fn_ty Var
var (Card
C_0N Card -> Demand -> Demand
`multDmd` (Card
C_11 (() :: Constraint) => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
sd)) -- discard strictness
        | Bool
otherwise
        -> DmdType
fn_ty -- don't bother tracking; just annotate with 'topDmd' later
  -- Everything else:
  --   * Local let binders for which we use LetUp (cf. 'useLetUp')
  --   * Lambda binders
  --   * Case and constructor field binders
  | Bool
otherwise
  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $
    DmdEnv -> DmdType
noArgsDmdType (DmdEnv -> Var -> Demand -> DmdEnv
addVarDmdEnv DmdEnv
nopDmdEnv Var
var (Card
C_11 (() :: Constraint) => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
sd))

{- *********************************************************************
*                                                                      *
                      Binding right-hand sides
*                                                                      *
********************************************************************* -}

-- | An environment in which all demands are weak according to 'isWeakDmd'.
-- See Note [Lazy and unleashable free variables].
type WeakDmds = VarEnv Demand

-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature
-- for the LetDown rule. It works as follows:
--
--  * assuming the weakest possible body sub-demand, L
--  * looking at the definition
--  * determining a strictness signature
--
-- Since it assumed a body sub-demand of L, the resulting signature is
-- applicable at any call site.
dmdAnalRhsSig
  :: TopLevelFlag
  -> RecFlag
  -> AnalEnv -> SubDemand
  -> Id -> CoreExpr
  -> (AnalEnv, WeakDmds, Id, CoreExpr)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-- See Note [NOINLINE and strictness]
dmdAnalRhsSig :: TopLevelFlag
-> RecFlag
-> AnalEnv
-> SubDemand
-> Var
-> CoreExpr
-> (AnalEnv, WeakDmds, Var, CoreExpr)
dmdAnalRhsSig TopLevelFlag
top_lvl RecFlag
rec_flag AnalEnv
env SubDemand
let_dmd Var
id CoreExpr
rhs
  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $
    (AnalEnv
final_env, WeakDmds
weak_fvs, Var
final_id, CoreExpr
final_rhs)
  where
    rhs_arity :: Arity
rhs_arity = Var -> Arity
idArity Var
id
    -- See Note [Demand signatures are computed for a threshold demand based on idArity]

    rhs_dmd :: SubDemand
rhs_dmd = Arity -> SubDemand -> SubDemand
mkCalledOnceDmds Arity
rhs_arity SubDemand
body_dmd

    body_dmd :: SubDemand
body_dmd
      | Var -> Bool
isJoinId Var
id
      -- See Note [Demand analysis for join points]
      -- See Note [Invariants on join points] invariant 2b, in GHC.Core
      --     rhs_arity matches the join arity of the join point
      -- See Note [Unboxed demand on function bodies returning small products]
      = AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand
unboxedWhenSmall AnalEnv
env RecFlag
rec_flag (Var -> Maybe Type
resultType_maybe Var
id) SubDemand
let_dmd
      | Bool
otherwise
      -- See Note [Unboxed demand on function bodies returning small products]
      = AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand
unboxedWhenSmall AnalEnv
env RecFlag
rec_flag (Var -> Maybe Type
resultType_maybe Var
id) SubDemand
topSubDmd

    WithDmdType DmdType
rhs_dmd_ty CoreExpr
rhs' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
dmdAnal AnalEnv
env SubDemand
rhs_dmd CoreExpr
rhs
    DmdType DmdEnv
rhs_env [Demand]
rhs_dmds = DmdType
rhs_dmd_ty
    ([Demand]
final_rhs_dmds, CoreExpr
final_rhs) = AnalEnv
-> Var
-> Arity
-> CoreExpr
-> Divergence
-> Maybe ([Demand], CoreExpr)
finaliseArgBoxities AnalEnv
env Var
id Arity
rhs_arity CoreExpr
rhs' (DmdEnv -> Divergence
de_div DmdEnv
rhs_env)
                                    Maybe ([Demand], CoreExpr)
-> ([Demand], CoreExpr) -> ([Demand], CoreExpr)
forall a. Maybe a -> a -> a
`orElse` ([Demand]
rhs_dmds, CoreExpr
rhs')

    sig :: DmdSig
sig = Arity -> DmdType -> DmdSig
mkDmdSigForArity Arity
rhs_arity (DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
sig_env [Demand]
final_rhs_dmds)

    final_id :: Var
final_id   = Var
id Var -> DmdSig -> Var
`setIdDmdSig` DmdSig
sig
    !final_env :: AnalEnv
final_env = TopLevelFlag -> AnalEnv -> Var -> DmdSig -> AnalEnv
extendAnalEnv TopLevelFlag
top_lvl AnalEnv
env Var
final_id DmdSig
sig

    -- See Note [Aggregated demand for cardinality]
    -- FIXME: That Note doesn't explain the following lines at all. The reason
    --        is really much different: When we have a recursive function, we'd
    --        have to also consider the free vars of the strictness signature
    --        when checking whether we found a fixed-point. That is expensive;
    --        we only want to check whether argument demands of the sig changed.
    --        reuseEnv makes it so that the FV results are stable as long as the
    --        last argument demands were. Strictness won't change. But used-once
    --        might turn into used-many even if the signature was stable and
    --        we'd have to do an additional iteration. reuseEnv makes sure that
    --        we never get used-once info for FVs of recursive functions.
    --        See #14816 where we try to get rid of reuseEnv.
    rhs_env1 :: DmdEnv
rhs_env1 = case RecFlag
rec_flag of
                RecFlag
Recursive    -> DmdEnv -> DmdEnv
reuseEnv DmdEnv
rhs_env
                RecFlag
NonRecursive -> DmdEnv
rhs_env

    -- See Note [Absence analysis for stable unfoldings and RULES]
    rhs_env2 :: DmdEnv
rhs_env2 = DmdEnv
rhs_env1 DmdEnv -> DmdEnv -> DmdEnv
`plusDmdEnv` AnalEnv -> VarSet -> DmdEnv
demandRootSet AnalEnv
env (Var -> VarSet
bndrRuleAndUnfoldingIds Var
id)

    -- See Note [Lazy and unleashable free variables]
    !(!DmdEnv
sig_env, !WeakDmds
weak_fvs) = DmdEnv -> (DmdEnv, WeakDmds)
splitWeakDmds DmdEnv
rhs_env2

splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)
splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)
splitWeakDmds (DE WeakDmds
fvs Divergence
div) = (WeakDmds -> Divergence -> DmdEnv
DE WeakDmds
sig_fvs Divergence
div, WeakDmds
weak_fvs)
  where (!WeakDmds
weak_fvs, !WeakDmds
sig_fvs) = (Demand -> Bool) -> WeakDmds -> (WeakDmds, WeakDmds)
forall a. (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)
partitionVarEnv Demand -> Bool
isWeakDmd WeakDmds
fvs

-- | The result type after applying 'idArity' many arguments. Returns 'Nothing'
-- when the type doesn't have exactly 'idArity' many arrows.
resultType_maybe :: Id -> Maybe Type
resultType_maybe :: Var -> Maybe Type
resultType_maybe Var
id
  | ([TyCoBinder]
pis,Type
ret_ty) <- Type -> ([TyCoBinder], Type)
splitPiTys (Var -> Type
idType Var
id)
  , (TyCoBinder -> Bool) -> [TyCoBinder] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count (Bool -> Bool
not (Bool -> Bool) -> (TyCoBinder -> Bool) -> TyCoBinder -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoBinder -> Bool
isNamedBinder) [TyCoBinder]
pis Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Var -> Arity
idArity Var
id
  = Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$! Type
ret_ty
  | Bool
otherwise
  = Maybe Type
forall a. Maybe a
Nothing

unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand
-- See Note [Unboxed demand on function bodies returning small products]
unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand
unboxedWhenSmall AnalEnv
_   RecFlag
_        Maybe Type
Nothing       SubDemand
sd = SubDemand
sd
unboxedWhenSmall AnalEnv
env RecFlag
rec_flag (Just Type
ret_ty) SubDemand
sd = Arity -> Type -> SubDemand -> SubDemand
go Arity
1 Type
ret_ty SubDemand
sd
  where
    -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We
    -- might want to minmax in the future.
    max_depth :: Arity
max_depth | RecFlag -> Bool
isRec RecFlag
rec_flag = Arity
3 -- So we get at most something as deep as !P(L!P(L!L))
              | Bool
otherwise      = Arity
1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows
    go :: Int -> Type -> SubDemand -> SubDemand
    go :: Arity -> Type -> SubDemand -> SubDemand
go Arity
depth Type
ty SubDemand
sd
      | Arity
depth Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
max_depth
      , Just (TyCon
tc, [Type]
tc_args, Coercion
_co) <- FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
normSplitTyConApp_maybe (AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env) Type
ty
      , Just DataCon
dc <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tc
      , [Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Var]
dataConExTyCoVars DataCon
dc) -- Can't unbox results with existentials
      , DataCon -> Arity
dataConRepArity DataCon
dc Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= DmdAnalOpts -> Arity
dmd_unbox_width (AnalEnv -> DmdAnalOpts
ae_opts AnalEnv
env)
      , Just (Boxity
_, [Demand]
ds) <- Arity -> SubDemand -> Maybe (Boxity, [Demand])
viewProd (DataCon -> Arity
dataConRepArity DataCon
dc) SubDemand
sd
      , [Type]
arg_tys <- (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Scaled Type]
dataConInstArgTys DataCon
dc [Type]
tc_args
      , [Demand] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Demand]
ds [Type]
arg_tys
      = Boxity -> [Demand] -> SubDemand
mkProd Boxity
Unboxed ([Demand] -> SubDemand) -> [Demand] -> SubDemand
forall a b. (a -> b) -> a -> b
$! (Type -> Demand -> Demand) -> [Type] -> [Demand] -> [Demand]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
strictZipWith (Arity -> Type -> Demand -> Demand
go_dmd (Arity
depthArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1)) [Type]
arg_tys [Demand]
ds
      | Bool
otherwise
      = SubDemand
sd

    go_dmd :: Int -> Type -> Demand -> Demand
    go_dmd :: Arity -> Type -> Demand -> Demand
go_dmd Arity
depth Type
ty Demand
dmd = case Demand
dmd of
      Demand
AbsDmd  -> Demand
AbsDmd
      Demand
BotDmd  -> Demand
BotDmd
      Card
n :* SubDemand
sd -> Card
n (() :: Constraint) => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Arity -> Type -> SubDemand -> SubDemand
go Arity
depth Type
ty SubDemand
sd

-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines
-- whether we should process the binding up (body before rhs) or down (rhs
-- before body).
--
-- We use LetDown if there is a chance to get a useful strictness signature to
-- unleash at call sites. LetDown is generally more precise than LetUp if we can
-- correctly guess how it will be used in the body, that is, for which incoming
-- demand the strictness signature should be computed, which allows us to
-- unleash higher-order demands on arguments at call sites. This is mostly the
-- case when
--
--   * The binding takes any arguments before performing meaningful work (cf.
--     'idArity'), in which case we are interested to see how it uses them.
--   * The binding is a join point, hence acting like a function, not a value.
--     As a big plus, we know *precisely* how it will be used in the body; since
--     it's always tail-called, we can directly unleash the incoming demand of
--     the let binding on its RHS when computing a strictness signature. See
--     [Demand analysis for join points].
--
-- Thus, if the binding is not a join point and its arity is 0, we have a thunk
-- and use LetUp, implying that we have no usable demand signature available
-- when we analyse the let body.
--
-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free
-- vars at most once, regardless of how many times it was forced in the body.
-- This makes a real difference wrt. usage demands. The other reason is being
-- able to unleash a more precise product demand on its RHS once we know how the
-- thunk was used in the let body.
--
-- Characteristic examples, always assuming a single evaluation:
--
--   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that
--     the expression uses @y@ at most once.
--   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that
--     @b@ is absent.
--   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that
--     the expression uses @y@ strictly, because we have @f@'s demand signature
--     available at the call site.
--   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>
--     LetDown. Compared to LetUp, we find out that the expression uses @y@
--     strictly, because we can unleash @exit@'s signature at each call site.
--   * For a more convincing example with join points, see Note [Demand analysis
--     for join points].
--
useLetUp :: TopLevelFlag -> Var -> Bool
useLetUp :: TopLevelFlag -> Var -> Bool
useLetUp TopLevelFlag
top_lvl Var
f = TopLevelFlag -> Bool
isNotTopLevel TopLevelFlag
top_lvl Bool -> Bool -> Bool
&& Var -> Arity
idArity Var
f Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Var -> Bool
isJoinId Var
f)

{- Note [Demand analysis for join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   g :: (Int,Int) -> Int
   g (p,q) = p+q

   f :: T -> Int -> Int
   f x p = g (join j y = (p,y)
              in case x of
                   A -> j 3
                   B -> j 4
                   C -> (p,7))

If j was a vanilla function definition, we'd analyse its body with
evalDmd, and think that it was lazy in p.  But for join points we can
do better!  We know that j's body will (if called at all) be evaluated
with the demand that consumes the entire join-binding, in this case
the argument demand from g.  Whizzo!  g evaluates both components of
its argument pair, so p will certainly be evaluated if j is called.

For f to be strict in p, we need /all/ paths to evaluate p; in this
case the C branch does so too, so we are fine.  So, as usual, we need
to transport demands on free variables to the call site(s).  Compare
Note [Lazy and unleashable free variables].

The implementation is easy.  When analysing a join point, we can
analyse its body with the demand from the entire join-binding (written
let_dmd here).

Another win for join points!  #13543.

However, note that the strictness signature for a join point can
look a little puzzling.  E.g.

    (join j x = \y. error "urk")
    (in case v of              )
    (     A -> j 3             )  x
    (     B -> j 4             )
    (     C -> \y. blah        )

The entire thing is in a C1(L) context, so j's strictness signature
will be    [A]b
meaning one absent argument, returns bottom.  That seems odd because
there's a \y inside.  But it's right because when consumed in a C1(L)
context the RHS of the join point is indeed bottom.

Note [Demand signatures are computed for a threshold demand based on idArity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We compute demand signatures assuming idArity incoming arguments to approximate
behavior for when we have a call site with at least that many arguments. idArity
is /at least/ the number of manifest lambdas, but might be higher for PAPs and
trivial RHS (see Note [Demand analysis for trivial right-hand sides]).

Because idArity of a function varies independently of its cardinality
properties (cf. Note [idArity varies independently of dmdTypeDepth]), we
implicitly encode the arity for when a demand signature is sound to unleash
in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and DmdSig] in
GHC.Types.Demand). It is unsound to unleash a demand signature when the
incoming number of arguments is less than that.
See Note [What are demand signatures?] in GHC.Types.Demand for more details
on soundness.

Why idArity arguments? Because that's a conservative estimate of how many
arguments we must feed a function before it does anything interesting with them.
Also it elegantly subsumes the trivial RHS and PAP case.

There might be functions for which we might want to analyse for more incoming
arguments than idArity. Example:

  f x =
    if expensive
      then \y -> ... y ...
      else \y -> ... y ...

We'd analyse `f` under a unary call demand C1(L), corresponding to idArity
being 1. That's enough to look under the manifest lambda and find out how a
unary call would use `x`, but not enough to look into the lambdas in the if
branches.

On the other hand, if we analysed for call demand C1(C1(L)), we'd get useful
strictness info for `y` (and more precise info on `x`) and possibly CPR
information, but

  * We would no longer be able to unleash the signature at unary call sites
  * Performing the worker/wrapper split based on this information would be
    implicitly eta-expanding `f`, playing fast and loose with divergence and
    even being unsound in the presence of newtypes, so we refrain from doing so.
    Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap.

Since we only compute one signature, we do so for arity 1. Computing multiple
signatures for different arities (i.e., polyvariance) would be entirely
possible, if it weren't for the additional runtime and implementation
complexity.

Note [idArity varies independently of dmdTypeDepth]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound
identifier. But that means we would have to zap demand signatures every time we
reset or decrease arity. That's an unnecessary dependency, because

  * The demand signature captures a semantic property that is independent of
    what the binding's current arity is
  * idArity is analysis information itself, thus volatile
  * We already *have* dmdTypeDepth, wo why not just use it to encode the
    threshold for when to unleash the signature
    (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand)

Consider the following expression, for example:

    (let go x y = `x` seq ... in go) |> co

`go` might have a strictness signature of `<1L><L>`. The simplifier will identify
`go` as a nullary join point through `joinPointBinding_maybe` and float the
coercion into the binding, leading to an arity decrease:

    join go = (\x y -> `x` seq ...) |> co in go

With the CoreLint check, we would have to zap `go`'s perfectly viable strictness
signature.

Note [Demand analysis for trivial right-hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    foo = plusInt |> co
where plusInt is an arity-2 function with known strictness.  Clearly
we want plusInt's strictness to propagate to foo!  But because it has
no manifest lambdas, it won't do so automatically, and indeed 'co' might
have type (Int->Int->Int) ~ T.

Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to
forward plusInt's demand signature, and all is well (see Note [Newtype arity] in
GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity.

Note [Absence analysis for stable unfoldings and RULES]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Among others, tickets #18638 and #23208 show that it's really important to treat
stable unfoldings as demanded. Consider

   g = blah

   f = \x.  ...no use of g....
   {- f's stable unfolding is f = \x. ...g... -}

If f is ever inlined we use 'g'. But f's current RHS makes no use
of 'g', so if we don't look at the unfolding we'll mark g as Absent,
and transform to

   g = error "Entered absent value"
   f = \x. ...
   {- f's stable unfolding is f = \x. ...g... -}

Now if f is subsequently inlined, we'll use 'g' and ... disaster.

SOLUTION: if f has a stable unfolding, treat every free variable as a
/demand root/, that is: Analyse it as if it was a variable occuring in a
'topDmd' context. This is done in `demandRoot` (which we also use for exported
top-level ids). Do the same for Ids free in the RHS of any RULES for f.

Wrinkles:

  (W1) You may wonder how it can be that f's optimised RHS has somehow
    discarded 'g', but when f is inlined we /don't/ discard g in the same
    way. I think a simple example is
       g = (a,b)
       f = \x.  fst g
       {-# INLINE f #-}

    Now f's optimised RHS will be \x.a, but if we change g to (error "..")
    (since it is apparently Absent) and then inline (\x. fst g) we get
    disaster.  But regardless, #18638 was a more complicated version of
    this, that actually happened in practice.

  (W2) You might wonder why we don't simply take the free vars of the
    unfolding/RULE and map them to topDmd. The reason is that any of the free vars
    might have demand signatures themselves that in turn demand transitive free
    variables and that we hence need to unleash! This came up in #23208.
    Consider

       err :: Int -> b
       err = error "really important message"

       sg :: Int -> Int
       sg _ = case err of {}  -- Str=<1B>b {err:->S}

       g :: a -> a  -- g is exported
       g x = x
       {-# RULES "g" g @Int = sg #-}

    Here, `err` is only demanded by `sg`'s demand signature: It doesn't occur
    in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg`
    because it occurs in the RULEs of `g` (which is exported), we better unleash
    the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd'
    for `sg`, failing to unleash the signature and hence observed an absent
    error instead of the `really important message`.

Note [Boxity for bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
```hs
indexError :: Show a => (a, a) -> a -> String -> b
-- Str=<..><1!P(S,S)><1S><S>b
indexError rng i s = error (show rng ++ show i ++ show s)

get :: (Int, Int) -> Int -> [a] -> a
get p@(l,u) i xs
  | l <= i, i < u = xs !! (i-u)
  | otherwise     = indexError p i "get"
```
The hot path of `get` certainly wants to unbox `p` as well as `l` and `u`, but
the unimportant, diverging error path needs `l` and `u` boxed (although the
wrapper for `indexError` *will* unbox `p`). This pattern often occurs in
performance sensitive code that does bounds-checking.

It would be a shame to let `Boxed` win for the fields! So here's what we do:
While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`,
we `unboxDeeplyDmd` all its argument demands and are careful not to discard
excess boxity in the `StopUnboxing` case, to get the signature
`<1!P(!S,!S)><1!S><S!S>b`.

Then worker/wrapper will not only unbox the pair passed to `indexError` (as it
would do anyway), demand analysis will also pretend that `indexError` needs `l`
and `u` unboxed (and the two other args). Which is a lie, because `indexError`'s
type abstracts over their types and could never unbox them.

The important change is at the *call sites* of `$windexError`: Boxity analysis
will conclude to unbox `l` and `u`, which *will* incur reboxing of crud that
should better float to the call site of `$windexError`. There we don't care
much, because it's in the slow, diverging code path! And that floating often
happens, but not always. See Note [Reboxed crud for bottoming calls].

Note [Reboxed crud for bottoming calls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For functions like `get` in Note [Boxity for bottoming functions], it's clear
that the reboxed crud will be floated inside to the call site of `$windexError`.
But here's an example where that is not the case:
```hs
import GHC.Ix

theresCrud :: Int -> Int -> Int
theresCrud x y = go x
  where
    go 0 = index (0,y) 0
    go 1 = index (x,y) 1
    go n = go (n-1)
    {-# NOINLINE theresCrud #-}
```
If you look at the Core, you'll see that `y` will be reboxed and used in the
two exit join points for the `$windexError` calls, while `x` is only reboxed in the
exit join point for `index (x,y) 1` (happens in lvl below):
```
$wtheresCrud = \ ww ww1 ->
      let { y = I# ww1 } in
      join { lvl2 = ... case lvl1 ww y of wild { }; ... } in
      join { lvl3 = ... case lvl y of wild { }; ... } in
      ...
```
This is currently a bug that we willingly accept and it's documented in #21128.
-}

{- *********************************************************************
*                                                                      *
             Finalising boxity
*                                                                      *
********************************************************************* -}

{- Note [Finalising boxity for demand signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The worker/wrapper pass must strictly adhere to the boxity decisions
encoded in the demand signature, because that is the information that
demand analysis propagates throughout the program. Failing to
implement the strategy laid out in the signature can result in
reboxing in unexpected places. Hence, we must completely anticipate
unboxing decisions during demand analysis and reflect these decicions
in demand annotations. That is the job of 'finaliseArgBoxities',
which is defined here and called from demand analysis.

Here is a list of different Notes it has to take care of:

  * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in
    general, but still allow Note [Unboxing evaluated arguments]
  * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`
  * Implement fixes for corner cases Note [Do not unbox class dictionaries]
    and Note [mkWWstr and unsafeCoerce]

Then, in worker/wrapper blindly trusts the boxity info in the demand signature
and will not look at strictness info *at all*, in 'wantToUnboxArg'.

Note [Finalising boxity for let-bound Ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
  let x = e in body
where the demand on 'x' is 1!P(blah).  We want to unbox x according to
Note [Thunk splitting] in GHC.Core.Opt.WorkWrap.  We must do this becuase
worker/wrapper ignores stricness and looks only at boxity flags; so if
x's demand is L!P(blah) we might still split it (wrongly).  We want to
switch to Boxed on any lazy demand.

That is what finaliseLetBoxity does.  It has no worker-arg budget, so it
is much simpler than finaliseArgBoxities.

Note [No nested Unboxed inside Boxed in demand signature]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
```
f p@(x,y)
  | even (x+y) = []
  | otherwise  = [p]
```
Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)`
on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper
can't unbox the pair components without unboxing the pair! So we better say
`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info.
That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'.

Note [No lazy, Unboxed demands in demand signature]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider T19407:

  data Huge = Huge Bool () ... () -- think: DynFlags
  data T = T { h :: Huge, n :: Int }
  f t@(T h _) = g h t
  g (H b _ ... _) t = if b then 1 else n t

The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better
not put that demand in `g`'s demand signature, because worker/wrapper will not
in general unbox a lazy-and-unboxed demand like `L!P(..)`.
(The exception are known-to-be-evaluated arguments like strict fields,
see Note [Unboxing evaluated arguments].)

The program above is an example where spreading misinformed boxity through the
signature is particularly egregious. If we give `g` that signature, then `f`
puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and
we get

  f (T (H b _ ... _) n) = $wf b n
  $wf b n = $wg b (T (H b x ... x) n)
  $wg = ...

Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in
'trimBoxity', modulo Note [Unboxing evaluated arguments].

Note [Unboxing evaluated arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this program (due to Roman):

    data X a = X !a

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

We want the worker for 'foo' to 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
(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), 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

* Since this has nothing to do with how 'foo' uses 'a', we leave demand
  analysis alone, but account for the additional evaluatedness when
  annotating the binder 'finaliseArgBoxities', which will retain the Unboxed
  boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning
  it's used lazily but unboxed nonetheless. This seems to contradict Note
  [No lazy, Unboxed demands in demand signature], but we know that 'a' is
  evaluated and thus can be unboxed.

* When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands
  together with the respective 'StrictnessMark'. In case of 'x', it will pair
  up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for
  the strict field.

* Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in
  'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but
  since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'.

* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will
  /not/ look at the strictness bits of the demand, only at Boxity flags. As such,
  it will happily unbox 'a' despite the lazy demand on it.

The net effect is that boxity analysis and the w/w transformation are more
aggressive about unboxing the strict arguments of a data constructor than when
looking at strictness info exclusively. It is very much like (Nested) CPR, which
needs its nested fields to be evaluated in order for it to unbox nestedly.

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

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

Note [Do not unbox 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 discard the boxity
flag in finaliseArgBoxities (see the isClassPred test).

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

2. -fspecialise-aggressively.  As #21286 shows, the same phenomenon can occur
   occur without INLINABLE, when we use -fexpose-all-unfoldings and
   -fspecialise-aggressively to do vigorous cross-module specialisation.

3. #18421 found that unboxing a dictionary can also make the worker less likely
   to inline; the inlining heuristics seem to prefer to inline a function
   applied to a dictionary over a function applied to a bunch of functions.

TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing
a raft of higher-order functions isn't a huge win anyway -- you really want to
specialise the function.

Note [Worker argument budget]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In 'finaliseArgBoxities' we don't want to generate workers with zillions of
argument when, say given a strict record with zillions of fields.  So we
limit the maximum number of worker args to the maximum of
  - -fmax-worker-args=N
  - The number of args in the original function; if it already has has
    zillions of arguments we don't want to seek /fewer/ args in the worker.
(Maybe we should /add/ them instead of maxing?)

We pursue a "layered" strategy for unboxing: we unbox the top level of the
argument(s), subject to budget; if there are any arguments left we unbox the
next layer, using that depleted budget.

To achieve this, we use the classic almost-circular programming technique in
which we we write one pass that takes a lazy list of the Budgets for every
layer.

Note [The OPAQUE pragma and avoiding the reboxing of arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when
a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for
'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined.

That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a
W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments
that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of
reboxing does not happen.

But now we have functions with OPAQUE pragmas, which by definition (See Note
[OPAQUE pragma]) do not get W/W-transformed. So in order to avoid reboxing
workers of any W/W-transformed /callers of/ 'f' we need to strip all boxity
information from 'f' in the demand analysis. This will inform the
W/W-transformation code that boxed arguments of 'f' must definitely be passed
along in boxed form and as such dissuade the creation of reboxing workers.
-}

data Budgets = MkB Arity Budgets   -- An infinite list of arity budgets

incTopBudget :: Budgets -> Budgets
incTopBudget :: Budgets -> Budgets
incTopBudget (MkB Arity
n Budgets
bg) = Arity -> Budgets -> Budgets
MkB (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) Budgets
bg

positiveTopBudget :: Budgets -> Bool
positiveTopBudget :: Budgets -> Bool
positiveTopBudget (MkB Arity
n Budgets
_) = Arity
n Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
>= Arity
0

finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence
                    -> Maybe ([Demand], CoreExpr)
finaliseArgBoxities :: AnalEnv
-> Var
-> Arity
-> CoreExpr
-> Divergence
-> Maybe ([Demand], CoreExpr)
finaliseArgBoxities AnalEnv
env Var
fn Arity
arity CoreExpr
rhs Divergence
div
  | Arity
arity Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> (Var -> Bool) -> [Var] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count Var -> Bool
isId [Var]
bndrs  -- Can't find enough binders
  = Maybe ([Demand], CoreExpr)
forall a. Maybe a
Nothing  -- This happens if we have   f = g
             -- Then there are no binders; we don't worker/wrapper; and we
             -- simply want to give f the same demand signature as g

  | Bool
otherwise
  = ([Demand], CoreExpr) -> Maybe ([Demand], CoreExpr)
forall a. a -> Maybe a
Just ([Demand]
arg_dmds', [Demand] -> CoreExpr -> CoreExpr
add_demands [Demand]
arg_dmds' CoreExpr
rhs)
    -- add_demands: we must attach the final boxities to the lambda-binders
    -- of the function, both because that's kosher, and because CPR analysis
    -- uses the info on the binders directly.
  where
    opts :: DmdAnalOpts
opts            = AnalEnv -> DmdAnalOpts
ae_opts AnalEnv
env
    fam_envs :: FamInstEnvs
fam_envs        = AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env
    is_inlinable_fn :: Bool
is_inlinable_fn = Unfolding -> Bool
isStableUnfolding (Var -> Unfolding
realIdUnfolding Var
fn)
    ([Var]
bndrs, CoreExpr
_body)  = CoreExpr -> ([Var], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
rhs
    max_wkr_args :: Arity
max_wkr_args    = DmdAnalOpts -> Arity
dmd_max_worker_args DmdAnalOpts
opts Arity -> Arity -> Arity
forall a. Ord a => a -> a -> a
`max` Arity
arity
                      -- See Note [Worker argument budget]

    -- This is the key line, which uses almost-circular programming
    -- The remaining budget from one layer becomes the initial
    -- budget for the next layer down.  See Note [Worker argument budget]
    (Budgets
remaining_budget, [Demand]
arg_dmds') = Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand])
go_args (Arity -> Budgets -> Budgets
MkB Arity
max_wkr_args Budgets
remaining_budget) [(Type, StrictnessMark, Demand)]
arg_triples

    arg_triples :: [(Type, StrictnessMark, Demand)]
    arg_triples :: [(Type, StrictnessMark, Demand)]
arg_triples = Arity
-> [(Type, StrictnessMark, Demand)]
-> [(Type, StrictnessMark, Demand)]
forall a. Arity -> [a] -> [a]
take Arity
arity ([(Type, StrictnessMark, Demand)]
 -> [(Type, StrictnessMark, Demand)])
-> [(Type, StrictnessMark, Demand)]
-> [(Type, StrictnessMark, Demand)]
forall a b. (a -> b) -> a -> b
$
                  (Var -> (Type, StrictnessMark, Demand))
-> [Var] -> [(Type, StrictnessMark, Demand)]
forall a b. (a -> b) -> [a] -> [b]
map Var -> (Type, StrictnessMark, Demand)
mk_triple ([Var] -> [(Type, StrictnessMark, Demand)])
-> [Var] -> [(Type, StrictnessMark, Demand)]
forall a b. (a -> b) -> a -> b
$
                  (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
isRuntimeVar [Var]
bndrs

    mk_triple :: Id -> (Type,StrictnessMark,Demand)
    mk_triple :: Var -> (Type, StrictnessMark, Demand)
mk_triple Var
bndr | Type -> Bool
is_cls_arg Type
ty = (Type
ty, StrictnessMark
NotMarkedStrict, Demand -> Demand
trimBoxity Demand
dmd)
                   | Bool
is_bot_fn     = (Type
ty, StrictnessMark
NotMarkedStrict, Demand -> Demand
unboxDeeplyDmd Demand
dmd)
                   -- See Note [OPAQUE pragma]
                   -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
                   | Bool
is_opaque     = (Type
ty, StrictnessMark
NotMarkedStrict, Demand -> Demand
trimBoxity Demand
dmd)
                   | Bool
otherwise     = (Type
ty, StrictnessMark
NotMarkedStrict, Demand
dmd)
                   where
                     ty :: Type
ty        = Var -> Type
idType Var
bndr
                     dmd :: Demand
dmd       = Var -> Demand
idDemandInfo Var
bndr
                     is_opaque :: Bool
is_opaque = InlinePragma -> Bool
isOpaquePragma (Var -> InlinePragma
idInlinePragma Var
fn)

    -- is_cls_arg: see Note [Do not unbox class dictionaries]
    is_cls_arg :: Type -> Bool
is_cls_arg Type
arg_ty = Bool
is_inlinable_fn Bool -> Bool -> Bool
&& Type -> Bool
isClassPred Type
arg_ty
    -- is_bot_fn:  see Note [Boxity for bottoming functions]
    is_bot_fn :: Bool
is_bot_fn         = Divergence
div Divergence -> Divergence -> Bool
forall a. Eq a => a -> a -> Bool
== Divergence
botDiv

    go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])
    go_args :: Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand])
go_args Budgets
bg [(Type, StrictnessMark, Demand)]
triples = (Budgets -> (Type, StrictnessMark, Demand) -> (Budgets, Demand))
-> Budgets
-> [(Type, StrictnessMark, Demand)]
-> (Budgets, [Demand])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Budgets -> (Type, StrictnessMark, Demand) -> (Budgets, Demand)
go_arg Budgets
bg [(Type, StrictnessMark, Demand)]
triples

    go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)
    go_arg :: Budgets -> (Type, StrictnessMark, Demand) -> (Budgets, Demand)
go_arg bg :: Budgets
bg@(MkB Arity
bg_top Budgets
bg_inner) (Type
ty, StrictnessMark
str_mark, dmd :: Demand
dmd@(Card
n :* SubDemand
_))
      = case Bool -> FamInstEnvs -> Type -> Demand -> UnboxingDecision Demand
wantToUnboxArg Bool
False FamInstEnvs
fam_envs Type
ty Demand
dmd of
          UnboxingDecision Demand
StopUnboxing
            | Bool -> Bool
not Bool
is_bot_fn
                -- If bot: Keep deep boxity even though WW won't unbox
                -- See Note [Boxity for bottoming functions]
            -> (Arity -> Budgets -> Budgets
MkB (Arity
bg_topArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) Budgets
bg_inner, Demand -> Demand
trimBoxity Demand
dmd)

          Unbox DataConPatContext{dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc=DataCon
dc, dcpc_tc_args :: DataConPatContext -> [Type]
dcpc_tc_args=[Type]
tc_args} [Demand]
dmds
            -> (Arity -> Budgets -> Budgets
MkB (Arity
bg_topArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) Budgets
final_bg_inner, Demand
final_dmd)
            where
              dc_arity :: Arity
dc_arity = DataCon -> Arity
dataConRepArity DataCon
dc
              arg_tys :: [Type]
arg_tys  = DataCon -> [Type] -> [Type]
dubiousDataConInstArgTys DataCon
dc [Type]
tc_args
              (Budgets
bg_inner', [Demand]
dmds') = Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand])
go_args (Budgets -> Budgets
incTopBudget Budgets
bg_inner) ([(Type, StrictnessMark, Demand)] -> (Budgets, [Demand]))
-> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand])
forall a b. (a -> b) -> a -> b
$
                                   [Type]
-> [StrictnessMark] -> [Demand] -> [(Type, StrictnessMark, Demand)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Type]
arg_tys (DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc) [Demand]
dmds
              dmd' :: Demand
dmd' = Card
n (() :: Constraint) => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* (Boxity -> [Demand] -> SubDemand
mkProd Boxity
Unboxed ([Demand] -> SubDemand) -> [Demand] -> SubDemand
forall a b. (a -> b) -> a -> b
$! [Demand]
dmds')
              (Budgets
final_bg_inner, Demand
final_dmd)
                  | [Demand]
dmds [Demand] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` Arity
dc_arity
                  , Card -> Bool
isStrict Card
n Bool -> Bool -> Bool
|| StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str_mark
                     -- isStrict: see Note [No lazy, Unboxed demands in demand signature]
                     -- isMarkedStrict: see Note [Unboxing evaluated arguments]
                  , Budgets -> Bool
positiveTopBudget Budgets
bg_inner'
                  , IsRecDataConResult
NonRecursiveOrUnsure <- AnalEnv -> DataCon -> IsRecDataConResult
ae_rec_dc AnalEnv
env DataCon
dc
                     -- See Note [Which types are unboxed?]
                     -- and Note [Demand analysis for recursive data constructors]
                  = (Budgets
bg_inner', Demand
dmd')
                  | Bool
otherwise
                  = (Budgets
bg_inner, Demand -> Demand
trimBoxity Demand
dmd)
          UnboxingDecision Demand
_ -> (Budgets
bg, Demand
dmd)

    add_demands :: [Demand] -> CoreExpr -> CoreExpr
    -- Attach the demands to the outer lambdas of this expression
    add_demands :: [Demand] -> CoreExpr -> CoreExpr
add_demands [] CoreExpr
e = CoreExpr
e
    add_demands (Demand
dmd:[Demand]
dmds) (Lam Var
v CoreExpr
e)
      | Var -> Bool
isTyVar Var
v = Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Var
v ([Demand] -> CoreExpr -> CoreExpr
add_demands (Demand
dmdDemand -> [Demand] -> [Demand]
forall a. a -> [a] -> [a]
:[Demand]
dmds) CoreExpr
e)
      | Bool
otherwise = Var -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam (Var
v Var -> Demand -> Var
`setIdDemandInfo` Demand
dmd) ([Demand] -> CoreExpr -> CoreExpr
add_demands [Demand]
dmds CoreExpr
e)
    add_demands [Demand]
dmds CoreExpr
e = String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"add_demands" ([Demand] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Demand]
dmds SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e)

finaliseLetBoxity
  :: FamInstEnvs
  -> Type                   -- ^ Type of the let-bound Id
  -> Demand                 -- ^ How the Id is used
  -> Demand
-- See Note [Finalising boxity for let-bound Ids]
-- This function is like finaliseArgBoxities, but much simpler because
-- it has no "budget".  It simply unboxes strict demands, and stops
-- when it reaches a lazy one.
finaliseLetBoxity :: FamInstEnvs -> Type -> Demand -> Demand
finaliseLetBoxity FamInstEnvs
env Type
ty Demand
dmd
  = Type -> StrictnessMark -> Demand -> Demand
go Type
ty StrictnessMark
NotMarkedStrict Demand
dmd
  where
    go :: Type -> StrictnessMark -> Demand -> Demand
go Type
ty StrictnessMark
mark dmd :: Demand
dmd@(Card
n :* SubDemand
_) =
      case Bool -> FamInstEnvs -> Type -> Demand -> UnboxingDecision Demand
wantToUnboxArg Bool
False FamInstEnvs
env Type
ty Demand
dmd of
        UnboxingDecision Demand
DropAbsent   -> Demand
dmd
        UnboxingDecision Demand
StopUnboxing -> Demand -> Demand
trimBoxity Demand
dmd
        Unbox DataConPatContext{dcpc_dc :: DataConPatContext -> DataCon
dcpc_dc=DataCon
dc, dcpc_tc_args :: DataConPatContext -> [Type]
dcpc_tc_args=[Type]
tc_args} [Demand]
dmds
          | Card -> Bool
isStrict Card
n Bool -> Bool -> Bool
|| StrictnessMark -> Bool
isMarkedStrict StrictnessMark
mark
          , [Demand]
dmds [Demand] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` DataCon -> Arity
dataConRepArity DataCon
dc
          , let arg_tys :: [Type]
arg_tys = DataCon -> [Type] -> [Type]
dubiousDataConInstArgTys DataCon
dc [Type]
tc_args
                dmds' :: [Demand]
dmds'   = (Type -> StrictnessMark -> Demand -> Demand)
-> [Type] -> [StrictnessMark] -> [Demand] -> [Demand]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
strictZipWith3 Type -> StrictnessMark -> Demand -> Demand
go [Type]
arg_tys (DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc) [Demand]
dmds
          -> Card
n (() :: Constraint) => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* (Boxity -> [Demand] -> SubDemand
mkProd Boxity
Unboxed ([Demand] -> SubDemand) -> [Demand] -> SubDemand
forall a b. (a -> b) -> a -> b
$! [Demand]
dmds')
          | Bool
otherwise
          -> Demand -> Demand
trimBoxity Demand
dmd
        UnboxingDecision Demand
Unlift -> String -> Demand
forall a. String -> a
panic String
"No unlifting in DmdAnal"


{- *********************************************************************
*                                                                      *
                      Fixpoints
*                                                                      *
********************************************************************* -}

-- Recursive bindings
dmdFix :: TopLevelFlag
       -> AnalEnv                            -- Does not include bindings for this binding
       -> SubDemand
       -> [(Id,CoreExpr)]
       -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info
dmdFix :: TopLevelFlag
-> AnalEnv
-> SubDemand
-> [(Var, CoreExpr)]
-> (AnalEnv, WeakDmds, [(Var, CoreExpr)])
dmdFix TopLevelFlag
top_lvl AnalEnv
env SubDemand
let_dmd [(Var, CoreExpr)]
orig_pairs
  = Arity
-> [(Var, CoreExpr)] -> (AnalEnv, WeakDmds, [(Var, CoreExpr)])
loop Arity
1 [(Var, CoreExpr)]
initial_pairs
  where
    -- See Note [Initialising strictness]
    initial_pairs :: [(Var, CoreExpr)]
initial_pairs | AnalEnv -> Bool
ae_virgin AnalEnv
env = [(Var -> DmdSig -> Var
setIdDmdSig Var
id DmdSig
botSig, CoreExpr
rhs) | (Var
id, CoreExpr
rhs) <- [(Var, CoreExpr)]
orig_pairs ]
                  | Bool
otherwise     = [(Var, CoreExpr)]
orig_pairs

    -- If fixed-point iteration does not yield a result we use this instead
    -- See Note [Safe abortion in the fixed-point iteration]
    abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)])
    abort :: (AnalEnv, WeakDmds, [(Var, CoreExpr)])
abort = (AnalEnv
env, WeakDmds
weak_fv', [(Var, CoreExpr)]
zapped_pairs)
      where (WeakDmds
weak_fv, [(Var, CoreExpr)]
pairs') = Bool -> [(Var, CoreExpr)] -> (WeakDmds, [(Var, CoreExpr)])
step Bool
True ([(Var, CoreExpr)] -> [(Var, CoreExpr)]
zapIdDmdSig [(Var, CoreExpr)]
orig_pairs)
            -- Note [Lazy and unleashable free variables]
            weak_fvs :: WeakDmds
weak_fvs = [WeakDmds] -> WeakDmds
forall a. [VarEnv a] -> VarEnv a
plusVarEnvList ([WeakDmds] -> WeakDmds) -> [WeakDmds] -> WeakDmds
forall a b. (a -> b) -> a -> b
$ ((Var, CoreExpr) -> WeakDmds) -> [(Var, CoreExpr)] -> [WeakDmds]
forall a b. (a -> b) -> [a] -> [b]
map (DmdEnv -> WeakDmds
de_fvs (DmdEnv -> WeakDmds)
-> ((Var, CoreExpr) -> DmdEnv) -> (Var, CoreExpr) -> WeakDmds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DmdSig -> DmdEnv
dmdSigDmdEnv (DmdSig -> DmdEnv)
-> ((Var, CoreExpr) -> DmdSig) -> (Var, CoreExpr) -> DmdEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> DmdSig
idDmdSig (Var -> DmdSig)
-> ((Var, CoreExpr) -> Var) -> (Var, CoreExpr) -> DmdSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst) [(Var, CoreExpr)]
pairs'
            weak_fv' :: WeakDmds
weak_fv'     = (Demand -> Demand -> Demand) -> WeakDmds -> WeakDmds -> WeakDmds
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C Demand -> Demand -> Demand
plusDmd WeakDmds
weak_fv (WeakDmds -> WeakDmds) -> WeakDmds -> WeakDmds
forall a b. (a -> b) -> a -> b
$ (Demand -> Demand) -> WeakDmds -> WeakDmds
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (Demand -> Demand -> Demand
forall a b. a -> b -> a
const Demand
topDmd) WeakDmds
weak_fvs
            zapped_pairs :: [(Var, CoreExpr)]
zapped_pairs = [(Var, CoreExpr)] -> [(Var, CoreExpr)]
zapIdDmdSig [(Var, CoreExpr)]
pairs'

    -- The fixed-point varies the idDmdSig field of the binders, and terminates if that
    -- annotation does not change any more.
    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)])
    loop :: Arity
-> [(Var, CoreExpr)] -> (AnalEnv, WeakDmds, [(Var, CoreExpr)])
loop Arity
n [(Var, CoreExpr)]
pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)
                   --                                     | (id,_)<- pairs]) $
                   Arity
-> [(Var, CoreExpr)] -> (AnalEnv, WeakDmds, [(Var, CoreExpr)])
loop' Arity
n [(Var, CoreExpr)]
pairs

    loop' :: Arity
-> [(Var, CoreExpr)] -> (AnalEnv, WeakDmds, [(Var, CoreExpr)])
loop' Arity
n [(Var, CoreExpr)]
pairs
      | Bool
found_fixpoint = (AnalEnv
final_anal_env, WeakDmds
weak_fv, [(Var, CoreExpr)]
pairs')
      | Arity
n Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
10        = (AnalEnv, WeakDmds, [(Var, CoreExpr)])
abort
      | Bool
otherwise      = Arity
-> [(Var, CoreExpr)] -> (AnalEnv, WeakDmds, [(Var, CoreExpr)])
loop (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) [(Var, CoreExpr)]
pairs'
      where
        found_fixpoint :: Bool
found_fixpoint    = ((Var, CoreExpr) -> DmdSig) -> [(Var, CoreExpr)] -> [DmdSig]
forall a b. (a -> b) -> [a] -> [b]
map (Var -> DmdSig
idDmdSig (Var -> DmdSig)
-> ((Var, CoreExpr) -> Var) -> (Var, CoreExpr) -> DmdSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst) [(Var, CoreExpr)]
pairs' [DmdSig] -> [DmdSig] -> Bool
forall a. Eq a => a -> a -> Bool
== ((Var, CoreExpr) -> DmdSig) -> [(Var, CoreExpr)] -> [DmdSig]
forall a b. (a -> b) -> [a] -> [b]
map (Var -> DmdSig
idDmdSig (Var -> DmdSig)
-> ((Var, CoreExpr) -> Var) -> (Var, CoreExpr) -> DmdSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst) [(Var, CoreExpr)]
pairs
        first_round :: Bool
first_round       = Arity
n Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
        (WeakDmds
weak_fv, [(Var, CoreExpr)]
pairs') = Bool -> [(Var, CoreExpr)] -> (WeakDmds, [(Var, CoreExpr)])
step Bool
first_round [(Var, CoreExpr)]
pairs
        final_anal_env :: AnalEnv
final_anal_env    = TopLevelFlag -> AnalEnv -> [Var] -> AnalEnv
extendAnalEnvs TopLevelFlag
top_lvl AnalEnv
env (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
pairs')

    step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])
    step :: Bool -> [(Var, CoreExpr)] -> (WeakDmds, [(Var, CoreExpr)])
step Bool
first_round [(Var, CoreExpr)]
pairs = (WeakDmds
weak_fv, [(Var, CoreExpr)]
pairs')
      where
        -- In all but the first iteration, delete the virgin flag
        start_env :: AnalEnv
start_env | Bool
first_round = AnalEnv
env
                  | Bool
otherwise   = AnalEnv -> AnalEnv
nonVirgin AnalEnv
env

        start :: (AnalEnv, WeakDmds)
start = (TopLevelFlag -> AnalEnv -> [Var] -> AnalEnv
extendAnalEnvs TopLevelFlag
top_lvl AnalEnv
start_env (((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
pairs), WeakDmds
forall a. VarEnv a
emptyVarEnv)

        !((AnalEnv
_,!WeakDmds
weak_fv), ![(Var, CoreExpr)]
pairs') = ((AnalEnv, WeakDmds)
 -> (Var, CoreExpr) -> ((AnalEnv, WeakDmds), (Var, CoreExpr)))
-> (AnalEnv, WeakDmds)
-> [(Var, CoreExpr)]
-> ((AnalEnv, WeakDmds), [(Var, CoreExpr)])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (AnalEnv, WeakDmds)
-> (Var, CoreExpr) -> ((AnalEnv, WeakDmds), (Var, CoreExpr))
my_downRhs (AnalEnv, WeakDmds)
start [(Var, CoreExpr)]
pairs
                -- mapAccumL: Use the new signature to do the next pair
                -- The occurrence analyser has arranged them in a good order
                -- so this can significantly reduce the number of iterations needed

        my_downRhs :: (AnalEnv, WeakDmds)
-> (Var, CoreExpr) -> ((AnalEnv, WeakDmds), (Var, CoreExpr))
my_downRhs (AnalEnv
env, WeakDmds
weak_fv) (Var
id,CoreExpr
rhs)
          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $
            ((AnalEnv
env', WeakDmds
weak_fv'), (Var
id', CoreExpr
rhs'))
          where
            !(!AnalEnv
env', !WeakDmds
weak_fv1, !Var
id', !CoreExpr
rhs') = TopLevelFlag
-> RecFlag
-> AnalEnv
-> SubDemand
-> Var
-> CoreExpr
-> (AnalEnv, WeakDmds, Var, CoreExpr)
dmdAnalRhsSig TopLevelFlag
top_lvl RecFlag
Recursive AnalEnv
env SubDemand
let_dmd Var
id CoreExpr
rhs
            !weak_fv' :: WeakDmds
weak_fv'                    = (Demand -> Demand -> Demand) -> WeakDmds -> WeakDmds -> WeakDmds
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C Demand -> Demand -> Demand
plusDmd WeakDmds
weak_fv WeakDmds
weak_fv1

    zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
    zapIdDmdSig :: [(Var, CoreExpr)] -> [(Var, CoreExpr)]
zapIdDmdSig [(Var, CoreExpr)]
pairs = [(Var -> DmdSig -> Var
setIdDmdSig Var
id DmdSig
nopSig, CoreExpr
rhs) | (Var
id, CoreExpr
rhs) <- [(Var, CoreExpr)]
pairs ]

{- Note [Safe abortion in the fixed-point iteration]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Fixed-point iteration may fail to terminate. But we cannot simply give up and
return the environment and code unchanged! We still need to do one additional
round, for two reasons:

 * To get information on used free variables (both lazy and strict!)
   (see Note [Lazy and unleashable free variables])
 * To ensure that all expressions have been traversed at least once, and any left-over
   strictness annotations have been updated.

This final iteration does not add the variables to the strictness signature
environment, which effectively assigns them 'nopSig' (see "getStrictness")

Note [Trimming a demand to a type]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are two reasons we sometimes trim a demand to match a type.
  1. GADTs
  2. Recursive products and widening

More on both below.  But the botttom line is: we really don't want to
have a binder whose demand is more deeply-nested than its type
"allows". So in findBndrDmd we call trimToType and findTypeShape to
trim the demand on the binder to a form that matches the type

Now to the reasons. For (1) consider
  f :: a -> Bool
  f x = case ... of
          A g1 -> case (x |> g1) of (p,q) -> ...
          B    -> error "urk"

where A,B are the constructors of a GADT.  We'll get a 1P(L,L) demand
on x from the A branch, but that's a stupid demand for x itself, which
has type 'a'. Indeed we get ASSERTs going off (notably in
splitUseProdDmd, #8569).

For (2) consider
  data T = MkT Int T    -- A recursive product
  f :: Int -> T -> Int
  f 0 _         = 0
  f _ (MkT n t) = f n t

Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))).
Notice that this happens because T is a product type, and is recrusive.
If we are not careful, we'll fail to iterate to a fixpoint in dmdFix,
and bale out entirely, which is inefficient and over-conservative.

Worse, as we discovered in #18304, the size of the usages we compute
can grow /exponentially/, so even 10 iterations costs far too much.
Especially since we then discard the result.

To avoid this we use the same findTypeShape function as for (1), but
arrange that it trims the demand if it encounters the same type constructor
twice (or three times, etc).  We use our standard RecTcChecker mechanism
for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape.

This is usually call "widening".  We could do it just in dmdFix, but
since are doing this findTypeShape business /anyway/ because of (1),
and it has all the right information to hand, it's extremely
convenient to do it there.

-}

{- *********************************************************************
*                                                                      *
                 Strictness signatures and types
*                                                                      *
********************************************************************* -}

noArgsDmdType :: DmdEnv -> DmdType
noArgsDmdType :: DmdEnv -> DmdType
noArgsDmdType DmdEnv
dmd_env = DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
dmd_env []

coercionDmdEnv :: Coercion -> DmdEnv
coercionDmdEnv :: Coercion -> DmdEnv
coercionDmdEnv Coercion
co = [Coercion] -> DmdEnv
coercionsDmdEnv [Coercion
co]

coercionsDmdEnv :: [Coercion] -> DmdEnv
coercionsDmdEnv :: [Coercion] -> DmdEnv
coercionsDmdEnv [Coercion]
cos
  = WeakDmds -> DmdEnv
mkTermDmdEnv (WeakDmds -> DmdEnv) -> WeakDmds -> DmdEnv
forall a b. (a -> b) -> a -> b
$ (Var -> Demand) -> VarEnv Var -> WeakDmds
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (Demand -> Var -> Demand
forall a b. a -> b -> a
const Demand
topDmd) (VarEnv Var -> WeakDmds) -> VarEnv Var -> WeakDmds
forall a b. (a -> b) -> a -> b
$ VarSet -> VarEnv Var
forall a. UniqSet a -> UniqFM a a
getUniqSet (VarSet -> VarEnv Var) -> VarSet -> VarEnv Var
forall a b. (a -> b) -> a -> b
$ [Coercion] -> VarSet
coVarsOfCos [Coercion]
cos
  -- The VarSet from coVarsOfCos is really a VarEnv Var

addVarDmd :: DmdType -> Var -> Demand -> DmdType
addVarDmd :: DmdType -> Var -> Demand -> DmdType
addVarDmd (DmdType DmdEnv
fv [Demand]
ds) Var
var Demand
dmd
  = DmdEnv -> [Demand] -> DmdType
DmdType (DmdEnv -> Var -> Demand -> DmdEnv
addVarDmdEnv DmdEnv
fv Var
var Demand
dmd) [Demand]
ds

addWeakFVs :: DmdType -> WeakDmds -> DmdType
addWeakFVs :: DmdType -> WeakDmds -> DmdType
addWeakFVs DmdType
dmd_ty WeakDmds
weak_fvs
  = DmdType
dmd_ty DmdType -> DmdEnv -> DmdType
`plusDmdType` WeakDmds -> DmdEnv
mkTermDmdEnv WeakDmds
weak_fvs
        -- Using plusDmdType (rather than just plus'ing the envs)
        -- is vital.  Consider
        --      let f = \x -> (x,y)
        --      in  error (f 3)
        -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L
        -- demand with the bottom coming up from 'error'
        --
        -- I got a loop in the fixpointer without this, due to an interaction
        -- with the weak_fv filtering in dmdAnalRhsSig.  Roughly, it was
        --      letrec f n x
        --          = letrec g y = x `fatbar`
        --                         letrec h z = z + ...g...
        --                         in h (f (n-1) x)
        --      in ...
        -- In the initial iteration for f, f=Bot
        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it
        -- places on its free variables.  Suppose it places none.  Then the
        --      x `fatbar` ...call to h...
        -- will give a x->V demand for x.  That turns into a L demand for x,
        -- which floats out of the defn for h.  Without the modifyEnv, that
        -- L demand doesn't get both'd with the Bot coming up from the inner
        -- call to f.  So we just get an L demand for x for g.

setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]
setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]
setBndrsDemandInfo (Var
b:[Var]
bs) [Demand]
ds
  | Var -> Bool
isTyVar Var
b = Var
b Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: HasCallStack => [Var] -> [Demand] -> [Var]
[Var] -> [Demand] -> [Var]
setBndrsDemandInfo [Var]
bs [Demand]
ds
setBndrsDemandInfo (Var
b:[Var]
bs) (Demand
d:[Demand]
ds) =
    let !new_info :: Var
new_info = Var -> Demand -> Var
setIdDemandInfo Var
b Demand
d
        !vars :: [Var]
vars = HasCallStack => [Var] -> [Demand] -> [Var]
[Var] -> [Demand] -> [Var]
setBndrsDemandInfo [Var]
bs [Demand]
ds
    in Var
new_info Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
vars
setBndrsDemandInfo [] [Demand]
ds = Bool -> [Var] -> [Var]
forall a. HasCallStack => Bool -> a -> a
assert ([Demand] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Demand]
ds) []
setBndrsDemandInfo [Var]
bs [Demand]
_  = String -> SDoc -> [Var]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"setBndrsDemandInfo" ([Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
bs)

annotateLamIdBndr :: AnalEnv
                  -> DmdType    -- Demand type of body
                  -> Id         -- Lambda binder
                  -> WithDmdType Id  -- Demand type of lambda
                                     -- and binder annotated with demand

annotateLamIdBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var
annotateLamIdBndr AnalEnv
env DmdType
dmd_ty Var
id
-- For lambdas we add the demand to the argument demands
-- Only called for Ids
  = Bool -> WithDmdType Var -> WithDmdType Var
forall a. HasCallStack => Bool -> a -> a
assert (Var -> Bool
isId Var
id) (WithDmdType Var -> WithDmdType Var)
-> WithDmdType Var -> WithDmdType Var
forall a b. (a -> b) -> a -> b
$
    -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $
    DmdType -> Var -> WithDmdType Var
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
main_ty Var
new_id
  where
    new_id :: Var
new_id  = Var -> Demand -> Var
setIdDemandInfo Var
id Demand
dmd
    main_ty :: DmdType
main_ty = Demand -> DmdType -> DmdType
addDemand Demand
dmd DmdType
dmd_ty'
    WithDmdType DmdType
dmd_ty' Demand
dmd = AnalEnv -> DmdType -> Var -> WithDmdType Demand
findBndrDmd AnalEnv
env DmdType
dmd_ty Var
id

{- Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At one point we disabled strictness for NOINLINE functions, on the
grounds that they should be entirely opaque.  But that lost lots of
useful semantic strictness information, so now we analyse them like
any other function, and pin strictness information on them.

That in turn forces us to worker/wrapper them; see
Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.


Note [Lazy and unleashable free variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We put the strict and once-used FVs in the DmdType of the Id, so
that at its call sites we unleash demands on its strict fvs.
An example is 'roll' in imaginary/wheel-sieve2
Something like this:
        roll x = letrec
                     go y = if ... then roll (x-1) else x+1
                 in
                 go ms
We want to see that roll is strict in x, which is because
go is called.   So we put the DmdEnv for x in go's DmdType.

Another example:

        f :: Int -> Int -> Int
        f x y = let t = x+1
            h z = if z==0 then t else
                  if z==1 then x+1 else
                  x + h (z-1)
        in h y

Calling h does indeed evaluate x, but we can only see
that if we unleash a demand on x at the call site for t.

Incidentally, here's a place where lambda-lifting h would
lose the cigar --- we couldn't see the joint strictness in t/x

        ON THE OTHER HAND

We don't want to put *all* the fv's from the RHS into the
DmdType. Because

 * it makes the strictness signatures larger, and hence slows down fixpointing

and

 * it is useless information at the call site anyways:
   For lazy, used-many times fv's we will never get any better result than
   that, no matter how good the actual demand on the function at the call site
   is (unless it is always absent, but then the whole binder is useless).

Therefore we exclude lazy multiple-used fv's from the environment in the
DmdType.

But now the signature lies! (Missing variables are assumed to be absent.) To
make up for this, the code that analyses the binding keeps the demand on those
variable separate (usually called "weak_fv") and adds it to the demand of the
whole binding later.

What if we decide _not_ to store a strictness signature for a binding at all, as
we do when aborting a fixed-point iteration? The we risk losing the information
that the strict variables are being used. In that case, we take all free variables
mentioned in the (unsound) strictness signature, conservatively approximate the
demand put on them (topDmd), and add that to the "weak_fv" returned by "dmdFix".


************************************************************************
*                                                                      *
\subsection{Strictness signatures}
*                                                                      *
************************************************************************
-}


data AnalEnv = AE
  { AnalEnv -> DmdAnalOpts
ae_opts      :: !DmdAnalOpts
  -- ^ Analysis options
  , AnalEnv -> SigEnv
ae_sigs      :: !SigEnv
  , AnalEnv -> Bool
ae_virgin    :: !Bool
  -- ^ True on first iteration only. See Note [Initialising strictness]
  , AnalEnv -> FamInstEnvs
ae_fam_envs  :: !FamInstEnvs
  , AnalEnv -> DataCon -> IsRecDataConResult
ae_rec_dc    :: DataCon -> IsRecDataConResult
  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
  }

        -- We use the se_env to tell us whether to
        -- record info about a variable in the DmdEnv
        -- We do so if it's a LocalId, but not top-level
        --
        -- The DmdEnv gives the demand on the free vars of the function
        -- when it is given enough args to satisfy the strictness signature

type SigEnv = VarEnv (DmdSig, TopLevelFlag)

instance Outputable AnalEnv where
  ppr :: AnalEnv -> SDoc
ppr AnalEnv
env = String -> SDoc
text String
"AE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
         [ String -> SDoc
text String
"ae_virgin =" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AnalEnv -> Bool
ae_virgin AnalEnv
env)
         , String -> SDoc
text String
"ae_sigs =" SDoc -> SDoc -> SDoc
<+> SigEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (AnalEnv -> SigEnv
ae_sigs AnalEnv
env)
         ])

emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv
emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv
emptyAnalEnv DmdAnalOpts
opts FamInstEnvs
fam_envs
    = AE { ae_opts :: DmdAnalOpts
ae_opts         = DmdAnalOpts
opts
         , ae_sigs :: SigEnv
ae_sigs         = SigEnv
emptySigEnv
         , ae_virgin :: Bool
ae_virgin       = Bool
True
         , ae_fam_envs :: FamInstEnvs
ae_fam_envs     = FamInstEnvs
fam_envs
         , ae_rec_dc :: DataCon -> IsRecDataConResult
ae_rec_dc       = (DataCon -> IsRecDataConResult) -> DataCon -> IsRecDataConResult
forall k a. Uniquable k => (k -> a) -> k -> a
memoiseUniqueFun (FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult
isRecDataCon FamInstEnvs
fam_envs IntWithInf
3)
         }

-- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun
-- binding. Part of the mechanism that detects
-- Note [Do not strictify a DFun's parameter dictionaries].
enterDFun :: CoreBind -> AnalEnv -> AnalEnv
enterDFun :: Bind Var -> AnalEnv -> AnalEnv
enterDFun Bind Var
bind AnalEnv
env
  | (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Var -> Bool
isDFunId (Bind Var -> [Var]
forall b. Bind b -> [b]
bindersOf Bind Var
bind)
  = AnalEnv
env { ae_opts :: DmdAnalOpts
ae_opts = (AnalEnv -> DmdAnalOpts
ae_opts AnalEnv
env) { dmd_strict_dicts :: Bool
dmd_strict_dicts = Bool
False } }
  | Bool
otherwise
  = AnalEnv
env

emptySigEnv :: SigEnv
emptySigEnv :: SigEnv
emptySigEnv = SigEnv
forall a. VarEnv a
emptyVarEnv

-- | Extend an environment with the strictness sigs attached to the Ids
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Var] -> AnalEnv
extendAnalEnvs TopLevelFlag
top_lvl AnalEnv
env [Var]
vars
  = AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = TopLevelFlag -> SigEnv -> [Var] -> SigEnv
extendSigEnvs TopLevelFlag
top_lvl (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) [Var]
vars }

extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
extendSigEnvs :: TopLevelFlag -> SigEnv -> [Var] -> SigEnv
extendSigEnvs TopLevelFlag
top_lvl SigEnv
sigs [Var]
vars
  = SigEnv -> [(Var, (DmdSig, TopLevelFlag))] -> SigEnv
forall a. VarEnv a -> [(Var, a)] -> VarEnv a
extendVarEnvList SigEnv
sigs [ (Var
var, (Var -> DmdSig
idDmdSig Var
var, TopLevelFlag
top_lvl)) | Var
var <- [Var]
vars]

extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv
extendAnalEnv :: TopLevelFlag -> AnalEnv -> Var -> DmdSig -> AnalEnv
extendAnalEnv TopLevelFlag
top_lvl AnalEnv
env Var
var DmdSig
sig
  = AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = TopLevelFlag -> SigEnv -> Var -> DmdSig -> SigEnv
extendSigEnv TopLevelFlag
top_lvl (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) Var
var DmdSig
sig }

extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv
extendSigEnv :: TopLevelFlag -> SigEnv -> Var -> DmdSig -> SigEnv
extendSigEnv TopLevelFlag
top_lvl SigEnv
sigs Var
var DmdSig
sig = SigEnv -> Var -> (DmdSig, TopLevelFlag) -> SigEnv
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv SigEnv
sigs Var
var (DmdSig
sig, TopLevelFlag
top_lvl)

lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag)
lookupSigEnv :: AnalEnv -> Var -> Maybe (DmdSig, TopLevelFlag)
lookupSigEnv AnalEnv
env Var
id = SigEnv -> Var -> Maybe (DmdSig, TopLevelFlag)
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) Var
id

addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv
addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv
addInScopeAnalEnv AnalEnv
env Var
id = AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = SigEnv -> Var -> SigEnv
forall a. VarEnv a -> Var -> VarEnv a
delVarEnv (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) Var
id }

addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv
addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv
addInScopeAnalEnvs AnalEnv
env [Var]
ids = AnalEnv
env { ae_sigs :: SigEnv
ae_sigs = SigEnv -> [Var] -> SigEnv
forall a. VarEnv a -> [Var] -> VarEnv a
delVarEnvList (AnalEnv -> SigEnv
ae_sigs AnalEnv
env) [Var]
ids }

nonVirgin :: AnalEnv -> AnalEnv
nonVirgin :: AnalEnv -> AnalEnv
nonVirgin AnalEnv
env = AnalEnv
env { ae_virgin :: Bool
ae_virgin = Bool
False }

findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
-- Return the demands on the Ids in the [Var]
findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
findBndrsDmds AnalEnv
env DmdType
dmd_ty [Var]
bndrs
  = DmdType -> [Var] -> WithDmdType [Demand]
go DmdType
dmd_ty [Var]
bndrs
  where
    go :: DmdType -> [Var] -> WithDmdType [Demand]
go DmdType
dmd_ty []  = DmdType -> [Demand] -> WithDmdType [Demand]
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
dmd_ty []
    go DmdType
dmd_ty (Var
b:[Var]
bs)
      | Var -> Bool
isId Var
b    = let WithDmdType DmdType
dmd_ty1 [Demand]
dmds = DmdType -> [Var] -> WithDmdType [Demand]
go DmdType
dmd_ty [Var]
bs
                        WithDmdType DmdType
dmd_ty2 Demand
dmd  = AnalEnv -> DmdType -> Var -> WithDmdType Demand
findBndrDmd AnalEnv
env DmdType
dmd_ty1 Var
b
                    in DmdType -> [Demand] -> WithDmdType [Demand]
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
dmd_ty2  (Demand
dmd Demand -> [Demand] -> [Demand]
forall a. a -> [a] -> [a]
: [Demand]
dmds)
      | Bool
otherwise = DmdType -> [Var] -> WithDmdType [Demand]
go DmdType
dmd_ty [Var]
bs

findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand
-- See Note [Trimming a demand to a type]
findBndrDmd :: AnalEnv -> DmdType -> Var -> WithDmdType Demand
findBndrDmd AnalEnv
env DmdType
dmd_ty Var
id
  = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $
    DmdType -> Demand -> WithDmdType Demand
forall a. DmdType -> a -> WithDmdType a
WithDmdType DmdType
dmd_ty' Demand
dmd'
  where
    dmd' :: Demand
dmd' = Demand -> Demand
strictify (Demand -> Demand) -> Demand -> Demand
forall a b. (a -> b) -> a -> b
$
           Demand -> TypeShape -> Demand
trimToType Demand
starting_dmd (FamInstEnvs -> Type -> TypeShape
findTypeShape FamInstEnvs
fam_envs Type
id_ty)

    (DmdType
dmd_ty', Demand
starting_dmd) = DmdType -> Var -> (DmdType, Demand)
peelFV DmdType
dmd_ty Var
id

    id_ty :: Type
id_ty = Var -> Type
idType Var
id

    strictify :: Demand -> Demand
strictify Demand
dmd
      -- See Note [Making dictionary parameters strict]
      -- and Note [Do not strictify a DFun's parameter dictionaries]
      | DmdAnalOpts -> Bool
dmd_strict_dicts (AnalEnv -> DmdAnalOpts
ae_opts AnalEnv
env)
      = Type -> Demand -> Demand
strictifyDictDmd Type
id_ty Demand
dmd
      | Bool
otherwise
      = Demand
dmd

    fam_envs :: FamInstEnvs
fam_envs = AnalEnv -> FamInstEnvs
ae_fam_envs AnalEnv
env

{- Note [Bringing a new variable into scope]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f x = blah
   g = ...(\f. ...f...)...

In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,
not the top-level `f` (which will be in `ae_sigs`).  So it's very important
to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.
Otherwise chaos results (#22718).

Note [Making dictionary parameters strict]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?

* Generally CBV is more efficient.

* A datatype dictionary is always non-bottom and never takes much work to
  compute.  E.g. a DFun from an instance decl always returns a dictionary
  record immediately.  See DFunUnfolding in CoreSyn.
  See also Note [Recursive superclasses] in TcInstDcls.

See #17758 for more background and perf numbers.

Wrinkles:

* A newtype dictionary is *not* always non-bottom.  E.g.
      class C a where op :: a -> a
      instance C Int where op = error "urk"
  Now a value of type (C Int) is just a newtype wrapper (a cast) around
  the error thunk.  Don't strictify these!

* Strictifying DFuns risks destroying the invariant that DFuns never take much
  work to compute, so we don't do it.
  See Note [Do not strictify a DFun's parameter dictionaries] for details.

* Although worker/wrapper *could* unbox strictly used dictionaries, we do not do
  so; see Note [Do not unbox class dictionaries].

The implementation is extremly simple: just make the strictness
analyser strictify the demand on a dictionary binder in
'findBndrDmd' if the binder does not belong to a DFun.

Note [Do not strictify a DFun's parameter dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The typechecker can tie recursive knots involving (non-recursive) DFuns, so
we must not strictify a DFun's parameter dictionaries (#22549).
T22549 has an example involving undecidable instances that <<loop>>s when we
strictify the DFun of, e.g., `$fEqSeqT`:

  Main.$fEqSeqT
    = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) ->
        GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad)
                                     ($c/= @m @a $dEq $dMonad)

  Rec {
    $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity
    $dEq_b = ... $dEq_a ... <another strict context due to DFun>
  }

If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a
giant, <<loop>>ing thunk.

To prevent that, we never strictify dictionary params when inside a DFun.
That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun.

See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather
similar example in #20836. We may never speculate *arguments* of (recursive)
DFun calls, likewise we should not mark *formal parameters* of recursive DFuns
as strict.

Note [Initialising strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See section 9.2 (Finding fixpoints) of the paper.

Our basic plan is to initialise the strictness of each Id in a
recursive group to "bottom", and find a fixpoint from there.  However,
this group B might be inside an *enclosing* recursive group A, in
which case we'll do the entire fixpoint shebang on for each iteration
of A. This can be illustrated by the following example:

Example:

  f [] = []
  f (x:xs) = let g []     = f xs
                 g (y:ys) = y+1 : g ys
              in g (h x)

At each iteration of the fixpoint for f, the analyser has to find a
fixpoint for the enclosed function g. In the meantime, the demand
values for g at each iteration for f are *greater* than those we
encountered in the previous iteration for f. Therefore, we can begin
the fixpoint for g not with the bottom value but rather with the
result of the previous analysis. I.e., when beginning the fixpoint
process for g, we can start from the demand signature computed for g
previously and attached to the binding occurrence of g.

To speed things up, we initialise each iteration of A (the enclosing
one) from the result of the last one, which is neatly recorded in each
binder.  That way we make use of earlier iterations of the fixpoint
algorithm. (Cunning plan.)

But on the *first* iteration we want to *ignore* the current strictness
of the Id, and start from "bottom".  Nowadays the Id can have a current
strictness, because interface files record strictness for nested bindings.
To know when we are in the first iteration, we look at the ae_virgin
field of the AnalEnv.


Note [Final Demand Analyser run]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some of the information that the demand analyser determines is not always
preserved by the simplifier.  For example, the simplifier will happily rewrite
  \y [Demand=MU] let x = y in x + x
to
  \y [Demand=MU] y + y
which is quite a lie: Now y occurs more than just once.

The once-used information is (currently) only used by the code
generator, though.  So:

 * We zap the used-once info in the worker-wrapper;
   see Note [Zapping Used Once info in WorkWrap] in
   GHC.Core.Opt.WorkWrap.
   If it's not reliable, it's better not to have it at all.

 * Just before TidyCore, we add a pass of the demand analyser,
      but WITHOUT subsequent worker/wrapper and simplifier,
   right before TidyCore.  See SimplCore.getCoreToDo.

   This way, correct information finds its way into the module interface
   (strictness signatures!) and the code generator (single-entry thunks!)

Note that, in contrast, the single-call information (CM(..)) /can/ be
relied upon, as the simplifier tends to be very careful about not
duplicating actual function calls.

Also see #11731.

Note [Space Leaks in Demand Analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Ticket: #15455
MR: !5399

In the past the result of demand analysis was not forced until the whole module
had finished being analysed. In big programs, this led to a big build up of thunks
which were all ultimately forced at the end of the analysis.

This was because the return type of the analysis was a lazy pair:
  dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr)
To avoid space leaks we added extra bangs to evaluate the DmdType component eagerly; but
we were never sure we had added enough.
The easiest way to systematically fix this was to use a strict pair type for the
return value of the analysis so that we can be more confident that the result
is incrementally computed rather than all at the end.

A second, only loosely related point is that
the updating of Ids was not forced because the result of updating
an Id was placed into a lazy field in CoreExpr. This meant that until the end of
demand analysis, the unforced Ids would retain the DmdEnv which the demand information
was fetch from. Now we are quite careful to force Ids before putting them
back into core expressions so that we can garbage-collect the environments more eagerly.
For example see the `Case` branch of `dmdAnal'` where `case_bndr'` is forced
or `dmdAnalSumAlt`.

The net result of all these improvements is the peak live memory usage of compiling
jsaddle-dom decreases about 4GB (from 6.5G to 2.5G). A bunch of bytes allocated benchmarks also
decrease because we allocate a lot fewer thunks which we immediately overwrite and
also runtime for the pass is faster! Overall, good wins.

-}