    {-
    (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.Types.Demand   -- All of it

    import GHC.Core
    import GHC.Core.DataCon
    import GHC.Core.Utils
    import GHC.Core.TyCon
    import GHC.Core.Type
    import GHC.Core.Predicate( isEqualityClass, isCTupleClass )
    import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
    import GHC.Core.Coercion ( Coercion )
    import GHC.Core.TyCo.FVs     ( coVarsOfCos )
    import GHC.Core.TyCo.Compare ( eqType )
    import GHC.Core.Multiplicity ( scaledThing )
    import GHC.Core.FamInstEnv
    import GHC.Core.Opt.Arity ( typeArity )
    import GHC.Core.Opt.WorkWrap.Utils

    import GHC.Builtin.PrimOps
    import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )

    import GHC.Types.Unique.Set
    import GHC.Types.Unique.MemoFun
    import GHC.Types.RepType
    import GHC.Types.ForeignCall ( isSafeForeignCall )
    import GHC.Types.Id
    import GHC.Types.Var.Env
    import GHC.Types.Var.Set
    import GHC.Types.Basic

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

    import Data.List        ( mapAccumL )

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

    -- | Options for the demand analysis
    data DmdAnalOpts = DmdAnalOpts
       { DmdAnalOpts -> Bool
    dmd_strict_dicts    :: !Bool
       -- ^ Value of `-fdicts-strict` (on by default).
       -- When set, all functons are implicitly strict in dictionary args.
       , DmdAnalOpts -> Bool
    dmd_do_boxity       :: !Bool
       -- ^ Governs whether the analysis should update boxity signatures.
       -- See Note [Don't change boxity without worker/wrapper].
       , DmdAnalOpts -> Arity
    dmd_unbox_width     :: !Int
       -- ^ Value of `-fdmd-unbox-width`.
       -- See Note [Unboxed demand on function bodies returning small products]
       , DmdAnalOpts -> Arity
    dmd_max_worker_args :: !Int
       -- ^ Value of `-fmax-worker-args`.
       -- Don't unbox anything if we end up with more than this many args.
       }

    -- 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 laziness (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 Id
    b:CoreProgram
    bs) = WithDmdType (DmdResult (Bind Id) CoreProgram)
    -> WithDmdType CoreProgram
    forall b. WithDmdType (DmdResult b [b]) -> WithDmdType [b]
    cons_up (WithDmdType (DmdResult (Bind Id) CoreProgram)
     -> WithDmdType CoreProgram)
    -> WithDmdType (DmdResult (Bind Id) CoreProgram)
    -> WithDmdType CoreProgram
    forall a b. (a -> b) -> a -> b
    $ TopLevelFlag
    -> AnalEnv
    -> SubDemand
    -> Bind Id
    -> (AnalEnv -> WithDmdType CoreProgram)
    -> WithDmdType (DmdResult (Bind Id) CoreProgram)
    forall a.
    TopLevelFlag
    -> AnalEnv
    -> SubDemand
    -> Bind Id
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    dmdAnalBind TopLevelFlag
    TopLevel AnalEnv
    env SubDemand
    topSubDmd Bind Id
    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 -> [Id] -> DmdEnv
    keep_alive_roots AnalEnv
    env' (Bind Id -> [Id]
    forall b. Bind b -> [b]
    bindersOf Bind Id
    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 -> [Id] -> DmdEnv
    keep_alive_roots AnalEnv
    env [Id]
    ids = [DmdEnv] -> DmdEnv
    plusDmdEnvs ((Id -> DmdEnv) -> [Id] -> [DmdEnv]
    forall a b. (a -> b) -> [a] -> [b]
    map (AnalEnv -> Id -> DmdEnv
    demandRoot AnalEnv
    env) ((Id -> Bool) -> [Id] -> [Id]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Id -> Bool
    is_root [Id]
    ids))

        is_root :: Id -> Bool
        is_root :: Id -> Bool
    is_root Id
    id = Id -> Bool
    isExportedId Id
    id Bool -> Bool -> Bool
    || Id -> VarSet -> Bool
    elemVarSet Id
    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 -> Id -> DmdEnv
    demandRoot AnalEnv
    env Id
    id = (DmdEnv, CoreExpr) -> DmdEnv
    forall a b. (a, b) -> a
    fst (AnalEnv -> Demand -> CoreExpr -> (DmdEnv, CoreExpr)
    dmdAnalStar AnalEnv
    env Demand
    topDmd (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    id))

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

    demandRootSet :: AnalEnv -> IdSet -> DmdEnv
    demandRootSet :: AnalEnv -> VarSet -> DmdEnv
    demandRootSet AnalEnv
    env VarSet
    ids = AnalEnv -> [Id] -> DmdEnv
    demandRoots AnalEnv
    env (VarSet -> [Id]
    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 :: Id -> Bool
    isInterestingTopLevelFn Id
    id = Type -> Arity
    typeArity (Id -> Type
    idType Id
    id) Arity -> Arity -> Bool
    forall a. Ord a => a -> a -> Bool
    > 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 [Don't change boxity without worker/wrapper]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider (T21754)
      f n = n+1
      {-# NOINLINE f #-}
    With `-fno-worker-wrapper`, we should not give `f` a boxity signature that says
    that it unboxes its argument! Client modules would never be able to cancel away
    the box for n. Likewise we shouldn't give `f` the CPR property.

    Similarly, in the last run of DmdAnal before codegen (which does not have a
    worker/wrapper phase) we should not change boxity in any way. Remember: an
    earlier result of the demand analyser, complete with worker/wrapper, has aleady
    given a demand signature (with boxity info) to the function.
    (The "last run" is mainly there to attach demanded-once info to let-bindings.)

    In general, we should not run Note [Boxity analysis] unless worker/wrapper
    follows to exploit the boxity and make sure that calling modules can observe the
    reported boxity.

    Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only
    if worker/wrapper follows after DmdAnal. If it is not set, and the signature
    is not subject to Note [Boxity for bottoming functions], DmdAnal tries
    to transfer over the previous boxity to the new demand signature, in
    `setIdDmdAndBoxSig`.

    Why isn't CprAnal configured with a similar flag? Because if we aren't going to
    do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline)

    It might be surprising that we only try to preserve *arg* boxity, not boxity on
    FVs. But FV demands won't make it into interface files anyway, so it's a waste
    of energy.
    Besides, W/W zaps the `DmdEnv` portion of a signature, so we don't know the old
    boxity to begin with; see Note [Zapping DmdEnv after Demand Analyzer].

    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 @LC(L,C(M,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 Id
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    dmdAnalBind TopLevelFlag
    top_lvl AnalEnv
    env SubDemand
    dmd Bind Id
    bind AnalEnv -> WithDmdType a
    anal_body = case Bind Id
    bind of
      NonRec Id
    id CoreExpr
    rhs
        | TopLevelFlag -> Id -> Bool
    useLetUp TopLevelFlag
    top_lvl Id
    id
        -> TopLevelFlag
    -> AnalEnv
    -> Id
    -> CoreExpr
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    forall a.
    TopLevelFlag
    -> AnalEnv
    -> Id
    -> CoreExpr
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    dmdAnalBindLetUp   TopLevelFlag
    top_lvl AnalEnv
    env_rhs     Id
    id CoreExpr
    rhs AnalEnv -> WithDmdType a
    anal_body
      Bind Id
    _ -> TopLevelFlag
    -> AnalEnv
    -> SubDemand
    -> Bind Id
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    forall a.
    TopLevelFlag
    -> AnalEnv
    -> SubDemand
    -> Bind Id
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    dmdAnalBindLetDown TopLevelFlag
    top_lvl AnalEnv
    env_rhs SubDemand
    dmd Bind Id
    bind   AnalEnv -> WithDmdType a
    anal_body
      where
        env_rhs :: AnalEnv
    env_rhs = Bind Id -> AnalEnv -> AnalEnv
    enterDFun Bind Id
    bind AnalEnv
    env

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

    -- | Update the demand signature, but be careful not to change boxity info if
    -- `dmd_do_boxity` is True or if the signature is bottom.
    -- See Note [Don't change boxity without worker/wrapper]
    -- and Note [Boxity for bottoming functions].
    setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id
    setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id
    setIdDmdAndBoxSig DmdAnalOpts
    opts Id
    id DmdSig
    sig = Id -> DmdSig -> Id
    setIdDmdSig Id
    id (DmdSig -> Id) -> DmdSig -> Id
    forall a b. (a -> b) -> a -> b
    $
      if DmdAnalOpts -> Bool
    dmd_do_boxity DmdAnalOpts
    opts Bool -> Bool -> Bool
    || DmdSig -> Bool
    isBottomingSig DmdSig
    sig
        then DmdSig
    sig
        else DmdSig -> DmdSig -> DmdSig
    transferArgBoxityDmdSig (Id -> DmdSig
    idDmdSig Id
    id) DmdSig
    sig

    -- | 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
    -> Id
    -> CoreExpr
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    dmdAnalBindLetUp TopLevelFlag
    top_lvl AnalEnv
    env Id
    id CoreExpr
    rhs AnalEnv -> WithDmdType a
    anal_body = DmdType
    -> DmdResult (Bind Id) a -> WithDmdType (DmdResult (Bind Id) a)
    forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    final_ty (Bind Id -> a -> DmdResult (Bind Id) a
    forall a b. a -> b -> DmdResult a b
    R (Id -> CoreExpr -> Bind Id
    forall b. b -> Expr b -> Bind b
    NonRec Id
    id' CoreExpr
    rhs') (a
    body'))
      where
        WithDmdType DmdType
    body_ty a
    body'   = AnalEnv -> WithDmdType a
    anal_body (AnalEnv -> Id -> AnalEnv
    addInScopeAnalEnv AnalEnv
    env Id
    id)
        -- See Note [Bringing a new variable into scope]
        WithDmdType DmdType
    body_ty' Demand
    id_dmd = AnalEnv -> DmdType -> Id -> WithDmdType Demand
    findBndrDmd AnalEnv
    env DmdType
    body_ty Id
    id
        -- See Note [Finalising boxity for demand signatures]

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

        -- See Note [Absence analysis for stable unfoldings and RULES]
        rule_fvs :: VarSet
    rule_fvs           = Id -> VarSet
    bndrRuleAndUnfoldingIds Id
    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 Id
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    dmdAnalBindLetDown TopLevelFlag
    top_lvl AnalEnv
    env SubDemand
    dmd Bind Id
    bind AnalEnv -> WithDmdType a
    anal_body = case Bind Id
    bind of
      NonRec Id
    id CoreExpr
    rhs
        | (AnalEnv
    env', WeakDmds
    weak_fv, Id
    id1, CoreExpr
    rhs1) <-
            TopLevelFlag
    -> RecFlag
    -> AnalEnv
    -> SubDemand
    -> Id
    -> CoreExpr
    -> (AnalEnv, WeakDmds, Id, CoreExpr)
    dmdAnalRhsSig TopLevelFlag
    top_lvl RecFlag
    NonRecursive AnalEnv
    env SubDemand
    dmd Id
    id CoreExpr
    rhs
        -> AnalEnv
    -> WeakDmds
    -> [(Id, CoreExpr)]
    -> ([(Id, CoreExpr)] -> Bind Id)
    -> WithDmdType (DmdResult (Bind Id) a)
    do_rest AnalEnv
    env' WeakDmds
    weak_fv [(Id
    id1, CoreExpr
    rhs1)] ((Id -> CoreExpr -> Bind Id) -> (Id, CoreExpr) -> Bind Id
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry Id -> CoreExpr -> Bind Id
    forall b. b -> Expr b -> Bind b
    NonRec ((Id, CoreExpr) -> Bind Id)
    -> ([(Id, CoreExpr)] -> (Id, CoreExpr))
    -> [(Id, CoreExpr)]
    -> Bind Id
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(Id, CoreExpr)] -> (Id, CoreExpr)
    forall a. [a] -> a
    only)
      Rec [(Id, CoreExpr)]
    pairs
        | (AnalEnv
    env', WeakDmds
    weak_fv, [(Id, CoreExpr)]
    pairs') <- TopLevelFlag
    -> AnalEnv
    -> SubDemand
    -> [(Id, CoreExpr)]
    -> (AnalEnv, WeakDmds, [(Id, CoreExpr)])
    dmdFix TopLevelFlag
    top_lvl AnalEnv
    env SubDemand
    dmd [(Id, CoreExpr)]
    pairs
        -> AnalEnv
    -> WeakDmds
    -> [(Id, CoreExpr)]
    -> ([(Id, CoreExpr)] -> Bind Id)
    -> WithDmdType (DmdResult (Bind Id) a)
    do_rest AnalEnv
    env' WeakDmds
    weak_fv [(Id, CoreExpr)]
    pairs' [(Id, CoreExpr)] -> Bind Id
    forall b. [(b, Expr b)] -> Bind b
    Rec
      where
        do_rest :: AnalEnv
    -> WeakDmds
    -> [(Id, CoreExpr)]
    -> ([(Id, CoreExpr)] -> Bind Id)
    -> WithDmdType (DmdResult (Bind Id) a)
    do_rest AnalEnv
    env' WeakDmds
    weak_fv [(Id, CoreExpr)]
    pairs1 [(Id, CoreExpr)] -> Bind Id
    build_bind = DmdType
    -> DmdResult (Bind Id) a -> WithDmdType (DmdResult (Bind Id) a)
    forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    final_ty (Bind Id -> a -> DmdResult (Bind Id) a
    forall a b. a -> b -> DmdResult a b
    R ([(Id, CoreExpr)] -> Bind Id
    build_bind [(Id, 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 -> [Id] -> WithDmdType [Demand]
    findBndrsDmds AnalEnv
    env' DmdType
    dmd_ty (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    strictMap (Id, CoreExpr) -> Id
    forall a b. (a, b) -> a
    fst [(Id, CoreExpr)]
    pairs1)
            -- Important to force this as build_bind might not force it.
            !pairs2 :: [(Id, CoreExpr)]
    pairs2                         = ((Id, CoreExpr) -> Demand -> (Id, CoreExpr))
    -> [(Id, CoreExpr)] -> [Demand] -> [(Id, CoreExpr)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    strictZipWith (Id, CoreExpr) -> Demand -> (Id, CoreExpr)
    do_one [(Id, CoreExpr)]
    pairs1 [Demand]
    id_dmds
            do_one :: (Id, CoreExpr) -> Demand -> (Id, CoreExpr)
    do_one (Id
    id', CoreExpr
    rhs') Demand
    dmd          = ((,) (Id -> CoreExpr -> (Id, CoreExpr))
    -> Id -> CoreExpr -> (Id, CoreExpr)
    forall a b. (a -> b) -> a -> b
    $! TopLevelFlag -> Id -> Demand -> Id
    setBindIdDemandInfo TopLevelFlag
    top_lvl Id
    id' Demand
    dmd) (CoreExpr -> (Id, CoreExpr)) -> CoreExpr -> (Id, 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.

    -- | Mimic the effect of 'GHC.Core.Prep.mkFloat', turning non-trivial argument
    -- expressions/RHSs into a proper let-bound thunk (lifted) or a case (with
    -- unlifted scrutinee).
    anticipateANF :: CoreExpr -> Card -> Card
    anticipateANF :: CoreExpr -> Card -> Card
    anticipateANF CoreExpr
    e Card
    n
      | CoreExpr -> Bool
    exprIsTrivial CoreExpr
    e                               = Card
    n -- trivial expr won't have a binding
      | Type -> Bool
    definitelyUnliftedType (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    e)
      , Bool -> Bool
    not (Card -> Bool
    isAbs Card
    n Bool -> Bool -> Bool
    && CoreExpr -> Bool
    exprOkForSpeculation CoreExpr
    e)       = Card -> Card
    forall {p}. p -> Card
    case_bind Card
    n
      | Bool
    otherwise                                     = Card -> Card
    let_bind  Card
    n
      where
        case_bind :: p -> Card
    case_bind p
    _ = Card
    C_11       -- evaluated exactly once
        let_bind :: Card -> Card
    let_bind    = Card -> Card
    oneifyCard -- evaluated at most once

    -- 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
      | WithDmdType DmdType
    dmd_ty CoreExpr
    e' <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
    dmdAnal AnalEnv
    env SubDemand
    sd CoreExpr
    e
      , Card
    n' <- CoreExpr -> Card -> Card
    anticipateANF CoreExpr
    e Card
    n
          -- See Note [Anticipating ANF in demand analysis]
          -- and Note [Analysing with absent demand]
      = (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 Analysis 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 Id
    var)
      = DmdType -> CoreExpr -> WithDmdType CoreExpr
    forall a. DmdType -> a -> WithDmdType a
    WithDmdType (AnalEnv -> Id -> SubDemand -> DmdType
    dmdTransform AnalEnv
    env Id
    var SubDemand
    dmd) (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    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 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 `plusDmdType` 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 Id
    var CoreExpr
    body)
      | Id -> Bool
    isTyVar Id
    var
      = let
            WithDmdType DmdType
    body_ty CoreExpr
    body' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
    dmdAnal (AnalEnv -> Id -> AnalEnv
    addInScopeAnalEnv AnalEnv
    env Id
    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 (Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    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 -> Id -> AnalEnv
    addInScopeAnalEnv AnalEnv
    env Id
    var) SubDemand
    body_dmd CoreExpr
    body
            -- See Note [Bringing a new variable into scope]
            WithDmdType DmdType
    lam_ty Id
    var'   = AnalEnv -> DmdType -> Id -> WithDmdType Id
    annotateLamIdBndr AnalEnv
    env DmdType
    body_ty Id
    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 (Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    var' CoreExpr
    body')

    dmdAnal' AnalEnv
    env SubDemand
    dmd (Case CoreExpr
    scrut Id
    case_bndr Type
    ty [Alt AltCon
    alt_con [Id]
    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_con
      = let
            rhs_env :: AnalEnv
    rhs_env = AnalEnv -> [Id] -> AnalEnv
    addInScopeAnalEnvs AnalEnv
    env (Id
    case_bndrId -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    :[Id]
    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 -> [Id] -> WithDmdType [Demand]
    findBndrsDmds AnalEnv
    env DmdType
    rhs_ty [Id]
    bndrs
            WithDmdType DmdType
    alt_ty2 Demand
    case_bndr_dmd = AnalEnv -> DmdType -> Id -> WithDmdType Demand
    findBndrDmd AnalEnv
    env DmdType
    alt_ty1 Id
    case_bndr
            !case_bndr' :: Id
    case_bndr'                       = Id -> Demand -> Id
    setIdDemandInfo Id
    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 -> Demand
    strictifyDmd Demand
    case_bndr_dmd

            -- Compute demand on the scrutinee
            -- FORCE the result, otherwise thunks will end up retaining the
            -- whole DmdEnv
            !(![Id]
    bndrs', !SubDemand
    scrut_sd)
              | DataAlt DataCon
    _ <- AltCon
    alt_con
              -- 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' :: [Id]
    bndrs' = HasCallStack => [Id] -> [Demand] -> [Id]
    [Id] -> [Demand] -> [Id]
    setBndrsDemandInfo [Id]
    bndrs [Demand]
    fld_dmds'
              = ([Id]
    bndrs', SubDemand
    scrut_sd)
              | Bool
    otherwise
              -- DEFAULT alts. Simply add demands and discard the evaluation
              -- cardinality, as we evaluate the scrutinee exactly once.
              = Bool -> ([Id], SubDemand) -> ([Id], SubDemand)
    forall a. HasCallStack => Bool -> a -> a
    assert ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    bndrs) ([Id]
    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 -> Id -> Type -> [Alt Id] -> CoreExpr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CoreExpr
    scrut' Id
    case_bndr' Type
    ty [AltCon -> [Id] -> CoreExpr -> Alt Id
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    alt_con [Id]
    bndrs' CoreExpr
    rhs'])
        where
          want_precise_field_dmds :: AltCon -> Bool
    want_precise_field_dmds (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    -- Not a product type, even though this is the
                       -- only remaining possible data constructor
            | IsRecDataConResult
    DefinitelyRecursive <- AnalEnv -> DataCon -> IsRecDataConResult
    ae_rec_dc AnalEnv
    env DataCon
    dc
            = Bool
    False     -- See Note [Demand analysis for recursive data constructors]
            | Bool
    otherwise
            = Bool
    True
          want_precise_field_dmds (LitAlt {}) = Bool
    False  -- Like the non-product datacon above
          want_precise_field_dmds AltCon
    DEFAULT     = Bool
    True

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

            WithDmdType DmdType
    alt_ty1 Demand
    case_bndr_dmd = AnalEnv -> DmdType -> Id -> WithDmdType Demand
    findBndrDmd AnalEnv
    env DmdType
    alt_ty Id
    case_bndr
            !case_bndr' :: Id
    case_bndr'                       = Id -> Demand -> Id
    setIdDemandInfo Id
    case_bndr Demand
    case_bndr_dmd
            WithDmdType DmdType
    alt_ty [Alt Id]
    alts'          = AnalEnv -> SubDemand -> Id -> [Alt Id] -> WithDmdType [Alt Id]
    dmdAnalSumAlts AnalEnv
    env SubDemand
    dmd Id
    case_bndr [Alt Id]
    alts

            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_ty1" <+> ppr alt_ty1
    --                                   , 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 -> Id -> Type -> [Alt Id] -> CoreExpr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CoreExpr
    scrut' Id
    case_bndr' Type
    ty [Alt Id]
    alts')

    dmdAnal' AnalEnv
    env SubDemand
    dmd (Let Bind Id
    bind CoreExpr
    body)
      = DmdType -> CoreExpr -> WithDmdType CoreExpr
    forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    final_ty (Bind Id -> CoreExpr -> CoreExpr
    forall b. Bind b -> Expr b -> Expr b
    Let Bind Id
    bind' CoreExpr
    body')
      where
        !(WithDmdType DmdType
    final_ty (R Bind Id
    bind' CoreExpr
    body')) = TopLevelFlag
    -> AnalEnv
    -> SubDemand
    -> Bind Id
    -> (AnalEnv -> WithDmdType CoreExpr)
    -> WithDmdType (DmdResult (Bind Id) CoreExpr)
    forall a.
    TopLevelFlag
    -> AnalEnv
    -> SubDemand
    -> Bind Id
    -> (AnalEnv -> WithDmdType a)
    -> WithDmdType (DmdResult (Bind Id) a)
    dmdAnalBind TopLevelFlag
    NotTopLevel AnalEnv
    env SubDemand
    dmd Bind Id
    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 (HasDebugCallStack => CoreExpr -> Type
    CoreExpr -> Type
    exprType CoreExpr
    e))
      = Bool
    False -- 1. in the Note
      | (Var Id
    f, [CoreExpr]
    _) <- CoreExpr -> (CoreExpr, [CoreExpr])
    forall b. Expr b -> (Expr b, [Expr b])
    collectArgs CoreExpr
    e
      , Just PrimOp
    op    <- Id -> Maybe PrimOp
    isPrimOpId_maybe Id
    f
      , PrimOp
    op PrimOp -> PrimOp -> Bool
    forall a. Eq a => a -> a -> Bool
    /= PrimOp
    RaiseIOOp
      = Bool
    False -- 2. in the Note
      | (Var Id
    f, [CoreExpr]
    _) <- CoreExpr -> (CoreExpr, [CoreExpr])
    forall b. Expr b -> (Expr b, [Expr b])
    collectArgs CoreExpr
    e
      , Just ForeignCall
    fcall <- Id -> Maybe ForeignCall
    isFCallId_maybe Id
    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

    dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt]
    dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [Alt Id] -> WithDmdType [Alt Id]
    dmdAnalSumAlts AnalEnv
    _ SubDemand
    _ Id
    _ [] = DmdType -> [Alt Id] -> WithDmdType [Alt Id]
    forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    botDmdType []
      -- Base case is botDmdType, for empty case alternatives
      -- This is a unit for lubDmdType, and the right result
      -- when there really are no alternatives
    dmdAnalSumAlts AnalEnv
    env SubDemand
    dmd Id
    case_bndr (Alt Id
    alt:[Alt Id]
    alts)
      = let
          WithDmdType DmdType
    cur_ty  Alt Id
    alt'  = AnalEnv -> SubDemand -> Id -> Alt Id -> WithDmdType (Alt Id)
    dmdAnalSumAlt AnalEnv
    env SubDemand
    dmd Id
    case_bndr Alt Id
    alt
          WithDmdType DmdType
    rest_ty [Alt Id]
    alts' = AnalEnv -> SubDemand -> Id -> [Alt Id] -> WithDmdType [Alt Id]
    dmdAnalSumAlts AnalEnv
    env SubDemand
    dmd Id
    case_bndr [Alt Id]
    alts
        in DmdType -> [Alt Id] -> WithDmdType [Alt Id]
    forall a. DmdType -> a -> WithDmdType a
    WithDmdType (DmdType -> DmdType -> DmdType
    lubDmdType DmdType
    cur_ty DmdType
    rest_ty) (Alt Id
    alt'Alt Id -> [Alt Id] -> [Alt Id]
    forall a. a -> [a] -> [a]
    :[Alt Id]
    alts')

    dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt
    dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Id -> WithDmdType (Alt Id)
    dmdAnalSumAlt AnalEnv
    env SubDemand
    dmd Id
    case_bndr (Alt AltCon
    con [Id]
    bndrs CoreExpr
    rhs)
      | let rhs_env :: AnalEnv
    rhs_env = AnalEnv -> [Id] -> AnalEnv
    addInScopeAnalEnvs AnalEnv
    env (Id
    case_bndrId -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    :[Id]
    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 -> [Id] -> WithDmdType [Demand]
    findBndrsDmds AnalEnv
    env DmdType
    rhs_ty [Id]
    bndrs
      , let (Card
    _ :* SubDemand
    case_bndr_sd) = DmdType -> Id -> Demand
    findIdDemand DmdType
    alt_ty Id
    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 :: [Id]
    new_ids            = HasCallStack => [Id] -> [Demand] -> [Id]
    [Id] -> [Demand] -> [Id]
    setBndrsDemandInfo [Id]
    bndrs [Demand]
    dmds'
      = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $
        DmdType -> Alt Id -> WithDmdType (Alt Id)
    forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    alt_ty (AltCon -> [Id] -> CoreExpr -> Alt Id
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    con [Id]
    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 [Anticipating ANF in demand analysis]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When analysing non-complex (e.g., trivial) thunks and complex function
    arguments, we have to pretend that the expression is really in administrative
    normal form (ANF), the conversion to which is done by CorePrep.

    Consider
    ```
    f x = let y = x |> co in y `seq` y `seq` ()
    ```
    E.g., 'y' is a let-binding with a trivial RHS. That may occur if 'y' can't be
    inlined, for example. Now, is 'x' used once? It may appear as if that is the
    case, since its only occurrence is in 'y's memoised RHS. But actually, CorePrep
    will *not* allocate a thunk for 'y', because it is trivial and could just
    re-use the memoisation mechanism of 'x'! By saying that 'x' is used once it
    becomes a single-entry thunk and a call to 'f' will evaluate it twice.
    The same applies to trivial arguments, e.g., `f z` really evaluates `z` twice.

    So, somewhat counter-intuitively, trivial arguments and let RHSs will *not* be
    memoised. On the other hand, evaluation of non-trivial arguments and let RHSs
    *will* be memoised. In fact, consider the effect of conversion to ANF on complex
    function arguments (as done by 'GHC.Core.Prep.mkFloat'):
    ```
    f2 (g2 x) ===> let y = g2 x in f2 y                   (if `y` is lifted)
    f3 (g3 x) ===> case g3 x of y { __DEFAULT -> f3 y }   (if `y` is not lifted)
    ```
    So if a lifted argument like `g2 x` is complex enough, it will be memoised.
    Regardless how many times 'f2' evaluates its parameter, the argument will be
    evaluated at most once to WHNF.
    Similarly, when an unlifted argument like `g3 x` is complex enough, we will
    evaluate it *exactly* once to WHNF, no matter how 'f3' evaluates its parameter.

    Note that any evaluation beyond WHNF is not affected by memoisation. So this
    Note affects the outer 'Card' of a 'Demand', but not its nested 'SubDemand'.
    'anticipateANF' predicts the effect of case-binding and let-binding complex
    arguments, as well as the lack of memoisation for trivial let RHSs.
    In particular, this takes care of the gripes in
    Note [Analysing with absent demand] relating to unlifted types.

    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' with the appropriate
      (absent) evaluation cardinality A or B.

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

    * Since we allow unlifted arguments that are not ok-for-speculation,
      we need to be extra careful in the following situation, because unlifted
      values are evaluated even if they are not used. Example from #9254:
         f :: (() -> (# Int#, () #)) -> ()
              -- Strictness signature is
              --    <1C(1,P(A,1L))>
              -- 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.

      But in function g, we *will* evaluate the 'case y of ...', because it has type
      Int#. So in the program as written, 'y' will be evaluated. Hence 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 filler (see Note [Absent fillers]), leading
      to a crash when 'y' is evaluated.

      Now, worker/wrapper could be smarter and replace `case y of I# y2 -> y2`
      with a suitable absent filler such as `RUBBISH[IntRep] @Int#`.
      But as long as worker/wrapper isn't equipped to do so, we must be cautious,
      and follow Note [Anticipating ANF in demand analysis]. That is, in
      'dmdAnalStar', we will set the evaluation cardinality to C_11, anticipating
      the case binding of the complex argument `case y of I# y2 -> y2`. This
      cardinlities' only effect is in the call to 'multDmdType', where it makes sure
      that the demand on the arg's free variable 'y' is not absent and strict, so
      that it is ultimately passed unboxed to 'g'.

    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. This code happens in want_precise_field_dmds
    in the Case equation for dmdAnal.

    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 -> Id -> SubDemand -> DmdType
    dmdTransform AnalEnv
    env Id
    var SubDemand
    sd
      -- Data constructors
      | Just DataCon
    con <- Id -> Maybe DataCon
    isDataConWorkId_maybe Id
    var
      = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $
        [StrictnessMark] -> SubDemand -> DmdType
    dmdTransformDataConSig (DataCon -> [StrictnessMark]
    dataConRepStrictness DataCon
    con) SubDemand
    sd
      -- See Note [DmdAnal for DataCon wrappers]
      | Id -> Bool
    isDataConWrapId Id
    var, let rhs :: CoreExpr
    rhs = Unfolding -> CoreExpr
    uf_tmpl (Id -> Unfolding
    realIdUnfolding Id
    var)
      , WithDmdType DmdType
    dmd_ty CoreExpr
    _rhs' <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
    dmdAnal AnalEnv
    env SubDemand
    sd CoreExpr
    rhs
      = DmdType
    dmd_ty
      -- Dictionary component selectors
      -- Used to be controlled by a flag.
      -- See #18429 for some perf measurements.
      | Just Class
    _ <- Id -> Maybe Class
    isClassOpId_maybe Id
    var
      = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $
        DmdSig -> SubDemand -> DmdType
    dmdTransformDictSelSig (Id -> DmdSig
    idDmdSig Id
    var) SubDemand
    sd
      -- Imported functions
      | Id -> Bool
    isGlobalId Id
    var
      , let res :: DmdType
    res = DmdSig -> SubDemand -> DmdType
    dmdTransformSig (Id -> DmdSig
    idDmdSig Id
    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 -> Id -> Maybe (DmdSig, TopLevelFlag)
    lookupSigEnv AnalEnv
    env Id
    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 -> Id -> Demand -> DmdType
    addVarDmd DmdType
    fn_ty Id
    var (Card
    C_11 HasDebugCallStack => Card -> SubDemand -> Demand
    Card -> SubDemand -> Demand
    :* SubDemand
    sd)
          TopLevelFlag
    TopLevel
            | Id -> Bool
    isInterestingTopLevelFn Id
    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 -> Id -> Demand -> DmdType
    addVarDmd DmdType
    fn_ty Id
    var (Card
    C_0N Card -> Demand -> Demand
    `multDmd` (Card
    C_11 HasDebugCallStack => 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 -> Id -> Demand -> DmdEnv
    addVarDmdEnv DmdEnv
    nopDmdEnv Id
    var (Card
    C_11 HasDebugCallStack => 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
    -> Id
    -> CoreExpr
    -> (AnalEnv, WeakDmds, Id, CoreExpr)
    dmdAnalRhsSig TopLevelFlag
    top_lvl RecFlag
    rec_flag AnalEnv
    env SubDemand
    let_dmd Id
    id CoreExpr
    rhs
      = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $
        (AnalEnv
    final_env, WeakDmds
    weak_fvs, Id
    final_id, CoreExpr
    final_rhs)
      where
        threshold_arity :: Arity
    threshold_arity = Id -> CoreExpr -> Arity
    thresholdArity Id
    id CoreExpr
    rhs

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

        body_dmd :: SubDemand
    body_dmd
          | Id -> Bool
    isJoinId Id
    id
          -- See Note [Demand analysis for join points]
          -- See Note [Invariants on join points] invariant 2b, in GHC.Core
          --     threshold_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 (Id -> Maybe Type
    resultType_maybe Id
    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 (Id -> Maybe Type
    resultType_maybe Id
    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
    -> Id
    -> Arity
    -> [Demand]
    -> Divergence
    -> CoreExpr
    -> ([Demand], CoreExpr)
    finaliseArgBoxities AnalEnv
    env Id
    id Arity
    threshold_arity
                                                          [Demand]
    rhs_dmds (DmdEnv -> Divergence
    de_div DmdEnv
    rhs_env) CoreExpr
    rhs'

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

        opts :: DmdAnalOpts
    opts       = AnalEnv -> DmdAnalOpts
    ae_opts AnalEnv
    env
        final_id :: Id
    final_id   = DmdAnalOpts -> Id -> DmdSig -> Id
    setIdDmdAndBoxSig DmdAnalOpts
    opts Id
    id DmdSig
    sig
        !final_env :: AnalEnv
    final_env = TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv
    extendAnalEnv TopLevelFlag
    top_lvl AnalEnv
    env Id
    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 (Id -> VarSet
    bndrRuleAndUnfoldingIds Id
    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

    thresholdArity :: Id -> CoreExpr -> Arity
    -- See Note [Demand signatures are computed for a threshold arity based on idArity]
    thresholdArity :: Id -> CoreExpr -> Arity
    thresholdArity Id
    fn CoreExpr
    rhs
      = case Id -> JoinPointHood
    idJoinPointHood Id
    fn of
          JoinPoint Arity
    join_arity -> (Id -> Bool) -> [Id] -> Arity
    forall a. (a -> Bool) -> [a] -> Arity
    count Id -> Bool
    isId ([Id] -> Arity) -> [Id] -> Arity
    forall a b. (a -> b) -> a -> b
    $ ([Id], CoreExpr) -> [Id]
    forall a b. (a, b) -> a
    fst (([Id], CoreExpr) -> [Id]) -> ([Id], CoreExpr) -> [Id]
    forall a b. (a -> b) -> a -> b
    $ Arity -> CoreExpr -> ([Id], CoreExpr)
    forall b. Arity -> Expr b -> ([b], Expr b)
    collectNBinders Arity
    join_arity CoreExpr
    rhs
          JoinPointHood
    NotJoinPoint         -> Id -> Arity
    idArity Id
    fn

    -- | 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 :: Id -> Maybe Type
    resultType_maybe Id
    id
      | ([PiTyBinder]
    pis,Type
    ret_ty) <- Type -> ([PiTyBinder], Type)
    splitPiTys (Id -> Type
    idType Id
    id)
      , (PiTyBinder -> Bool) -> [PiTyBinder] -> Arity
    forall a. (a -> Bool) -> [a] -> Arity
    count PiTyBinder -> Bool
    isAnonPiTyBinder [PiTyBinder]
    pis Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Id -> Arity
    idArity Id
    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
          , [Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (DataCon -> [Id]
    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 HasDebugCallStack => 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 -> Id -> Bool
    useLetUp TopLevelFlag
    top_lvl Id
    f = TopLevelFlag -> Bool
    isNotTopLevel TopLevelFlag
    top_lvl Bool -> Bool -> Bool
    && Id -> Arity
    idArity Id
    f Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    0 Bool -> Bool -> Bool
    && Bool -> Bool
    not (Id -> Bool
    isJoinId Id
    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 C(1,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 C(1,L)
    context the RHS of the join point is indeed bottom.

    Note [Demand signatures are computed for a threshold arity based on idArity]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Given a binding { f = rhs }, we compute a "theshold arity", and do demand
    analysis based on a call with that many value arguments.

    The threshold we use is

    * Ordinary bindings: idArity f.
      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.  E.g. for
          f = g
      we want to use a threshold arity based on g, not 0!

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

    * Join points: the value-binder subset of the JoinArity.  This can
      be less than the number of visible lambdas; e.g.
         join j x = \y. blah
         in ...(jump j 2)....(jump j 3)....
      We know that j will never be applied to more than 1 arg (its join
      arity, and we don't eta-expand join points, so here a threshold
      of 1 is the best we can do.

    Note that the idArity of a function varies independently of its cardinality
    properties (cf. Note [idArity varies independently of dmdTypeDepth]), so we
    implicitly encode the arity for when a demand signature is sound to unleash
    in its 'dmdTypeDepth', not in its idArity (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
    GHC.Types.Demand Note [What are demand signatures?]  for more details on
    soundness.

    Note that there might, in principle, 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 C(1,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 C(1,C(1,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]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In general, an Id `f` has two independently varying attributes:

    * f's idArity, and
    * the dmdTypeDepth of f's demand signature

    For example, if f's demand signature is <L><L>, f's arity could be
    greater than, or less than 2. Why?  Because both are conservative
    approximations:

    * Arity n means "does no expensive work until applied to at least n args"
      (e.g. (f x1..xm) is cheap to bring to HNF for m<n)

    * Dmd sig with n args means "here is how to transform the incoming demand
      when applied to n args".  This is /semantic/ property, unrelated to
      arity. See GHC.Types.Demand Note [Understanding DmdType and DmdSig]

    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.

    For example, consider the following expression:

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

    However, in the case of a /bottoming/ signature, f : <L><L>b, we /can/
    say that f's arity is no greater than 2, because it'd be false to say
    that f does no work when applied to 3 args.  Lint checks this constraint,
    in `GHC.Core.Lint.lintLetBind`.

    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 occurring 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 [DmdAnal for DataCon wrappers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We give DataCon wrappers a (necessarily flat) demand signature in
    `GHC.Types.Id.Make.mkDataConRep`, so that passes such as the Simplifier can
    exploit it via the call to `GHC.Core.Opt.Simplify.Utils.isStrictArgInfo` in
    `GHC.Core.Opt.Simplify.Iteration.rebuildCall`. But during DmdAnal, we *ignore*
    the demand signature of a DataCon wrapper, and instead analyse its unfolding at
    every call site.

    The reason is that DataCon *worker*s have very precise demand transformers,
    computed by `dmdTransformDataConSig`. It would be awkward if DataCon *wrappers*
    would behave much less precisely during DmdAnal. Example:

       data T1 = MkT1 { get_x1 :: Int,  get_y1 :: Int }
       data T2 = MkT2 { get_x2 :: !Int, get_y2 :: Int }
       f1 x y = get_x1 (MkT1 x y)
       f2 x y = get_x2 (MkT2 x y)

    Here `MkT1` has no wrapper. `get_x1` puts a demand `!P(1!L,A)` on its argument,
    and `dmdTransformDataConSig` will transform that demand to an absent demand on
    `y` in `f1` and an unboxing demand on `x`.
    But `MkT2` has a wrapper (to evaluate the first field). If demand analysis deals
    with `MkT2` only through its demand signature, demand signatures can't transform
    an incoming demand `P(1!L,A)` in a useful way, so we won't get an absent demand
    on `y` in `f2` or see that `x` can be unboxed. That's a serious loss.

    The example above will not actually occur, because $WMkT2 would be inlined.
    Nevertheless, we can get interesting sub-demands on DataCon wrapper
    applications in boring contexts; see T22241.

    You might worry about the efficiency cost of demand-analysing datacon wrappers
    at every call site. But in fact they are inlined /anyway/ in the Final phase,
    which happens before DmdAnal, so few wrappers remain. And analysing the
    unfoldings for the remaining calls (which are those in a boring context) will be
    exactly as (in)efficent as if we'd inlined those calls. It turns out to be not
    measurable in practice.

    See also Note [CPR for DataCon wrappers] in `GHC.Core.Opt.CprAnal`.

    Note [Boxity for bottoming functions]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider (A)
        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::a` and `u::a`
    boxed, since `indexError` can't unbox them because they are polymorphic.
    This pattern often occurs in performance sensitive code that does
    bounds-checking.

    So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S><S!S>b`
    where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments
    are unboxed (recursively).  The wrapper for `indexError` won't /actually/
    unbox them (because their polymorphic type doesn't allow that) but when
    demand-analysing /callers/, we'll behave as if that call needs the args
    unboxed.

    Then at call sites of `indexError`, we will end up doing some
    reboxing, because `$windexError` still takes boxed arguments. This
    reboxing should usually float into the slow, diverging code path; but
    sometimes (sadly) it doesn't: see Note [Reboxed crud for bottoming calls].

    Here is another important case (B):
        f x = Just x  -- Suppose f is not inlined for some reason
                      -- Main point: f takes its argument boxed

        wombat x = error (show (f x))

        g :: Bool -> Int -> a
        g True  x = x+1
        g False x = wombat x

    Again we want `wombat` to pretend to take its Int-typed argument unboxed,
    even though it has to pass it boxed to `f`, so that `g` can take its
    argument unboxed (and rebox it before calling `wombat`).

    So here's what we do: while summarising `indexError`'s boxity signature in
    `finaliseArgBoxities`:

    * To address (B), for bottoming functions, we start by using `unboxDeeplyDmd`
      to make all its argument demands unboxed, right to the leaves; regardless
      of what the analysis said.

    * To address (A), for bottoming functions, in the DontUnbox case when the
      argument is a type variable, we /refrain/ from using trimBoxity.
      (Remember the previous bullet: we have already doen `unboxDeeplyDmd`.)

    Wrinkle:

    * Remember Note [No lazy, Unboxed demands in demand signature]. So
      unboxDeeplyDmd doesn't recurse into lazy demands.  It's extremely unusual
      to have lazy demands in the arguments of a bottoming function anyway.
      But it can happen, when the demand analyser gives up because it
      encounters a recursive data type; see Note [Demand analysis for recursive
      data constructors].

    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.

    See also Note [indexError] in base:GHC.Ix, which describes how we use
    SPECIALISE to mitigate this problem for indexError.
    -}

    {- *********************************************************************
    *                                                                      *
                 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 decisions
    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)`
      * Note [mkWWstr and unsafeCoerce]

    NB: Then, the worker/wrapper blindly trusts the boxity info in the
    demand signature; that is why 'canUnboxArg' does not look at
    strictness -- it is redundant to do so.

    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 because
    worker/wrapper ignores strictness 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 'canUnboxArg' 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 [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 ('max_wkr_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.
    Unboxing an argument *increases* the budget for the inner layer roughly
    according to how many registers that argument takes (unboxed tuples take
    multiple registers, see below), as determined by 'unariseArity'.
    Budget is spent when we have to pass a non-absent field as a parameter.

    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. The effect is that of a breadth-first search (over argument type and
    demand structure) to compute Budgets followed by a depth-first search to
    construct the product demands, but laziness allows us to do it all in one
    pass and without intermediate data structures.

    Suppose we have -fmax-worker-args=4 for the remainder of this Note.
    Then consider this example function:

      boxed :: (Int, Int) -> (Int, (Int, Int, Int)) -> Int
      boxed (a,b) (c, (d,e,f)) = a + b + c + d + e + f

    With a budget of 4 args to spend (number of args is only 2), we'd be served well
    to unbox both pairs, but not the triple. Indeed, that is what the algorithm
    computes, and the following pictogram shows how the budget layers are computed.
    Each layer is started with `n ~>`, where `n` is the budget at the start of the
    layer. We write -n~> when we spend budget (and n is the remaining budget) and
    +n~> when we earn budget. We separate unboxed args with ][ and indicate
    inner budget threads becoming negative in braces {{}}, so that we see which
    unboxing decision we do *not* commit to. Without further ado:

      4 ~> ][     (a,b) -3~>               ][     (c, ...) -2~>
           ][      | |                     ][      |   |
           ][      | +-------------+       ][      |   +-----------------+
           ][      |               |       ][      |                     |
           ][      v               v       ][      v                     v
      2 ~> ][ +3~> a  -2~> ][      b  -1~> ][ +2~> c  -1~> ][        (d, e, f) -0~>
           ][      |       ][      |       ][      |       ][ {{      |  |  |                          }}
           ][      |       ][      |       ][      |       ][ {{      |  |  +----------------+         }}
           ][      v       ][      v       ][      v       ][ {{      v  +------v            v         }}
      0 ~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ {{ +1~> d -0~> ][ e -(-1)~> ][ f -(-2)~> }}

    Unboxing increments the budget we have on the next layer (because we don't need
    to retain the boxed arg), but in turn the inner layer must afford to retain all
    non-absent fields, each decrementing the budget. Note how the budget becomes
    negative when trying to unbox the triple and the unboxing decision is "rolled
    back". This is done by the 'positiveTopBudget' guard.

    There's a bit of complication as a result of handling unboxed tuples correctly;
    specifically, handling nested unboxed tuples. Consider (#21737)

      unboxed :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int
      unboxed (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f

    Recall that unboxed tuples will be flattened to individual arguments during
    unarisation. Here, `unboxed` will have 5 arguments at runtime because of the
    nested unboxed tuple, which will be flattened to 4 args. So it's best to leave
    `(a,b)` boxed (because we already are above our arg threshold), but unbox `c`
    through `f` because that doesn't increase the number of args post unarisation.

    Note that the challenge is that syntactically, `(# d, e, f #)` occurs in a
    deeper layer than `(a, b)`. Treating unboxed tuples as a regular data type, we'd
    make the same unboxing decisions as for `boxed` above; although our starting
    budget is 5 (Here, the number of args is greater than -fmax-worker-args), it's
    not enough to unbox the triple (we'd finish with budget -1). So we'd unbox `a`
    through `c`, but not `d` through `f`, which is silly, because then we'd end up
    having 6 arguments at runtime, of which `d` through `f` weren't unboxed.

    Hence we pretend that the fields of unboxed tuples appear in the same budget
    layer as the tuple itself. For example at the top-level, `(# x,y #)` is to be
    treated just like two arguments `x` and `y`.
    Of course, for that to work, our budget calculations must initialise
    'max_wkr_args' to 5, based on the 'unariseArity' of each Core arg: That would be
    1 for the pair and 4 for the unboxed pair. Then when we decide whether to unbox
    the unboxed pair, we *directly* recurse into the fields, spending our budget
    on retaining `c` and (after recursing once more) `d` through `f` as arguments,
    depleting our budget completely in the first layer. Pictorially:

      5 ~> ][         (a,b) -4~>             ][         (# c, ... #)
           ][ {{      | |                 }} ][      c  -3~> ][ (# d, e, f #)
           ][ {{      | +-------+         }} ][      |       ][      d  -2~> ][      e  -1~> ][      f  -0~>
           ][ {{      |         |         }} ][      |       ][      |       ][      |       ][      |
           ][ {{      v         v         }} ][      v       ][      v       ][      v       ][      v
      0 ~> ][ {{ +1~> a -0~> ][ b -(-1)~> }} ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~>

    As you can see, we have no budget left to justify unboxing `(a,b)` on the second
    layer, which is good, because it would increase the number of args. Also note
    that we can still unbox `c` through `f` in this layer, because doing so has a
    net zero effect on budget.

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

    -- | How many registers does this type take after unarisation?
    unariseArity :: Type -> Arity
    unariseArity :: Type -> Arity
    unariseArity Type
    ty = [PrimRep] -> Arity
    forall a. [a] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length (HasDebugCallStack => Type -> [PrimRep]
    Type -> [PrimRep]
    typePrimRep Type
    ty)

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

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

    spendTopBudget :: Arity -> Budgets -> Budgets
    spendTopBudget :: Arity -> Budgets -> Budgets
    spendTopBudget Arity
    m (MkB Arity
    n Budgets
    bg) = Arity -> Budgets -> Budgets
    MkB (Arity
    nArity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    -Arity
    m) 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
                        -> [Demand] -> Divergence
                        -> CoreExpr -> ([Demand], CoreExpr)
    finaliseArgBoxities :: AnalEnv
    -> Id
    -> Arity
    -> [Demand]
    -> Divergence
    -> CoreExpr
    -> ([Demand], CoreExpr)
    finaliseArgBoxities AnalEnv
    env Id
    fn Arity
    threshold_arity [Demand]
    rhs_dmds Divergence
    div CoreExpr
    rhs

      -- Check for an OPAQUE function: see Note [OPAQUE pragma]
      -- In that case, trim off all boxity info from argument demands
      -- and demand info on lambda binders
      -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
      | InlinePragma -> Bool
    isOpaquePragma (Id -> InlinePragma
    idInlinePragma Id
    fn)
      , let trimmed_rhs_dmds :: [Demand]
    trimmed_rhs_dmds = (Demand -> Demand) -> [Demand] -> [Demand]
    forall a b. (a -> b) -> [a] -> [b]
    map Demand -> Demand
    trimBoxity [Demand]
    rhs_dmds
      = ([Demand]
    trimmed_rhs_dmds, [Demand] -> CoreExpr -> CoreExpr
    set_lam_dmds [Demand]
    trimmed_rhs_dmds CoreExpr
    rhs)

      -- Check that we have enough visible binders to match the
      -- threshold arity; if not, we won't do worker/wrapper
      -- This happens if we have simply  {f = g} or a PAP {f = h 13}
      -- we simply want to give f the same demand signature as g
      -- How can such bindings arise?  Perhaps from {-# NOLINE[2] f #-},
      -- or if the call to `f` is currently not-applied (map f xs).
      -- It's a bit of a corner case.  Anyway for now we pass on the
      -- unadulterated demands from the RHS, without any boxity trimming.
      | Arity
    threshold_arity Arity -> Arity -> Bool
    forall a. Ord a => a -> a -> Bool
    > (Id -> Bool) -> [Id] -> Arity
    forall a. (a -> Bool) -> [a] -> Arity
    count Id -> Bool
    isId [Id]
    bndrs
      = ([Demand]
    rhs_dmds, CoreExpr
    rhs)

      -- The normal case
      | Bool
    otherwise -- NB: threshold_arity might be less than
                  -- manifest arity for join points
      = -- pprTrace "finaliseArgBoxities" (
        --   vcat [text "function:" <+> ppr fn
        --        , text "max" <+> ppr max_wkr_args
        --        , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
        --        , text "dmds after: " <+>  ppr arg_dmds' ]) $
        ([Demand]
    arg_dmds', [Demand] -> CoreExpr -> CoreExpr
    set_lam_dmds [Demand]
    arg_dmds' CoreExpr
    rhs)
        -- set_lam_dmds: 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
        ([Id]
    bndrs, CoreExpr
    _body)  = CoreExpr -> ([Id], CoreExpr)
    forall b. Expr b -> ([b], Expr b)
    collectBinders CoreExpr
    rhs
        unarise_arity :: Arity
    unarise_arity   = [Arity] -> Arity
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum [ Type -> Arity
    unariseArity (Id -> Type
    idType Id
    b) | Id
    b <- [Id]
    bndrs, Id -> Bool
    isId Id
    b ]
        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
    unarise_arity
                          -- This is the budget initialisation step of
                          -- 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
    threshold_arity ([(Type, StrictnessMark, Demand)]
     -> [(Type, StrictnessMark, Demand)])
    -> [(Type, StrictnessMark, Demand)]
    -> [(Type, StrictnessMark, Demand)]
    forall a b. (a -> b) -> a -> b
    $
                      [ (Id -> Type
    idType Id
    bndr, StrictnessMark
    NotMarkedStrict, Id -> Demand
    get_dmd Id
    bndr)
                      | Id
    bndr <- [Id]
    bndrs, Id -> Bool
    isRuntimeVar Id
    bndr ]

        get_dmd :: Id -> Demand
        get_dmd :: Id -> Demand
    get_dmd Id
    bndr
          | Bool
    is_bot_fn = Demand -> Demand
    unboxDeeplyDmd Demand
    dmd -- See Note [Boxity for bottoming functions],
          | Bool
    otherwise = Demand
    dmd                --     case (B)
          where
            dmd :: Demand
    dmd = Id -> Demand
    idDemandInfo Id
    bndr

        -- 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 AnalEnv
    -> Type
    -> StrictnessMark
    -> Demand
    -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    wantToUnboxArg AnalEnv
    env Type
    ty StrictnessMark
    str_mark Demand
    dmd of
              UnboxingDecision [(Type, StrictnessMark, Demand)]
    DropAbsent -> (Budgets
    bg, Demand
    dmd)

              UnboxingDecision [(Type, StrictnessMark, Demand)]
    DontUnbox | Bool
    is_bot_fn, Type -> Bool
    isTyVarTy Type
    ty -> (Budgets
    retain_budget, Demand
    dmd)
                        | Bool
    otherwise               -> (Budgets
    retain_budget, Demand -> Demand
    trimBoxity Demand
    dmd)
                -- If bot: Keep deep boxity even though WW won't unbox
                -- See Note [Boxity for bottoming functions] case (A)
                -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature]
                where
                  retain_budget :: Budgets
    retain_budget = Arity -> Budgets -> Budgets
    spendTopBudget (Type -> Arity
    unariseArity Type
    ty) Budgets
    bg
                    -- spendTopBudget: spend from our budget the cost of the
                    -- retaining the arg
                    -- The unboxed case does happen here, for example
                    --   app g x = g x :: (# Int, Int #)
                    -- here, `x` is used `L`azy and thus Boxed

              DoUnbox [(Type, StrictnessMark, Demand)]
    triples
                | Type -> Bool
    isUnboxedTupleType Type
    ty
                , (Budgets
    bg', [Demand]
    dmds') <- Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand])
    go_args Budgets
    bg [(Type, StrictnessMark, Demand)]
    triples
                -> (Budgets
    bg', Card
    n HasDebugCallStack => 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'))
                         -- See Note [Worker argument budget]
                         -- unboxed tuples are always unboxed, deeply
                         -- NB: Recurse with bg, *not* bg_inner! The unboxed fields
                         -- are at the same budget layer.

                | Type -> Bool
    isUnboxedSumType Type
    ty
                -> String -> SDoc -> (Budgets, Demand)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "Unboxing through unboxed sum" (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    fn SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)
                         -- We currently don't return DoUnbox for unboxed sums.
                         -- But hopefully we will at some point. When that happens,
                         -- it would still be impossible to predict the effect
                         -- of dropping absent fields and unboxing others on the
                         -- unariseArity of the sum without losing sanity.
                         -- We could overwrite bg_top with the one from
                         -- retain_budget while still unboxing inside the alts as in
                         -- the tuple case for a conservative solution, though.

                | Bool
    otherwise
                -> (Arity -> Budgets -> Budgets
    spendTopBudget Arity
    1 (Arity -> Budgets -> Budgets
    MkB Arity
    bg_top Budgets
    final_bg_inner), Demand
    final_dmd)
                where
                  (Budgets
    bg_inner', [Demand]
    dmds') = Budgets -> [(Type, StrictnessMark, Demand)] -> (Budgets, [Demand])
    go_args (Budgets -> Budgets
    earnTopBudget Budgets
    bg_inner) [(Type, StrictnessMark, Demand)]
    triples
                         -- earnTopBudget: give back the cost of retaining the
                         -- arg we are insted unboxing.
                  dmd' :: Demand
    dmd' = Card
    n HasDebugCallStack => 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) -- "~": This match *must* be lazy!
                     | Budgets -> Bool
    positiveTopBudget Budgets
    bg_inner' = (Budgets
    bg_inner', Demand
    dmd')
                     | Bool
    otherwise                   = (Budgets
    bg_inner,  Demand -> Demand
    trimBoxity Demand
    dmd)

        set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr
        -- Attach the demands to the outer lambdas of this expression
        set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr
    set_lam_dmds (Demand
    dmd:[Demand]
    dmds) (Lam Id
    v CoreExpr
    e)
          | Id -> Bool
    isTyVar Id
    v = Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    v ([Demand] -> CoreExpr -> CoreExpr
    set_lam_dmds (Demand
    dmdDemand -> [Demand] -> [Demand]
    forall a. a -> [a] -> [a]
    :[Demand]
    dmds) CoreExpr
    e)
          | Bool
    otherwise = Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam (Id
    v Id -> Demand -> Id
    `setIdDemandInfo` Demand
    dmd) ([Demand] -> CoreExpr -> CoreExpr
    set_lam_dmds [Demand]
    dmds CoreExpr
    e)
        set_lam_dmds [Demand]
    dmds (Cast CoreExpr
    e Coercion
    co) = CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast ([Demand] -> CoreExpr -> CoreExpr
    set_lam_dmds [Demand]
    dmds CoreExpr
    e) Coercion
    co
           -- This case happens for an OPAQUE function, which may look like
           --     f = (\x y. blah) |> co
           -- We give it strictness but no boxity (#22502)
        set_lam_dmds [Demand]
    _ CoreExpr
    e = CoreExpr
    e
           -- In the OPAQUE case, the list of demands at this point might be
           -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997).

    finaliseLetBoxity
      :: AnalEnv
      -> 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 :: AnalEnv -> Type -> Demand -> Demand
    finaliseLetBoxity AnalEnv
    env Type
    ty Demand
    dmd
      = (Type, StrictnessMark, Demand) -> Demand
    go (Type
    ty, StrictnessMark
    NotMarkedStrict, Demand
    dmd)
      where
        go :: (Type,StrictnessMark,Demand) -> Demand
        go :: (Type, StrictnessMark, Demand) -> Demand
    go (Type
    ty, StrictnessMark
    str, dmd :: Demand
    dmd@(Card
    n :* SubDemand
    _)) =
          case AnalEnv
    -> Type
    -> StrictnessMark
    -> Demand
    -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    wantToUnboxArg AnalEnv
    env Type
    ty StrictnessMark
    str Demand
    dmd of
            UnboxingDecision [(Type, StrictnessMark, Demand)]
    DropAbsent      -> Demand
    dmd
            UnboxingDecision [(Type, StrictnessMark, Demand)]
    DontUnbox       -> Demand -> Demand
    trimBoxity Demand
    dmd
            DoUnbox [(Type, StrictnessMark, Demand)]
    triples -> Card
    n HasDebugCallStack => Card -> SubDemand -> Demand
    Card -> SubDemand -> Demand
    :* (Boxity -> [Demand] -> SubDemand
    mkProd Boxity
    Unboxed ([Demand] -> SubDemand) -> [Demand] -> SubDemand
    forall a b. (a -> b) -> a -> b
    $! ((Type, StrictnessMark, Demand) -> Demand)
    -> [(Type, StrictnessMark, Demand)] -> [Demand]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type, StrictnessMark, Demand) -> Demand
    go [(Type, StrictnessMark, Demand)]
    triples)

    wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand
                   -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    wantToUnboxArg :: AnalEnv
    -> Type
    -> StrictnessMark
    -> Demand
    -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    wantToUnboxArg AnalEnv
    env Type
    ty StrictnessMark
    str_mark dmd :: Demand
    dmd@(Card
    n :* SubDemand
    _)
      = case FamInstEnvs
    -> Type -> Demand -> UnboxingDecision (DataConPatContext Demand)
    canUnboxArg (AnalEnv -> FamInstEnvs
    ae_fam_envs AnalEnv
    env) Type
    ty Demand
    dmd of
          UnboxingDecision (DataConPatContext Demand)
    DropAbsent -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    forall unboxing_info. UnboxingDecision unboxing_info
    DropAbsent
          UnboxingDecision (DataConPatContext Demand)
    DontUnbox  -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    forall unboxing_info. UnboxingDecision unboxing_info
    DontUnbox

          DoUnbox (DataConPatContext{ dcpc_dc :: forall s. DataConPatContext s -> DataCon
    dcpc_dc      = DataCon
    dc
                                    , dcpc_tc_args :: forall s. DataConPatContext s -> [Type]
    dcpc_tc_args = [Type]
    tc_args
                                    , dcpc_args :: forall s. DataConPatContext s -> [s]
    dcpc_args    = [Demand]
    dmds })
           -- OK, so we /can/ unbox it; but do we /want/ to?
           | Bool -> Bool
    not (Card -> Bool
    isStrict Card
    n Bool -> Bool -> Bool
    || StrictnessMark -> Bool
    isMarkedStrict StrictnessMark
    str_mark)   -- Don't unbox a lazy field
             -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal
           -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    forall unboxing_info. UnboxingDecision unboxing_info
    DontUnbox

           | Type -> Bool
    doNotUnbox Type
    ty
           -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    forall unboxing_info. UnboxingDecision unboxing_info
    DontUnbox  -- See Note [Do not unbox class dictionaries]
                         -- NB: 'ty' has not been normalised, so this will (rightly)
                         --     catch newtype dictionaries too.
                         -- NB: even for bottoming functions, don't unbox dictionaries

           | IsRecDataConResult
    DefinitelyRecursive <- AnalEnv -> DataCon -> IsRecDataConResult
    ae_rec_dc AnalEnv
    env DataCon
    dc
             -- See Note [Which types are unboxed?]
             -- and Note [Demand analysis for recursive data constructors]
           -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    forall unboxing_info. UnboxingDecision unboxing_info
    DontUnbox

           | Bool
    otherwise  -- Bad cases dealt with: we want to unbox!
           -> [(Type, StrictnessMark, Demand)]
    -> UnboxingDecision [(Type, StrictnessMark, Demand)]
    forall unboxing_info.
    unboxing_info -> UnboxingDecision unboxing_info
    DoUnbox ([Type]
    -> [StrictnessMark] -> [Demand] -> [(Type, StrictnessMark, Demand)]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 (DataCon -> [Type] -> [Type]
    dubiousDataConInstArgTys DataCon
    dc [Type]
    tc_args)
                            (DataCon -> [StrictnessMark]
    dataConRepStrictness DataCon
    dc)
                            [Demand]
    dmds)

    doNotUnbox :: Type -> Bool
    -- Do not unbox class dictionaries, except equality classes and tuples
    -- Note [Do not unbox class dictionaries]
    doNotUnbox :: Type -> Bool
    doNotUnbox Type
    arg_ty
      = case Type -> Maybe TyCon
    tyConAppTyCon_maybe Type
    arg_ty of
          Just TyCon
    tc | Just Class
    cls <- TyCon -> Maybe Class
    tyConClass_maybe TyCon
    tc
                  -> Bool -> Bool
    not (Class -> Bool
    isEqualityClass Class
    cls Bool -> Bool -> Bool
    || Class -> Bool
    isCTupleClass Class
    cls)
           -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]

          Maybe TyCon
    _ -> Bool
    False

    {- Note [Do not unbox class dictionaries]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We never unbox class dictionaries in worker/wrapper.

    1. INLINABLE functions
       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.

       Historical note: #14955 describes how I got this fix wrong the first time.
       I got aware of the issue in T5075 by the change in boxity of loop between
       demand analysis runs.

    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.

    Wrinkle (DNB1): we /do/ want to unbox tuple dictionaries (#23398)
         f :: (% Eq a, Show a %) => blah
      with -fdicts-strict it is great to unbox to
         $wf :: Eq a => Show a => blah
      (where I have written out the currying explicitly).  Now we can specialise
      $wf on the Eq or Show dictionary.  Nothing is lost.

      And something is gained.  It is possible that `f` will look like this:
         f = /\a. \d:(% Eq a, Show a %). ... f @a (% sel1 d, sel2 d %)...
      where there is a recurive call to `f`, or to another function that takes the
      same tuple dictionary, but where the tuple is built from the components of
      `d`.  The Simplier does not fix this.  But if we unpacked the dictionary
      we'd get
         $wf = /\a. \(d1:Eq a) (d2:Show a). let d = (% d1, d2 %)
                 in ...f @a (% sel1 d, sel2 d %)
      and all the tuple building and taking apart will disappear.

    Wrinkle (DNB2): we /do/ want to unbox equality dictionaries,
      for (~), (~~), and Coercible (#23398).  Their payload is a single unboxed
      coercion.  We never want to specialise on `(t1 ~ t2)`.  All that would do is
      to make a copy of the function's RHS with a particular coercion.  Unlike
      normal class methods, that does not unlock any new optimisation
      opportunities in the specialised RHS.
    -}

    {- *********************************************************************
    *                                                                      *
                          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
    -> [(Id, CoreExpr)]
    -> (AnalEnv, WeakDmds, [(Id, CoreExpr)])
    dmdFix TopLevelFlag
    top_lvl AnalEnv
    env SubDemand
    let_dmd [(Id, CoreExpr)]
    orig_pairs
      = Arity -> [(Id, CoreExpr)] -> (AnalEnv, WeakDmds, [(Id, CoreExpr)])
    loop Arity
    1 [(Id, CoreExpr)]
    initial_pairs
      where
        opts :: DmdAnalOpts
    opts = AnalEnv -> DmdAnalOpts
    ae_opts AnalEnv
    env
        -- See Note [Initialising strictness]
        initial_pairs :: [(Id, CoreExpr)]
    initial_pairs | AnalEnv -> Bool
    ae_virgin AnalEnv
    env = [(DmdAnalOpts -> Id -> DmdSig -> Id
    setIdDmdAndBoxSig DmdAnalOpts
    opts Id
    id DmdSig
    botSig, CoreExpr
    rhs) | (Id
    id, CoreExpr
    rhs) <- [(Id, CoreExpr)]
    orig_pairs ]
                      | Bool
    otherwise     = [(Id, 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, [(Id, CoreExpr)])
    abort = (AnalEnv
    env, WeakDmds
    weak_fv', [(Id, CoreExpr)]
    zapped_pairs)
          where (WeakDmds
    weak_fv, [(Id, CoreExpr)]
    pairs') = Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])
    step Bool
    True ([(Id, CoreExpr)] -> [(Id, CoreExpr)]
    zapIdDmdSig [(Id, 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
    $ ((Id, CoreExpr) -> WeakDmds) -> [(Id, CoreExpr)] -> [WeakDmds]
    forall a b. (a -> b) -> [a] -> [b]
    map (DmdEnv -> WeakDmds
    de_fvs (DmdEnv -> WeakDmds)
    -> ((Id, CoreExpr) -> DmdEnv) -> (Id, CoreExpr) -> WeakDmds
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DmdSig -> DmdEnv
    dmdSigDmdEnv (DmdSig -> DmdEnv)
    -> ((Id, CoreExpr) -> DmdSig) -> (Id, CoreExpr) -> DmdEnv
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> DmdSig
    idDmdSig (Id -> DmdSig)
    -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> DmdSig
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Id, CoreExpr) -> Id
    forall a b. (a, b) -> a
    fst) [(Id, 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 :: [(Id, CoreExpr)]
    zapped_pairs = [(Id, CoreExpr)] -> [(Id, CoreExpr)]
    zapIdDmdSig [(Id, 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 -> [(Id, CoreExpr)] -> (AnalEnv, WeakDmds, [(Id, CoreExpr)])
    loop Arity
    n [(Id, CoreExpr)]
    pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)
                       --                                   | (id,_) <- pairs]) $
                       Arity -> [(Id, CoreExpr)] -> (AnalEnv, WeakDmds, [(Id, CoreExpr)])
    loop' Arity
    n [(Id, CoreExpr)]
    pairs

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

        step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])
        step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])
    step Bool
    first_round [(Id, CoreExpr)]
    pairs = (WeakDmds
    weak_fv, [(Id, 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 -> [Id] -> AnalEnv
    extendAnalEnvs TopLevelFlag
    top_lvl AnalEnv
    start_env (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map (Id, CoreExpr) -> Id
    forall a b. (a, b) -> a
    fst [(Id, CoreExpr)]
    pairs), WeakDmds
    forall a. VarEnv a
    emptyVarEnv)

            !((AnalEnv
    _,!WeakDmds
    weak_fv), ![(Id, CoreExpr)]
    pairs') = ((AnalEnv, WeakDmds)
     -> (Id, CoreExpr) -> ((AnalEnv, WeakDmds), (Id, CoreExpr)))
    -> (AnalEnv, WeakDmds)
    -> [(Id, CoreExpr)]
    -> ((AnalEnv, WeakDmds), [(Id, CoreExpr)])
    forall (t :: * -> *) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL (AnalEnv, WeakDmds)
    -> (Id, CoreExpr) -> ((AnalEnv, WeakDmds), (Id, CoreExpr))
    my_downRhs (AnalEnv, WeakDmds)
    start [(Id, 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)
    -> (Id, CoreExpr) -> ((AnalEnv, WeakDmds), (Id, CoreExpr))
    my_downRhs (AnalEnv
    env, WeakDmds
    weak_fv) (Id
    id,CoreExpr
    rhs)
              = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $
                ((AnalEnv
    env', WeakDmds
    weak_fv'), (Id
    id', CoreExpr
    rhs'))
              where
                !(!AnalEnv
    env', !WeakDmds
    weak_fv1, !Id
    id', !CoreExpr
    rhs') = TopLevelFlag
    -> RecFlag
    -> AnalEnv
    -> SubDemand
    -> Id
    -> CoreExpr
    -> (AnalEnv, WeakDmds, Id, CoreExpr)
    dmdAnalRhsSig TopLevelFlag
    top_lvl RecFlag
    Recursive AnalEnv
    env SubDemand
    let_dmd Id
    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 :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
    zapIdDmdSig [(Id, CoreExpr)]
    pairs = [(Id -> DmdSig -> Id
    setIdDmdSig Id
    id DmdSig
    nopSig, CoreExpr
    rhs) | (Id
    id, CoreExpr
    rhs) <- [(Id, 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 bottom 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 recursive.
    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
    $ (Id -> Demand) -> VarEnv Id -> WeakDmds
    forall a b. (a -> b) -> VarEnv a -> VarEnv b
    mapVarEnv (Demand -> Id -> Demand
    forall a b. a -> b -> a
    const Demand
    topDmd) (VarEnv Id -> WeakDmds) -> VarEnv Id -> WeakDmds
    forall a b. (a -> b) -> a -> b
    $ VarSet -> VarEnv Id
    forall a. UniqSet a -> UniqFM a a
    getUniqSet (VarSet -> VarEnv Id) -> VarSet -> VarEnv Id
    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 -> Id -> Demand -> DmdType
    addVarDmd (DmdType DmdEnv
    fv [Demand]
    ds) Id
    var Demand
    dmd
      = DmdEnv -> [Demand] -> DmdType
    DmdType (DmdEnv -> Id -> Demand -> DmdEnv
    addVarDmdEnv DmdEnv
    fv Id
    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 => [Id] -> [Demand] -> [Id]
    setBndrsDemandInfo (Id
    b:[Id]
    bs) [Demand]
    ds
      | Id -> Bool
    isTyVar Id
    b = Id
    b Id -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    : HasCallStack => [Id] -> [Demand] -> [Id]
    [Id] -> [Demand] -> [Id]
    setBndrsDemandInfo [Id]
    bs [Demand]
    ds
    setBndrsDemandInfo (Id
    b:[Id]
    bs) (Demand
    d:[Demand]
    ds) =
        let !new_info :: Id
    new_info = Id -> Demand -> Id
    setIdDemandInfo Id
    b Demand
    d
            !vars :: [Id]
    vars = HasCallStack => [Id] -> [Demand] -> [Id]
    [Id] -> [Demand] -> [Id]
    setBndrsDemandInfo [Id]
    bs [Demand]
    ds
        in Id
    new_info Id -> [Id] -> [Id]
    forall a. a -> [a] -> [a]
    : [Id]
    vars
    setBndrsDemandInfo [] [Demand]
    ds = Bool -> [Id] -> [Id]
    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 [Id]
    bs [Demand]
    _  = String -> SDoc -> [Id]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "setBndrsDemandInfo" ([Id] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Id]
    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 -> Id -> WithDmdType Id
    annotateLamIdBndr AnalEnv
    env DmdType
    dmd_ty Id
    id
    -- For lambdas we add the demand to the argument demands
    -- Only called for Ids
      = Bool -> WithDmdType Id -> WithDmdType Id
    forall a. HasCallStack => Bool -> a -> a
    assert (Id -> Bool
    isId Id
    id) (WithDmdType Id -> WithDmdType Id)
    -> WithDmdType Id -> WithDmdType Id
    forall a b. (a -> b) -> a -> b
    $
        -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $
        DmdType -> Id -> WithDmdType Id
    forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    main_ty Id
    new_id
      where
        new_id :: Id
    new_id  = Id -> Demand -> Id
    setIdDemandInfo Id
    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 -> Id -> WithDmdType Demand
    findBndrDmd AnalEnv
    env DmdType
    dmd_ty Id
    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
    forall doc. IsLine doc => String -> doc
    text String
    "AE" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces ([SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat
             [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "ae_virgin =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Bool -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (AnalEnv -> Bool
    ae_virgin AnalEnv
    env)
             , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "ae_sigs =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> 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 Id -> AnalEnv -> AnalEnv
    enterDFun Bind Id
    bind AnalEnv
    env
      | (Id -> Bool) -> [Id] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any Id -> Bool
    isDFunId (Bind Id -> [Id]
    forall b. Bind b -> [b]
    bindersOf Bind Id
    bind)
      = AnalEnv
    env { ae_opts = (ae_opts env) { dmd_strict_dicts = 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 -> [Id] -> AnalEnv
    extendAnalEnvs TopLevelFlag
    top_lvl AnalEnv
    env [Id]
    vars
      = AnalEnv
    env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }

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

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

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

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

    addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv
    addInScopeAnalEnv :: AnalEnv -> Id -> AnalEnv
    addInScopeAnalEnv AnalEnv
    env Id
    id = AnalEnv
    env { ae_sigs = delVarEnv (ae_sigs env) id }

    addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv
    addInScopeAnalEnvs :: AnalEnv -> [Id] -> AnalEnv
    addInScopeAnalEnvs AnalEnv
    env [Id]
    ids = AnalEnv
    env { ae_sigs = delVarEnvList (ae_sigs env) ids }

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

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

    findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand
    -- See Note [Trimming a demand to a type]
    findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand
    findBndrDmd AnalEnv
    env DmdType
    dmd_ty Id
    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 -> Id -> (DmdType, Demand)
    peelFV DmdType
    dmd_ty Id
    id

        id_ty :: Type
    id_ty = Id -> Type
    idType Id
    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 extremely 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 (C(M,..)) /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.

    -}