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

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

    {-# LANGUAGE CPP #-}

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

    #include "HsVersions.h"

    import GHC.Prelude

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

    -- import GHC.Driver.Ppr

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

    -- | Options for the demand analysis
    newtype DmdAnalOpts = DmdAnalOpts
       { DmdAnalOpts -> Bool
    dmd_strict_dicts :: Bool -- ^ Use strict dictionaries
       }

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

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

    data DmdResult a b = R !a !b

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

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

        add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType
        add_exported_uses :: AnalEnv -> DmdType -> [Var] -> DmdType
    add_exported_uses AnalEnv
    env = forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (AnalEnv -> DmdType -> Var -> DmdType
    add_exported_use AnalEnv
    env)

        -- | If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@
        -- corresponds to the demand type of @(id, e)@, but is a lot more direct.
        -- See Note [Analysing top-level bindings].
        add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType
        add_exported_use :: AnalEnv -> DmdType -> Var -> DmdType
    add_exported_use AnalEnv
    env DmdType
    dmd_ty Var
    id
          | Var -> Bool
    isExportedId Var
    id Bool -> Bool -> Bool
    || Var -> VarSet -> Bool
    elemVarSet Var
    id VarSet
    rule_fvs
          -- See Note [Absence analysis for stable unfoldings and RULES]
          = DmdType
    dmd_ty DmdType -> PlusDmdArg -> DmdType
    `plusDmdType` forall a b. (a, b) -> a
    fst (AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr)
    dmdAnalStar AnalEnv
    env Demand
    topDmd (forall b. Var -> Expr b
    Var Var
    id))
          | Bool
    otherwise
          = DmdType
    dmd_ty

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    -- Do not process absent demands
    -- Otherwise act like in a normal demand analysis
    -- See ↦* relation in the Cardinality Analysis paper
    dmdAnalStar :: AnalEnv
                -> Demand   -- This one takes a *Demand*
                -> CoreExpr -- Should obey the let/app invariant
                -> (PlusDmdArg, CoreExpr)
    dmdAnalStar :: AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr)
    dmdAnalStar AnalEnv
    env (Card
    n :* SubDemand
    cd) CoreExpr
    e
      | WithDmdType DmdType
    dmd_ty CoreExpr
    e'    <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
    dmdAnal AnalEnv
    env SubDemand
    cd CoreExpr
    e
      = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
        -- The argument 'e' should satisfy the let/app invariant
        -- See Note [Analysing with absent demand] in GHC.Types.Demand
        (DmdType -> PlusDmdArg
    toPlusDmdArg forall a b. (a -> b) -> a -> b
    $ Card -> DmdType -> DmdType
    multDmdType Card
    n DmdType
    dmd_ty, CoreExpr
    e')

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

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

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

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

    dmdAnal' AnalEnv
    env SubDemand
    dmd (Cast CoreExpr
    e Coercion
    co)
      = forall a. DmdType -> a -> WithDmdType a
    WithDmdType (DmdType
    dmd_ty DmdType -> PlusDmdArg -> DmdType
    `plusDmdType` DmdEnv -> PlusDmdArg
    mkPlusDmdArg (Coercion -> DmdEnv
    coercionDmdEnv Coercion
    co)) (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)
      = forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    dmd_ty (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))
      = forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    fun_ty (forall b. Expr b -> Expr b -> Expr b
    App CoreExpr
    fun' (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
            (PlusDmdArg
    arg_ty, CoreExpr
    arg')    = AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr)
    dmdAnalStar AnalEnv
    env (CoreExpr -> Demand -> Demand
    dmdTransformThunkDmd CoreExpr
    arg Demand
    arg_dmd) CoreExpr
    arg
        in
    --    pprTrace "dmdAnal:app" (vcat
    --         [ text "dmd =" <+> ppr dmd
    --         , text "expr =" <+> ppr (App fun arg)
    --         , text "fun dmd_ty =" <+> ppr fun_ty
    --         , text "arg dmd =" <+> ppr arg_dmd
    --         , text "arg dmd_ty =" <+> ppr arg_ty
    --         , text "res dmd_ty =" <+> ppr res_ty
    --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
        forall a. DmdType -> a -> WithDmdType a
    WithDmdType (DmdType
    res_ty DmdType -> PlusDmdArg -> DmdType
    `plusDmdType` PlusDmdArg
    arg_ty) (forall b. Expr b -> Expr b -> Expr b
    App CoreExpr
    fun' CoreExpr
    arg')

    dmdAnal' AnalEnv
    env SubDemand
    dmd (Lam Var
    var CoreExpr
    body)
      | Var -> Bool
    isTyVar Var
    var
      = let
            WithDmdType DmdType
    body_ty CoreExpr
    body' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
    dmdAnal AnalEnv
    env SubDemand
    dmd CoreExpr
    body
        in
        forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    body_ty (forall b. b -> Expr b -> Expr b
    Lam Var
    var CoreExpr
    body')

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

            WithDmdType DmdType
    body_ty CoreExpr
    body' = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
    dmdAnal AnalEnv
    env SubDemand
    body_dmd CoreExpr
    body
            WithDmdType DmdType
    lam_ty Var
    var'   = AnalEnv -> Bool -> DmdType -> Var -> WithDmdType Var
    annotateLamIdBndr AnalEnv
    env Bool
    notArgOfDfun DmdType
    body_ty Var
    var
            new_dmd_type :: DmdType
    new_dmd_type = Card -> DmdType -> DmdType
    multDmdType Card
    n DmdType
    lam_ty
        in
        forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    new_dmd_type (forall b. b -> Expr b -> Expr b
    Lam Var
    var' CoreExpr
    body')

    dmdAnal' AnalEnv
    env SubDemand
    dmd (Case CoreExpr
    scrut Var
    case_bndr Type
    ty [Alt AltCon
    alt [Var]
    bndrs CoreExpr
    rhs])
      -- Only one alternative.
      -- If it's a DataAlt, it should be the only constructor of the type.
      | AltCon -> Bool
    is_single_data_alt AltCon
    alt
      = let
            WithDmdType DmdType
    rhs_ty CoreExpr
    rhs'           = AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
    dmdAnal AnalEnv
    env SubDemand
    dmd CoreExpr
    rhs
            WithDmdType DmdType
    alt_ty1 [Demand]
    dmds          = AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
    findBndrsDmds AnalEnv
    env DmdType
    rhs_ty [Var]
    bndrs
            WithDmdType DmdType
    alt_ty2 Demand
    case_bndr_dmd = AnalEnv -> Bool -> DmdType -> Var -> WithDmdType Demand
    findBndrDmd AnalEnv
    env Bool
    False DmdType
    alt_ty1 Var
    case_bndr
            -- Evaluation cardinality on the case binder is irrelevant and a no-op.
            -- What matters is its nested sub-demand!
            (Card
    _ :* SubDemand
    case_bndr_sd)      = Demand
    case_bndr_dmd
            -- Compute demand on the scrutinee
            -- FORCE the result, otherwise thunks will end up retaining the
            -- whole DmdEnv
            !(![Var]
    bndrs', !SubDemand
    scrut_sd)
              | DataAlt DataCon
    _ <- AltCon
    alt
              , [Demand]
    id_dmds <- SubDemand -> [Demand] -> [Demand]
    addCaseBndrDmd SubDemand
    case_bndr_sd [Demand]
    dmds
              -- See Note [Demand on scrutinee of a product case]
              = let !new_info :: [Var]
    new_info = [Var] -> [Demand] -> [Var]
    setBndrsDemandInfo [Var]
    bndrs [Demand]
    id_dmds
                    !new_prod :: SubDemand
    new_prod = [Demand] -> SubDemand
    mkProd [Demand]
    id_dmds
                in ([Var]
    new_info, SubDemand
    new_prod)
              | Bool
    otherwise
              -- __DEFAULT and literal alts. Simply add demands and discard the
              -- evaluation cardinality, as we evaluate the scrutinee exactly once.
              = ASSERT( null bndrs ) (bndrs, case_bndr_sd)
            fam_envs :: FamInstEnvs
    fam_envs                 = AnalEnv -> FamInstEnvs
    ae_fam_envs AnalEnv
    env
            alt_ty3 :: DmdType
    alt_ty3
              -- 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_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 -> PlusDmdArg -> DmdType
    `plusDmdType` DmdType -> PlusDmdArg
    toPlusDmdArg DmdType
    scrut_ty
            !case_bndr' :: Var
    case_bndr'        = Var -> Demand -> Var
    setIdDemandInfo Var
    case_bndr Demand
    case_bndr_dmd
        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 ]) $
        forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    res_ty (forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case CoreExpr
    scrut' Var
    case_bndr' Type
    ty [forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    alt [Var]
    bndrs' CoreExpr
    rhs'])
        where
          is_single_data_alt :: AltCon -> Bool
    is_single_data_alt (DataAlt DataCon
    dc) = forall a. Maybe a -> Bool
    isJust forall a b. (a -> b) -> a -> b
    $ TyCon -> Maybe DataCon
    tyConSingleAlgDataCon_maybe forall a b. (a -> b) -> a -> b
    $ DataCon -> TyCon
    dataConTyCon DataCon
    dc
          is_single_data_alt AltCon
    _            = Bool
    True

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

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

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

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

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

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

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

    dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var)
    dmdAnalSumAlt :: AnalEnv -> SubDemand -> Var -> Alt Var -> WithDmdType (Alt Var)
    dmdAnalSumAlt AnalEnv
    env SubDemand
    dmd Var
    case_bndr (Alt AltCon
    con [Var]
    bndrs CoreExpr
    rhs)
      | WithDmdType DmdType
    rhs_ty CoreExpr
    rhs' <- AnalEnv -> SubDemand -> CoreExpr -> WithDmdType CoreExpr
    dmdAnal AnalEnv
    env SubDemand
    dmd CoreExpr
    rhs
      , WithDmdType DmdType
    alt_ty [Demand]
    dmds <- AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
    findBndrsDmds AnalEnv
    env DmdType
    rhs_ty [Var]
    bndrs
      , let (Card
    _ :* SubDemand
    case_bndr_sd) = DmdType -> Var -> Demand
    findIdDemand DmdType
    alt_ty Var
    case_bndr
            -- See Note [Demand on scrutinee of a product case]
            id_dmds :: [Demand]
    id_dmds             = SubDemand -> [Demand] -> [Demand]
    addCaseBndrDmd SubDemand
    case_bndr_sd [Demand]
    dmds
            -- Do not put a thunk into the Alt
            !new_ids :: [Var]
    new_ids  = [Var] -> [Demand] -> [Var]
    setBndrsDemandInfo [Var]
    bndrs [Demand]
    id_dmds
      = forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    alt_ty (forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    con [Var]
    new_ids CoreExpr
    rhs')

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    Note [Demand 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] in GHC.Types.Demand.
    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 [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 strictness environment
                 -> Id              -- ^ The function
                 -> SubDemand       -- ^ The demand on the function
                 -> DmdType         -- ^ The demand type of the function in this context
                                    -- Returned DmdEnv includes the demand on
                                    -- this function plus demand on its free variables

    -- See Note [What are demand signatures?] in "GHC.Types.Demand"
    dmdTransform :: AnalEnv -> Var -> SubDemand -> DmdType
    dmdTransform AnalEnv
    env Var
    var SubDemand
    dmd
      -- Data constructors
      | Var -> Bool
    isDataConWorkId Var
    var
      = Arity -> SubDemand -> DmdType
    dmdTransformDataConSig (Var -> Arity
    idArity Var
    var) SubDemand
    dmd
      -- Dictionary component selectors
      -- Used to be controlled by a flag.
      -- See #18429 for some perf measurements.
      | Just Class
    _ <- Var -> Maybe Class
    isClassOpId_maybe Var
    var
      = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $
        StrictSig -> SubDemand -> DmdType
    dmdTransformDictSelSig (Var -> StrictSig
    idStrictness Var
    var) SubDemand
    dmd
      -- Imported functions
      | Var -> Bool
    isGlobalId Var
    var
      , let res :: DmdType
    res = StrictSig -> SubDemand -> DmdType
    dmdTransformSig (Var -> StrictSig
    idStrictness Var
    var) SubDemand
    dmd
      = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, 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 (StrictSig
    sig, TopLevelFlag
    top_lvl) <- AnalEnv -> Var -> Maybe (StrictSig, TopLevelFlag)
    lookupSigEnv AnalEnv
    env Var
    var
      , let fn_ty :: DmdType
    fn_ty = StrictSig -> SubDemand -> DmdType
    dmdTransformSig StrictSig
    sig SubDemand
    dmd
      = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
        case TopLevelFlag
    top_lvl of
          TopLevelFlag
    NotTopLevel -> DmdType -> Var -> Demand -> DmdType
    addVarDmd DmdType
    fn_ty Var
    var (Card
    C_11 Card -> SubDemand -> Demand
    :* SubDemand
    dmd)
          TopLevelFlag
    TopLevel
            | Var -> Bool
    isInterestingTopLevelFn Var
    var
            -- Top-level things will be used multiple times or not at
            -- all anyway, hence the multDmd below: It means we don't
            -- have to track whether @var@ is used strictly or at most
            -- once, because ultimately it never will.
            -> DmdType -> Var -> Demand -> DmdType
    addVarDmd DmdType
    fn_ty Var
    var (Card
    C_0N Card -> Demand -> Demand
    `multDmd` (Card
    C_11 Card -> SubDemand -> Demand
    :* SubDemand
    dmd)) -- 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 sig, ppr dmd, ppr res]) $
        DmdEnv -> DmdType
    unitDmdType (forall a. Var -> a -> VarEnv a
    unitVarEnv Var
    var (Card
    C_11 Card -> SubDemand -> Demand
    :* SubDemand
    dmd))

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

    -- | @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, DmdEnv, Id, CoreExpr)
    -- Process the RHS of the binding, add the strictness signature
    -- to the Id, and augment the environment with the signature as well.
    -- See Note [NOINLINE and strictness]
    dmdAnalRhsSig :: TopLevelFlag
    -> RecFlag
    -> AnalEnv
    -> SubDemand
    -> Var
    -> CoreExpr
    -> (AnalEnv, DmdEnv, Var, CoreExpr)
    dmdAnalRhsSig TopLevelFlag
    top_lvl RecFlag
    rec_flag AnalEnv
    env SubDemand
    let_dmd Var
    id CoreExpr
    rhs
      = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $
        (AnalEnv
    env', DmdEnv
    lazy_fv, Var
    id', CoreExpr
    rhs')
      where
        rhs_arity :: Arity
    rhs_arity = Var -> Arity
    idArity Var
    id
        -- See Note [Demand signatures are computed for a threshold demand based on idArity]
        rhs_dmd :: SubDemand
    rhs_dmd -- See Note [Demand analysis for join points]
                -- See Note [Invariants on join points] invariant 2b, in GHC.Core
                --     rhs_arity matches the join arity of the join point
                | Var -> Bool
    isJoinId Var
    id
                = Arity -> SubDemand -> SubDemand
    mkCalledOnceDmds Arity
    rhs_arity SubDemand
    let_dmd
                | Bool
    otherwise
                = Arity -> SubDemand -> SubDemand
    mkCalledOnceDmds Arity
    rhs_arity 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_fv [Demand]
    rhs_dmds Divergence
    rhs_div = DmdType
    rhs_dmd_ty

        sig :: StrictSig
    sig = Arity -> DmdType -> StrictSig
    mkStrictSigForArity Arity
    rhs_arity (DmdEnv -> [Demand] -> Divergence -> DmdType
    DmdType DmdEnv
    sig_fv [Demand]
    rhs_dmds Divergence
    rhs_div)

        id' :: Var
    id' = Var
    id Var -> StrictSig -> Var
    `setIdStrictness` StrictSig
    sig
        !env' :: AnalEnv
    env' = TopLevelFlag -> AnalEnv -> Var -> StrictSig -> AnalEnv
    extendAnalEnv TopLevelFlag
    top_lvl AnalEnv
    env Var
    id' StrictSig
    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.
        rhs_fv1 :: DmdEnv
    rhs_fv1 = case RecFlag
    rec_flag of
                    RecFlag
    Recursive    -> DmdEnv -> DmdEnv
    reuseEnv DmdEnv
    rhs_fv
                    RecFlag
    NonRecursive -> DmdEnv
    rhs_fv

        -- See Note [Absence analysis for stable unfoldings and RULES]
        rhs_fv2 :: DmdEnv
    rhs_fv2 = DmdEnv
    rhs_fv1 DmdEnv -> VarSet -> DmdEnv
    `keepAliveDmdEnv` Var -> VarSet
    bndrRuleAndUnfoldingIds Var
    id

        -- See Note [Lazy and unleashable free variables]
        !(!DmdEnv
    lazy_fv, !DmdEnv
    sig_fv) = forall a. (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)
    partitionVarEnv Demand -> Bool
    isWeakDmd DmdEnv
    rhs_fv2

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

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

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

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

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

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

    Another win for join points!  #13543.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    Consider the following expression, for example:

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

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

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

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

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

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

    Note [Absence analysis for stable unfoldings and RULES]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Ticket #18638 shows that it's really important to do absence analysis
    for stable unfoldings. 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, adjust its DmdEnv (the demands
    on its free variables) so that no variable mentioned in its unfolding
    is Absent.  This is done by the function Demand.keepAliveDmdEnv.

    ALSO: do the same for Ids free in the RHS of any RULES for f.

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

    Historical Note [Product demands for function body]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    In 2013 I spotted this example, in shootout/binary_trees:

        Main.check' = \ b z ds. case z of z' { I# ip ->
                                    case ds_d13s of
                                      Main.Nil -> z'
                                      Main.Node s14k s14l s14m ->
                                        Main.check' (not b)
                                          (Main.check' b
                                             (case b {
                                                False -> I# (-# s14h s14k);
                                                True  -> I# (+# s14h s14k)
                                              })
                                             s14l)
                                         s14m   }   }   }

    Here we *really* want to unbox z, even though it appears to be used boxed in
    the Nil case.  Partly the Nil case is not a hot path.  But more specifically,
    the whole function gets the CPR property if we do.

    That motivated using a demand of C1(C1(C1(P(L,L)))) for the RHS, where
    (solely because the result was a product) we used a product demand
    (albeit with lazy components) for the body. But that gives very silly
    behaviour -- see #17932.   Happily it turns out now to be entirely
    unnecessary: we get good results with C1(C1(C1(L))).   So I simply
    deleted the special case.
    -}

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

    -- Recursive bindings
    dmdFix :: TopLevelFlag
           -> AnalEnv                            -- Does not include bindings for this binding
           -> SubDemand
           -> [(Id,CoreExpr)]
           -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info

    dmdFix :: TopLevelFlag
    -> AnalEnv
    -> SubDemand
    -> [(Var, CoreExpr)]
    -> (AnalEnv, DmdEnv, [(Var, CoreExpr)])
    dmdFix TopLevelFlag
    top_lvl AnalEnv
    env SubDemand
    let_dmd [(Var, CoreExpr)]
    orig_pairs
      = Arity -> [(Var, CoreExpr)] -> (AnalEnv, DmdEnv, [(Var, CoreExpr)])
    loop Arity
    1 [(Var, CoreExpr)]
    initial_pairs
      where
        -- See Note [Initialising strictness]
        initial_pairs :: [(Var, CoreExpr)]
    initial_pairs | AnalEnv -> Bool
    ae_virgin AnalEnv
    env = [(Var -> StrictSig -> Var
    setIdStrictness Var
    id StrictSig
    botSig, CoreExpr
    rhs) | (Var
    id, CoreExpr
    rhs) <- [(Var, CoreExpr)]
    orig_pairs ]
                      | Bool
    otherwise     = [(Var, CoreExpr)]
    orig_pairs

        -- If fixed-point iteration does not yield a result we use this instead
        -- See Note [Safe abortion in the fixed-point iteration]
        abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
        abort :: (AnalEnv, DmdEnv, [(Var, CoreExpr)])
    abort = (AnalEnv
    env, DmdEnv
    lazy_fv', [(Var, CoreExpr)]
    zapped_pairs)
          where (DmdEnv
    lazy_fv, [(Var, CoreExpr)]
    pairs') = Bool -> [(Var, CoreExpr)] -> (DmdEnv, [(Var, CoreExpr)])
    step Bool
    True ([(Var, CoreExpr)] -> [(Var, CoreExpr)]
    zapIdStrictness [(Var, CoreExpr)]
    orig_pairs)
                -- Note [Lazy and unleashable free variables]
                non_lazy_fvs :: DmdEnv
    non_lazy_fvs = forall a. [VarEnv a] -> VarEnv a
    plusVarEnvList forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (StrictSig -> DmdEnv
    strictSigDmdEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Var -> StrictSig
    idStrictness forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a b. (a, b) -> a
    fst) [(Var, CoreExpr)]
    pairs'
                lazy_fv' :: DmdEnv
    lazy_fv'     = DmdEnv
    lazy_fv forall a. VarEnv a -> VarEnv a -> VarEnv a
    `plusVarEnv` forall a b. (a -> b) -> VarEnv a -> VarEnv b
    mapVarEnv (forall a b. a -> b -> a
    const Demand
    topDmd) DmdEnv
    non_lazy_fvs
                zapped_pairs :: [(Var, CoreExpr)]
    zapped_pairs = [(Var, CoreExpr)] -> [(Var, CoreExpr)]
    zapIdStrictness [(Var, CoreExpr)]
    pairs'

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

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

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

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

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

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

        zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
        zapIdStrictness :: [(Var, CoreExpr)] -> [(Var, CoreExpr)]
    zapIdStrictness [(Var, CoreExpr)]
    pairs = [(Var -> StrictSig -> Var
    setIdStrictness Var
    id StrictSig
    nopSig, CoreExpr
    rhs) | (Var
    id, CoreExpr
    rhs) <- [(Var, CoreExpr)]
    pairs ]

    {- Note [Safe abortion in the fixed-point iteration]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Fixed-point iteration may fail to terminate. But we cannot simply give up and
    return the environment and code unchanged! We still need to do one additional
    round, for two reasons:

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

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

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

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

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

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

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

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

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

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

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

    -}

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

    unitDmdType :: DmdEnv -> DmdType
    unitDmdType :: DmdEnv -> DmdType
    unitDmdType DmdEnv
    dmd_env = DmdEnv -> [Demand] -> Divergence -> DmdType
    DmdType DmdEnv
    dmd_env [] Divergence
    topDiv

    coercionDmdEnv :: Coercion -> DmdEnv
    coercionDmdEnv :: Coercion -> DmdEnv
    coercionDmdEnv Coercion
    co = forall a b. (a -> b) -> VarEnv a -> VarEnv b
    mapVarEnv (forall a b. a -> b -> a
    const Demand
    topDmd) (forall a. UniqSet a -> UniqFM a a
    getUniqSet forall a b. (a -> b) -> a -> b
    $ Coercion -> VarSet
    coVarsOfCo Coercion
    co)
                        -- The VarSet from coVarsOfCo is really a VarEnv Var

    addVarDmd :: DmdType -> Var -> Demand -> DmdType
    addVarDmd :: DmdType -> Var -> Demand -> DmdType
    addVarDmd (DmdType DmdEnv
    fv [Demand]
    ds Divergence
    res) Var
    var Demand
    dmd
      = DmdEnv -> [Demand] -> Divergence -> DmdType
    DmdType (forall a. (a -> a -> a) -> VarEnv a -> Var -> a -> VarEnv a
    extendVarEnv_C Demand -> Demand -> Demand
    plusDmd DmdEnv
    fv Var
    var Demand
    dmd) [Demand]
    ds Divergence
    res

    addLazyFVs :: DmdType -> DmdEnv -> DmdType
    addLazyFVs :: DmdType -> DmdEnv -> DmdType
    addLazyFVs DmdType
    dmd_ty DmdEnv
    lazy_fvs
      = DmdType
    dmd_ty DmdType -> PlusDmdArg -> DmdType
    `plusDmdType` DmdEnv -> PlusDmdArg
    mkPlusDmdArg DmdEnv
    lazy_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 lazy_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.

    {-
    Note [Do not strictify the argument dictionaries of a dfun]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The typechecker can tie recursive knots involving dfuns, so we do the
    conservative thing and refrain from strictifying a dfun's argument
    dictionaries.
    -}

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

    annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var
    -- The returned env has the var deleted
    -- The returned var is annotated with demand info
    -- according to the result demand of the provided demand type
    -- No effect on the argument demands
    annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var
    annotateBndr AnalEnv
    env DmdType
    dmd_ty Var
    var
      | Var -> Bool
    isId Var
    var  = forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    dmd_ty' Var
    new_id
      | Bool
    otherwise = forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    dmd_ty  Var
    var
      where
        new_id :: Var
    new_id = Var -> Demand -> Var
    setIdDemandInfo Var
    var Demand
    dmd
        WithDmdType DmdType
    dmd_ty' Demand
    dmd = AnalEnv -> Bool -> DmdType -> Var -> WithDmdType Demand
    findBndrDmd AnalEnv
    env Bool
    False DmdType
    dmd_ty Var
    var

    annotateLamIdBndr :: AnalEnv
                      -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
                      -> DmdType    -- Demand type of body
                      -> Id         -- Lambda binder
                      -> WithDmdType Id  -- Demand type of lambda
                                         -- and binder annotated with demand

    annotateLamIdBndr :: AnalEnv -> Bool -> DmdType -> Var -> WithDmdType Var
    annotateLamIdBndr AnalEnv
    env Bool
    arg_of_dfun DmdType
    dmd_ty Var
    id
    -- For lambdas we add the demand to the argument demands
    -- Only called for Ids
      = ASSERT( isId id )
        -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $
        forall a. DmdType -> a -> WithDmdType a
    WithDmdType DmdType
    final_ty Var
    new_id
      where
        new_id :: Var
    new_id = Var -> Demand -> Var
    setIdDemandInfo Var
    id Demand
    dmd
          -- Watch out!  See note [Lambda-bound unfoldings]
        final_ty :: DmdType
    final_ty = case Unfolding -> Maybe CoreExpr
    maybeUnfoldingTemplate (Var -> Unfolding
    idUnfolding Var
    id) of
                     Maybe CoreExpr
    Nothing  -> DmdType
    main_ty
                     Just CoreExpr
    unf -> DmdType
    main_ty DmdType -> PlusDmdArg -> DmdType
    `plusDmdType` PlusDmdArg
    unf_ty
                              where
                                 (PlusDmdArg
    unf_ty, CoreExpr
    _) = AnalEnv -> Demand -> CoreExpr -> (PlusDmdArg, CoreExpr)
    dmdAnalStar AnalEnv
    env Demand
    dmd CoreExpr
    unf

        main_ty :: DmdType
    main_ty = Demand -> DmdType -> DmdType
    addDemand Demand
    dmd DmdType
    dmd_ty'
        WithDmdType DmdType
    dmd_ty' Demand
    dmd = AnalEnv -> Bool -> DmdType -> Var -> WithDmdType Demand
    findBndrDmd AnalEnv
    env Bool
    arg_of_dfun DmdType
    dmd_ty Var
    id

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

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

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

    Another example:

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

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

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

            ON THE OTHER HAND

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

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

    and

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

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

    But now the signature lies! (Missing variables are assumed to be absent.) To
    make up for this, the code that analyses the binding keeps the demand on those
    variable separate (usually called "lazy_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 "lazy_fv" returned by "dmdFix".

    Note [Lambda-bound unfoldings]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We allow a lambda-bound variable to carry an unfolding, a facility that is used
    exclusively for join points; see Note [Case binders and join points].  If so,
    we must be careful to demand-analyse the RHS of the unfolding!  Example
       \x. \y{=Just x}. <body>
    Then if <body> uses 'y', then transitively it uses 'x', and we must not
    forget that fact, otherwise we might make 'x' absent when it isn't.

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

    type DFunFlag = Bool  -- indicates if the lambda being considered is in the
                          -- sequence of lambdas at the top of the RHS of a dfun
    notArgOfDfun :: DFunFlag
    notArgOfDfun :: Bool
    notArgOfDfun = Bool
    False

    data AnalEnv = AE
       { AnalEnv -> Bool
    ae_strict_dicts :: !Bool -- ^ Enable strict dict
       , 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
       }

            -- 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 (StrictSig, TopLevelFlag)

    instance Outputable AnalEnv where
      ppr :: AnalEnv -> SDoc
    ppr AnalEnv
    env = String -> SDoc
    text String
    "AE" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    braces ([SDoc] -> SDoc
    vcat
             [ String -> SDoc
    text String
    "ae_virgin =" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr (AnalEnv -> Bool
    ae_virgin AnalEnv
    env)
             , String -> SDoc
    text String
    "ae_strict_dicts =" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr (AnalEnv -> Bool
    ae_strict_dicts AnalEnv
    env)
             , String -> SDoc
    text String
    "ae_sigs =" SDoc -> SDoc -> 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_strict_dicts :: Bool
    ae_strict_dicts = DmdAnalOpts -> Bool
    dmd_strict_dicts 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
             }

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

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

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

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

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

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

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

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

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

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

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

        strictify :: Demand -> Demand
    strictify Demand
    dmd
          | AnalEnv -> Bool
    ae_strict_dicts AnalEnv
    env
                 -- We never want to strictify a recursive let. At the moment
                 -- annotateBndr is only call for non-recursive lets; if that
                 -- changes, we need a RecFlag parameter and another guard here.
          , Bool -> Bool
    not Bool
    arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]
          = 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 [Initialising strictness]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    See section 9.2 (Finding fixpoints) of the paper.

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

    Example:

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

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

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

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

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

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

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

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

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

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

    Also see #11731.

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

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

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

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

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

    -}