    {-# LANGUAGE CPP #-}

    -- | Constructed Product Result analysis. Identifies functions that surely
    -- return heap-allocated records on every code path, so that we can eliminate
    -- said heap allocation by performing a worker/wrapper split.
    --
    -- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/.
    -- CPR analysis should happen after strictness analysis.
    -- See Note [Phase ordering].
    module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Driver.Session
    import GHC.Types.Demand
    import GHC.Types.Cpr
    import GHC.Core
    import GHC.Core.Seq
    import GHC.Utils.Outputable
    import GHC.Builtin.Names ( runRWKey )
    import GHC.Types.Var.Env
    import GHC.Types.Basic
    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Core.DataCon
    import GHC.Core.Multiplicity
    import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram )
    import GHC.Core.Type
    import GHC.Core.FamInstEnv
    import GHC.Core.Opt.WorkWrap.Utils
    import GHC.Utils.Misc
    import GHC.Utils.Panic
    import GHC.Utils.Logger  ( Logger, dumpIfSet_dyn, DumpFormat (..) )
    import GHC.Data.Graph.UnVar -- for UnVarSet
    import GHC.Data.Maybe   ( isNothing )

    import Control.Monad ( guard )
    import Data.List ( mapAccumL )

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

    {- Note [Constructed Product Result]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The goal of Constructed Product Result analysis is to identify functions that
    surely return heap-allocated records on every code path, so that we can
    eliminate said heap allocation by performing a worker/wrapper split.

    @swap@ below is such a function:

      swap (a, b) = (b, a)

    A @case@ on an application of @swap@, like
    @case swap (10, 42) of (a, b) -> a + b@ could cancel away
    (by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then
    say that @swap@ has the CPR property.

    We can't inline recursive functions, but similar reasoning applies there:

      f x n = case n of
        0 -> (x, 0)
        _ -> f (x+1) (n-1)

    Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed
    product with the case. So @f@, too, has the CPR property. But we can't really
    "inline" @f@, because it's recursive. Also, non-recursive functions like @swap@
    might be too big to inline (or even marked NOINLINE). We still want to exploit
    the CPR property, and that is exactly what the worker/wrapper transformation
    can do for us:

      $wf x n = case n of
        0 -> case (x, 0) of -> (a, b) -> (# a, b #)
        _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #)
      f x n = case $wf x n of (# a, b #) -> (a, b)

    where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to:

      $wf x n = case n of
        0 -> (# x, 0 #)
        _ -> $wf (x+1) (n-1)

    Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and
    eliminate the heap-allocated pair constructor.

    Note [Phase ordering]
    ~~~~~~~~~~~~~~~~~~~~~
    We need to perform strictness analysis before CPR analysis, because that might
    unbox some arguments, in turn leading to more constructed products.
    Ideally, we would want the following pipeline:

    1. Strictness
    2. worker/wrapper (for strictness)
    3. CPR
    4. worker/wrapper (for CPR)

    Currently, we omit 2. and anticipate the results of worker/wrapper.
    See Note [CPR for binders that will be unboxed]
    and Note [Optimistic field binder CPR].
    An additional w/w pass would simplify things, but probably add slight overhead.
    So currently we have

    1. Strictness
    2. CPR
    3. worker/wrapper (for strictness and CPR)
    -}

    --
    -- * Analysing programs
    --

    cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
    cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
    cprAnalProgram Logger
    logger DynFlags
    dflags FamInstEnvs
    fam_envs CoreProgram
    binds = do
      let env :: AnalEnv
    env            = FamInstEnvs -> AnalEnv
    emptyAnalEnv FamInstEnvs
    fam_envs
      let binds_plus_cpr :: CoreProgram
    binds_plus_cpr = (AnalEnv, CoreProgram) -> CoreProgram
    forall a b. (a, b) -> b
    snd ((AnalEnv, CoreProgram) -> CoreProgram)
    -> (AnalEnv, CoreProgram) -> CoreProgram
    forall a b. (a -> b) -> a -> b
    $ (AnalEnv -> CoreBind -> (AnalEnv, CoreBind))
    -> AnalEnv -> CoreProgram -> (AnalEnv, CoreProgram)
    forall (t :: * -> *) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
    cprAnalTopBind AnalEnv
    env CoreProgram
    binds
      Logger
    -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    dumpIfSet_dyn Logger
    logger DynFlags
    dflags DumpFlag
    Opt_D_dump_cpr_signatures String
    "Cpr signatures" DumpFormat
    FormatText (SDoc -> IO ()) -> SDoc -> IO ()
    forall a b. (a -> b) -> a -> b
    $
        (IdInfo -> SDoc) -> CoreProgram -> SDoc
    dumpIdInfoOfProgram (CprSig -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CprSig -> SDoc) -> (IdInfo -> CprSig) -> IdInfo -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IdInfo -> CprSig
    cprInfo) CoreProgram
    binds_plus_cpr
      -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
      CoreProgram -> ()
    seqBinds CoreProgram
    binds_plus_cpr () -> IO CoreProgram -> IO CoreProgram
    `seq` CoreProgram -> IO CoreProgram
    forall (m :: * -> *) a. Monad m => a -> m a
    return CoreProgram
    binds_plus_cpr

    -- Analyse a (group of) top-level binding(s)
    cprAnalTopBind :: AnalEnv
                   -> CoreBind
                   -> (AnalEnv, CoreBind)
    cprAnalTopBind :: AnalEnv -> CoreBind -> (AnalEnv, CoreBind)
    cprAnalTopBind AnalEnv
    env (NonRec CoreBndr
    id Expr CoreBndr
    rhs)
      = (AnalEnv
    env', CoreBndr -> Expr CoreBndr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec CoreBndr
    id' Expr CoreBndr
    rhs')
      where
        (CoreBndr
    id', Expr CoreBndr
    rhs', AnalEnv
    env') = TopLevelFlag
    -> AnalEnv
    -> CoreBndr
    -> Expr CoreBndr
    -> (CoreBndr, Expr CoreBndr, AnalEnv)
    cprAnalBind TopLevelFlag
    TopLevel AnalEnv
    env CoreBndr
    id Expr CoreBndr
    rhs

    cprAnalTopBind AnalEnv
    env (Rec [(CoreBndr, Expr CoreBndr)]
    pairs)
      = (AnalEnv
    env', [(CoreBndr, Expr CoreBndr)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec [(CoreBndr, Expr CoreBndr)]
    pairs')
      where
        (AnalEnv
    env', [(CoreBndr, Expr CoreBndr)]
    pairs') = TopLevelFlag
    -> AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    cprFix TopLevelFlag
    TopLevel AnalEnv
    env [(CoreBndr, Expr CoreBndr)]
    pairs

    --
    -- * Analysing expressions
    --

    -- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from
    -- "Constructed Product Result Analysis for Haskell"
    cprAnal, cprAnal'
      :: AnalEnv
      -> CoreExpr            -- ^ expression to be denoted by a 'CprType'
      -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'

    cprAnal :: AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $
                      AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal' AnalEnv
    env Expr CoreBndr
    e

    cprAnal' :: AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal' AnalEnv
    _ (Lit Literal
    lit)     = (CprType
    topCprType, Literal -> Expr CoreBndr
    forall b. Literal -> Expr b
    Lit Literal
    lit)
    cprAnal' AnalEnv
    _ (Type Type
    ty)     = (CprType
    topCprType, Type -> Expr CoreBndr
    forall b. Type -> Expr b
    Type Type
    ty)      -- Doesn't happen, in fact
    cprAnal' AnalEnv
    _ (Coercion Coercion
    co) = (CprType
    topCprType, Coercion -> Expr CoreBndr
    forall b. Coercion -> Expr b
    Coercion Coercion
    co)

    cprAnal' AnalEnv
    env (Cast Expr CoreBndr
    e Coercion
    co)
      = (CprType
    cpr_ty, Expr CoreBndr -> Coercion -> Expr CoreBndr
    forall b. Expr b -> Coercion -> Expr b
    Cast Expr CoreBndr
    e' Coercion
    co)
      where
        (CprType
    cpr_ty, Expr CoreBndr
    e') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    e

    cprAnal' AnalEnv
    env (Tick CoreTickish
    t Expr CoreBndr
    e)
      = (CprType
    cpr_ty, CoreTickish -> Expr CoreBndr -> Expr CoreBndr
    forall b. CoreTickish -> Expr b -> Expr b
    Tick CoreTickish
    t Expr CoreBndr
    e')
      where
        (CprType
    cpr_ty, Expr CoreBndr
    e') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    e

    cprAnal' AnalEnv
    env e :: Expr CoreBndr
    e@(Var{})
      = AnalEnv
    -> Expr CoreBndr
    -> [Expr CoreBndr]
    -> [CprType]
    -> (CprType, Expr CoreBndr)
    cprAnalApp AnalEnv
    env Expr CoreBndr
    e [] []
    cprAnal' AnalEnv
    env e :: Expr CoreBndr
    e@(App{})
      = AnalEnv
    -> Expr CoreBndr
    -> [Expr CoreBndr]
    -> [CprType]
    -> (CprType, Expr CoreBndr)
    cprAnalApp AnalEnv
    env Expr CoreBndr
    e [] []

    cprAnal' AnalEnv
    env (Lam CoreBndr
    var Expr CoreBndr
    body)
      | CoreBndr -> Bool
    isTyVar CoreBndr
    var
      , (CprType
    body_ty, Expr CoreBndr
    body') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    body
      = (CprType
    body_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
    forall b. b -> Expr b -> Expr b
    Lam CoreBndr
    var Expr CoreBndr
    body')
      | Bool
    otherwise
      = (CprType
    lam_ty, CoreBndr -> Expr CoreBndr -> Expr CoreBndr
    forall b. b -> Expr b -> Expr b
    Lam CoreBndr
    var Expr CoreBndr
    body')
      where
        -- See Note [CPR for binders that will be unboxed]
        env' :: AnalEnv
    env'             = AnalEnv -> CoreBndr -> AnalEnv
    extendSigEnvForArg AnalEnv
    env CoreBndr
    var
        (CprType
    body_ty, Expr CoreBndr
    body') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env' Expr CoreBndr
    body
        lam_ty :: CprType
    lam_ty           = CprType -> CprType
    abstractCprTy CprType
    body_ty

    cprAnal' AnalEnv
    env (Case Expr CoreBndr
    scrut CoreBndr
    case_bndr Type
    ty [Alt CoreBndr]
    alts)
      = (CprType
    res_ty, Expr CoreBndr
    -> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case Expr CoreBndr
    scrut' CoreBndr
    case_bndr Type
    ty [Alt CoreBndr]
    alts')
      where
        (CprType
    scrut_ty, Expr CoreBndr
    scrut') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    scrut
        env' :: AnalEnv
    env'               = AnalEnv -> CoreBndr -> CprSig -> AnalEnv
    extendSigEnv AnalEnv
    env CoreBndr
    case_bndr (CprType -> CprSig
    CprSig CprType
    scrut_ty)
        ([CprType]
    alt_tys, [Alt CoreBndr]
    alts')   = (Alt CoreBndr -> (CprType, Alt CoreBndr))
    -> [Alt CoreBndr] -> ([CprType], [Alt CoreBndr])
    forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
    mapAndUnzip (AnalEnv -> CprType -> Alt CoreBndr -> (CprType, Alt CoreBndr)
    cprAnalAlt AnalEnv
    env' CprType
    scrut_ty) [Alt CoreBndr]
    alts
        res_ty :: CprType
    res_ty             = (CprType -> CprType -> CprType) -> CprType -> [CprType] -> CprType
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' CprType -> CprType -> CprType
    lubCprType CprType
    botCprType [CprType]
    alt_tys

    cprAnal' AnalEnv
    env (Let (NonRec CoreBndr
    id Expr CoreBndr
    rhs) Expr CoreBndr
    body)
      = (CprType
    body_ty, CoreBind -> Expr CoreBndr -> Expr CoreBndr
    forall b. Bind b -> Expr b -> Expr b
    Let (CoreBndr -> Expr CoreBndr -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec CoreBndr
    id' Expr CoreBndr
    rhs') Expr CoreBndr
    body')
      where
        (CoreBndr
    id', Expr CoreBndr
    rhs', AnalEnv
    env') = TopLevelFlag
    -> AnalEnv
    -> CoreBndr
    -> Expr CoreBndr
    -> (CoreBndr, Expr CoreBndr, AnalEnv)
    cprAnalBind TopLevelFlag
    NotTopLevel AnalEnv
    env CoreBndr
    id Expr CoreBndr
    rhs
        (CprType
    body_ty, Expr CoreBndr
    body')  = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env' Expr CoreBndr
    body

    cprAnal' AnalEnv
    env (Let (Rec [(CoreBndr, Expr CoreBndr)]
    pairs) Expr CoreBndr
    body)
      = CprType
    body_ty CprType -> (CprType, Expr CoreBndr) -> (CprType, Expr CoreBndr)
    `seq` (CprType
    body_ty, CoreBind -> Expr CoreBndr -> Expr CoreBndr
    forall b. Bind b -> Expr b -> Expr b
    Let ([(CoreBndr, Expr CoreBndr)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec [(CoreBndr, Expr CoreBndr)]
    pairs') Expr CoreBndr
    body')
      where
        (AnalEnv
    env', [(CoreBndr, Expr CoreBndr)]
    pairs')   = TopLevelFlag
    -> AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    cprFix TopLevelFlag
    NotTopLevel AnalEnv
    env [(CoreBndr, Expr CoreBndr)]
    pairs
        (CprType
    body_ty, Expr CoreBndr
    body') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env' Expr CoreBndr
    body

    cprAnalAlt
      :: AnalEnv
      -> CprType -- ^ CPR type of the scrutinee
      -> Alt Var -- ^ current alternative
      -> (CprType, Alt Var)
    cprAnalAlt :: AnalEnv -> CprType -> Alt CoreBndr -> (CprType, Alt CoreBndr)
    cprAnalAlt AnalEnv
    env CprType
    scrut_ty (Alt AltCon
    con [CoreBndr]
    bndrs Expr CoreBndr
    rhs)
      = (CprType
    rhs_ty, AltCon -> [CoreBndr] -> Expr CoreBndr -> Alt CoreBndr
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    con [CoreBndr]
    bndrs Expr CoreBndr
    rhs')
      where
        env_alt :: AnalEnv
    env_alt
          | DataAlt DataCon
    dc <- AltCon
    con
          , let ids :: [CoreBndr]
    ids = (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
    forall a. (a -> Bool) -> [a] -> [a]
    filter CoreBndr -> Bool
    isId [CoreBndr]
    bndrs
          , CprType Arity
    arity Cpr
    cpr <- CprType
    scrut_ty
          , ASSERT( arity == 0 ) True
          = case DataCon -> Cpr -> UnpackConFieldsResult
    unpackConFieldsCpr DataCon
    dc Cpr
    cpr of
              AllFieldsSame Cpr
    field_cpr
                | let sig :: CprSig
    sig = Arity -> Cpr -> CprSig
    mkCprSig Arity
    0 Cpr
    field_cpr
                -> AnalEnv -> [CoreBndr] -> CprSig -> AnalEnv
    extendSigEnvAllSame AnalEnv
    env [CoreBndr]
    ids CprSig
    sig
              ForeachField [Cpr]
    field_cprs
                | let sigs :: [CprSig]
    sigs = (CoreBndr -> Cpr -> CprSig) -> [CoreBndr] -> [Cpr] -> [CprSig]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (Arity -> Cpr -> CprSig
    mkCprSig (Arity -> Cpr -> CprSig)
    -> (CoreBndr -> Arity) -> CoreBndr -> Cpr -> CprSig
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CoreBndr -> Arity
    idArity) [CoreBndr]
    ids [Cpr]
    field_cprs
                -> AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
    extendSigEnvList AnalEnv
    env (String -> [CoreBndr] -> [CprSig] -> [(CoreBndr, CprSig)]
    forall a b. String -> [a] -> [b] -> [(a, b)]
    zipEqual String
    "cprAnalAlt" [CoreBndr]
    ids [CprSig]
    sigs)
          | Bool
    otherwise
          = AnalEnv
    env
        (CprType
    rhs_ty, Expr CoreBndr
    rhs') = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env_alt Expr CoreBndr
    rhs

    --
    -- * CPR transformer
    --

    cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr)
    cprAnalApp :: AnalEnv
    -> Expr CoreBndr
    -> [Expr CoreBndr]
    -> [CprType]
    -> (CprType, Expr CoreBndr)
    cprAnalApp AnalEnv
    env Expr CoreBndr
    e [Expr CoreBndr]
    args' [CprType]
    arg_tys
      -- Collect CprTypes for (value) args (inlined collectArgs):
      | App Expr CoreBndr
    fn Expr CoreBndr
    arg <- Expr CoreBndr
    e, Expr CoreBndr -> Bool
    forall b. Expr b -> Bool
    isTypeArg Expr CoreBndr
    arg -- Don't analyse Type args
      = AnalEnv
    -> Expr CoreBndr
    -> [Expr CoreBndr]
    -> [CprType]
    -> (CprType, Expr CoreBndr)
    cprAnalApp AnalEnv
    env Expr CoreBndr
    fn (Expr CoreBndr
    argExpr CoreBndr -> [Expr CoreBndr] -> [Expr CoreBndr]
    forall a. a -> [a] -> [a]
    :[Expr CoreBndr]
    args') [CprType]
    arg_tys
      | App Expr CoreBndr
    fn Expr CoreBndr
    arg <- Expr CoreBndr
    e
      , (CprType
    arg_ty, Expr CoreBndr
    arg') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    arg
      = AnalEnv
    -> Expr CoreBndr
    -> [Expr CoreBndr]
    -> [CprType]
    -> (CprType, Expr CoreBndr)
    cprAnalApp AnalEnv
    env Expr CoreBndr
    fn (Expr CoreBndr
    arg'Expr CoreBndr -> [Expr CoreBndr] -> [Expr CoreBndr]
    forall a. a -> [a] -> [a]
    :[Expr CoreBndr]
    args') (CprType
    arg_tyCprType -> [CprType] -> [CprType]
    forall a. a -> [a] -> [a]
    :[CprType]
    arg_tys)

      | Var CoreBndr
    fn <- Expr CoreBndr
    e
      = (AnalEnv -> CoreBndr -> [CprType] -> CprType
    cprTransform AnalEnv
    env CoreBndr
    fn [CprType]
    arg_tys, Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps Expr CoreBndr
    e [Expr CoreBndr]
    args')

      | Bool
    otherwise -- e is not an App and not a Var
      , (CprType
    e_ty, Expr CoreBndr
    e') <- AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    e
      = (CprType -> Arity -> CprType
    applyCprTy CprType
    e_ty ([CprType] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [CprType]
    arg_tys), Expr CoreBndr -> [Expr CoreBndr] -> Expr CoreBndr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps Expr CoreBndr
    e' [Expr CoreBndr]
    args')

    cprTransform :: AnalEnv   -- ^ The analysis environment
                 -> Id        -- ^ The function
                 -> [CprType] -- ^ info about incoming /value/ arguments
                 -> CprType   -- ^ The demand type of the application
    cprTransform :: AnalEnv -> CoreBndr -> [CprType] -> CprType
    cprTransform AnalEnv
    env CoreBndr
    id [CprType]
    args
      = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig])
        CprType
    sig
      where
        sig :: CprType
    sig
          -- Top-level binding, local let-binding, lambda arg or case binder
          | Just CprSig
    sig <- AnalEnv -> CoreBndr -> Maybe CprSig
    lookupSigEnv AnalEnv
    env CoreBndr
    id
          = CprType -> Arity -> CprType
    applyCprTy (CprSig -> CprType
    getCprSig CprSig
    sig) ([CprType] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [CprType]
    args)
          -- CPR transformers for special Ids
          | Just CprType
    cpr_ty <- CoreBndr -> [CprType] -> Maybe CprType
    cprTransformSpecial CoreBndr
    id [CprType]
    args
          = CprType
    cpr_ty
          -- See Note [CPR for data structures]
          | Just Expr CoreBndr
    rhs <- CoreBndr -> Maybe (Expr CoreBndr)
    cprDataStructureUnfolding_maybe CoreBndr
    id
          = (CprType, Expr CoreBndr) -> CprType
    forall a b. (a, b) -> a
    fst ((CprType, Expr CoreBndr) -> CprType)
    -> (CprType, Expr CoreBndr) -> CprType
    forall a b. (a -> b) -> a -> b
    $ AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    rhs
          -- Imported function or data con worker
          | CoreBndr -> Bool
    isGlobalId CoreBndr
    id
          = CprType -> Arity -> CprType
    applyCprTy (CprSig -> CprType
    getCprSig (CoreBndr -> CprSig
    idCprInfo CoreBndr
    id)) ([CprType] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [CprType]
    args)
          | Bool
    otherwise
          = CprType
    topCprType

    -- | CPR transformers for special Ids
    cprTransformSpecial :: Id -> [CprType] -> Maybe CprType
    cprTransformSpecial :: CoreBndr -> [CprType] -> Maybe CprType
    cprTransformSpecial CoreBndr
    id [CprType]
    args
      -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep
      | CoreBndr -> Unique
    idUnique CoreBndr
    id Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    runRWKey -- `runRW (\s -> e)`
      , [CprType
    arg] <- [CprType]
    args           -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)
      = CprType -> Maybe CprType
    forall a. a -> Maybe a
    Just (CprType -> Maybe CprType) -> CprType -> Maybe CprType
    forall a b. (a -> b) -> a -> b
    $ CprType -> Arity -> CprType
    applyCprTy CprType
    arg Arity
    1 -- `e` has CPR type `2`
      | Bool
    otherwise
      = Maybe CprType
    forall a. Maybe a
    Nothing

    --
    -- * Bindings
    --

    -- Recursive bindings
    cprFix :: TopLevelFlag
           -> AnalEnv                    -- Does not include bindings for this binding
           -> [(Id,CoreExpr)]
           -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info
    cprFix :: TopLevelFlag
    -> AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    cprFix TopLevelFlag
    top_lvl AnalEnv
    orig_env [(CoreBndr, Expr CoreBndr)]
    orig_pairs
      = Arity
    -> AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    loop Arity
    1 AnalEnv
    init_env [(CoreBndr, Expr CoreBndr)]
    init_pairs
      where
        init_sig :: CoreBndr -> Expr CoreBndr -> CprSig
    init_sig CoreBndr
    id Expr CoreBndr
    rhs
          -- See Note [CPR for data structures]
          | CoreBndr -> Expr CoreBndr -> Bool
    isDataStructure CoreBndr
    id Expr CoreBndr
    rhs = CprSig
    topCprSig
          | Bool
    otherwise              = Arity -> Cpr -> CprSig
    mkCprSig Arity
    0 Cpr
    botCpr
        -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
        orig_virgin :: Bool
    orig_virgin = AnalEnv -> Bool
    ae_virgin AnalEnv
    orig_env
        init_pairs :: [(CoreBndr, Expr CoreBndr)]
    init_pairs | Bool
    orig_virgin  = [(CoreBndr -> CprSig -> CoreBndr
    setIdCprInfo CoreBndr
    id (CoreBndr -> Expr CoreBndr -> CprSig
    init_sig CoreBndr
    id Expr CoreBndr
    rhs), Expr CoreBndr
    rhs) | (CoreBndr
    id, Expr CoreBndr
    rhs) <- [(CoreBndr, Expr CoreBndr)]
    orig_pairs ]
                   | Bool
    otherwise    = [(CoreBndr, Expr CoreBndr)]
    orig_pairs
        init_env :: AnalEnv
    init_env = AnalEnv -> [CoreBndr] -> AnalEnv
    extendSigEnvFromIds AnalEnv
    orig_env (((CoreBndr, Expr CoreBndr) -> CoreBndr)
    -> [(CoreBndr, Expr CoreBndr)] -> [CoreBndr]
    forall a b. (a -> b) -> [a] -> [b]
    map (CoreBndr, Expr CoreBndr) -> CoreBndr
    forall a b. (a, b) -> a
    fst [(CoreBndr, Expr CoreBndr)]
    init_pairs)

        -- The fixed-point varies the idCprInfo field of the binders and and their
        -- entries in the AnalEnv, and terminates if that annotation does not change
        -- any more.
        loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
        loop :: Arity
    -> AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    loop Arity
    n AnalEnv
    env [(CoreBndr, Expr CoreBndr)]
    pairs
          | Bool
    found_fixpoint = (AnalEnv
    reset_env', [(CoreBndr, Expr CoreBndr)]
    pairs')
          | Bool
    otherwise      = Arity
    -> AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    loop (Arity
    nArity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    +Arity
    1) AnalEnv
    env' [(CoreBndr, Expr CoreBndr)]
    pairs'
          where
            -- In all but the first iteration, delete the virgin flag
            -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
            (AnalEnv
    env', [(CoreBndr, Expr CoreBndr)]
    pairs') = AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    step (Bool -> (AnalEnv -> AnalEnv) -> AnalEnv -> AnalEnv
    forall a. Bool -> (a -> a) -> a -> a
    applyWhen (Arity
    nArity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    /=Arity
    1) AnalEnv -> AnalEnv
    nonVirgin AnalEnv
    env) [(CoreBndr, Expr CoreBndr)]
    pairs
            -- Make sure we reset the virgin flag to what it was when we are stable
            reset_env' :: AnalEnv
    reset_env'     = AnalEnv
    env'{ ae_virgin :: Bool
    ae_virgin = Bool
    orig_virgin }
            found_fixpoint :: Bool
    found_fixpoint = ((CoreBndr, Expr CoreBndr) -> CprSig)
    -> [(CoreBndr, Expr CoreBndr)] -> [CprSig]
    forall a b. (a -> b) -> [a] -> [b]
    map (CoreBndr -> CprSig
    idCprInfo (CoreBndr -> CprSig)
    -> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
    -> (CoreBndr, Expr CoreBndr)
    -> CprSig
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (CoreBndr, Expr CoreBndr) -> CoreBndr
    forall a b. (a, b) -> a
    fst) [(CoreBndr, Expr CoreBndr)]
    pairs' [CprSig] -> [CprSig] -> Bool
    forall a. Eq a => a -> a -> Bool
    == ((CoreBndr, Expr CoreBndr) -> CprSig)
    -> [(CoreBndr, Expr CoreBndr)] -> [CprSig]
    forall a b. (a -> b) -> [a] -> [b]
    map (CoreBndr -> CprSig
    idCprInfo (CoreBndr -> CprSig)
    -> ((CoreBndr, Expr CoreBndr) -> CoreBndr)
    -> (CoreBndr, Expr CoreBndr)
    -> CprSig
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (CoreBndr, Expr CoreBndr) -> CoreBndr
    forall a b. (a, b) -> a
    fst) [(CoreBndr, Expr CoreBndr)]
    pairs

        step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)])
        step :: AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    step AnalEnv
    env [(CoreBndr, Expr CoreBndr)]
    pairs = (AnalEnv
     -> (CoreBndr, Expr CoreBndr)
     -> (AnalEnv, (CoreBndr, Expr CoreBndr)))
    -> AnalEnv
    -> [(CoreBndr, Expr CoreBndr)]
    -> (AnalEnv, [(CoreBndr, Expr CoreBndr)])
    forall (t :: * -> *) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL AnalEnv
    -> (CoreBndr, Expr CoreBndr)
    -> (AnalEnv, (CoreBndr, Expr CoreBndr))
    go AnalEnv
    env [(CoreBndr, Expr CoreBndr)]
    pairs
          where
            go :: AnalEnv
    -> (CoreBndr, Expr CoreBndr)
    -> (AnalEnv, (CoreBndr, Expr CoreBndr))
    go AnalEnv
    env (CoreBndr
    id, Expr CoreBndr
    rhs) = (AnalEnv
    env', (CoreBndr
    id', Expr CoreBndr
    rhs'))
              where
                (CoreBndr
    id', Expr CoreBndr
    rhs', AnalEnv
    env') = TopLevelFlag
    -> AnalEnv
    -> CoreBndr
    -> Expr CoreBndr
    -> (CoreBndr, Expr CoreBndr, AnalEnv)
    cprAnalBind TopLevelFlag
    top_lvl AnalEnv
    env CoreBndr
    id Expr CoreBndr
    rhs

    -- | Process the RHS of the binding for a sensible arity, add the CPR signature
    -- to the Id, and augment the environment with the signature as well.
    cprAnalBind
      :: TopLevelFlag
      -> AnalEnv
      -> Id
      -> CoreExpr
      -> (Id, CoreExpr, AnalEnv)
    cprAnalBind :: TopLevelFlag
    -> AnalEnv
    -> CoreBndr
    -> Expr CoreBndr
    -> (CoreBndr, Expr CoreBndr, AnalEnv)
    cprAnalBind TopLevelFlag
    top_lvl AnalEnv
    env CoreBndr
    id Expr CoreBndr
    rhs
      -- See Note [CPR for data structures]
      | CoreBndr -> Expr CoreBndr -> Bool
    isDataStructure CoreBndr
    id Expr CoreBndr
    rhs
      = (CoreBndr
    id,  Expr CoreBndr
    rhs,  AnalEnv
    env) -- Data structure => no code => need to analyse rhs
      | Bool
    otherwise
      = (CoreBndr
    id', Expr CoreBndr
    rhs', AnalEnv
    env')
      where
        (CprType
    rhs_ty, Expr CoreBndr
    rhs')  = AnalEnv -> Expr CoreBndr -> (CprType, Expr CoreBndr)
    cprAnal AnalEnv
    env Expr CoreBndr
    rhs
        -- possibly trim thunk CPR info
        rhs_ty' :: CprType
    rhs_ty'
          -- See Note [CPR for thunks]
          | Bool
    stays_thunk = CprType -> CprType
    trimCprTy CprType
    rhs_ty
          -- See Note [CPR for sum types]
          | Bool
    returns_sum = CprType -> CprType
    trimCprTy CprType
    rhs_ty
          | Bool
    otherwise   = CprType
    rhs_ty
        -- See Note [Arity trimming for CPR signatures]
        sig :: CprSig
    sig  = Arity -> CprType -> CprSig
    mkCprSigForArity (CoreBndr -> Arity
    idArity CoreBndr
    id) CprType
    rhs_ty'
        id' :: CoreBndr
    id'  = CoreBndr -> CprSig -> CoreBndr
    setIdCprInfo CoreBndr
    id CprSig
    sig
        env' :: AnalEnv
    env' = AnalEnv -> CoreBndr -> CprSig -> AnalEnv
    extendSigEnv AnalEnv
    env CoreBndr
    id CprSig
    sig

        -- See Note [CPR for thunks]
        stays_thunk :: Bool
    stays_thunk = Bool
    is_thunk Bool -> Bool -> Bool
    && Bool
    not_strict
        is_thunk :: Bool
    is_thunk    = Bool -> Bool
    not (Expr CoreBndr -> Bool
    exprIsHNF Expr CoreBndr
    rhs) Bool -> Bool -> Bool
    && Bool -> Bool
    not (CoreBndr -> Bool
    isJoinId CoreBndr
    id)
        not_strict :: Bool
    not_strict  = Bool -> Bool
    not (Demand -> Bool
    isStrUsedDmd (CoreBndr -> Demand
    idDemandInfo CoreBndr
    id))
        -- See Note [CPR for sum types]
        ([TyCoBinder]
    _, Type
    ret_ty) = Type -> ([TyCoBinder], Type)
    splitPiTys (CoreBndr -> Type
    idType CoreBndr
    id)
        not_a_prod :: Bool
    not_a_prod  = Maybe DataConPatContext -> Bool
    forall a. Maybe a -> Bool
    isNothing (FamInstEnvs -> Type -> Maybe DataConPatContext
    splitArgType_maybe (AnalEnv -> FamInstEnvs
    ae_fam_envs AnalEnv
    env) Type
    ret_ty)
        returns_sum :: Bool
    returns_sum = Bool -> Bool
    not (TopLevelFlag -> Bool
    isTopLevel TopLevelFlag
    top_lvl) Bool -> Bool -> Bool
    && Bool
    not_a_prod

    isDataStructure :: Id -> CoreExpr -> Bool
    -- See Note [CPR for data structures]
    isDataStructure :: CoreBndr -> Expr CoreBndr -> Bool
    isDataStructure CoreBndr
    id Expr CoreBndr
    rhs =
      CoreBndr -> Arity
    idArity CoreBndr
    id Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    0 Bool -> Bool -> Bool
    && Expr CoreBndr -> Bool
    exprIsHNF Expr CoreBndr
    rhs

    -- | Returns an expandable unfolding
    -- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has
    -- So effectively is a constructor application.
    cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr
    cprDataStructureUnfolding_maybe :: CoreBndr -> Maybe (Expr CoreBndr)
    cprDataStructureUnfolding_maybe CoreBndr
    id = do
      -- There are only FinalPhase Simplifier runs after CPR analysis
      Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (Activation -> Bool
    activeInFinalPhase (CoreBndr -> Activation
    idInlineActivation CoreBndr
    id))
      Expr CoreBndr
    unf <- Unfolding -> Maybe (Expr CoreBndr)
    expandUnfolding_maybe (CoreBndr -> Unfolding
    idUnfolding CoreBndr
    id)
      Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (CoreBndr -> Expr CoreBndr -> Bool
    isDataStructure CoreBndr
    id Expr CoreBndr
    unf)
      Expr CoreBndr -> Maybe (Expr CoreBndr)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Expr CoreBndr
    unf

    {- Note [Arity trimming for CPR signatures]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Although it doesn't affect correctness of the analysis per se, we have to trim
    CPR signatures to idArity. Here's what might happen if we don't:

      f x = if expensive
              then \y. Box y
              else \z. Box z
      g a b = f a b

    The two lambdas will have a CPR type of @1m@ (so construct a product after
    applied to one argument). Thus, @f@ will have a CPR signature of @2m@
    (constructs a product after applied to two arguments).
    But WW will never eta-expand @f@! In this case that would amount to possibly
    duplicating @expensive@ work.

    (Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see
    Note [Don't eta expand in w/w].)

    So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature
    from @f@'s, so it *will* be WW'd:

      f x = if expensive
              then \y. Box y
              else \z. Box z
      $wg a b = case f a b of Box x -> x
      g a b = Box ($wg a b)

    And the case in @g@ can never cancel away, thus we introduced extra reboxing.
    Hence we always trim the CPR signature of a binding to idArity.
    -}

    data AnalEnv
      = AE
      { AnalEnv -> SigEnv
    ae_sigs   :: SigEnv
      -- ^ Current approximation of signatures for local ids
      , AnalEnv -> Bool
    ae_virgin :: Bool
      -- ^ True only on every first iteration in a fixed-point
      -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal"
      , AnalEnv -> FamInstEnvs
    ae_fam_envs :: FamInstEnvs
      -- ^ Needed when expanding type families and synonyms of product types.
      }

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

    -- | An environment storing 'CprSig's for local Ids.
    -- Puts binders with 'topCprSig' in a space-saving 'IntSet'.
    -- See Note [Efficient Top sigs in SigEnv].
    data SigEnv
      = SE
      { SigEnv -> UnVarSet
    se_tops :: !UnVarSet
      -- ^ All these Ids have 'topCprSig'. Like a 'VarSet', but more efficient.
      , SigEnv -> VarEnv CprSig
    se_sigs :: !(VarEnv CprSig)
      -- ^ Ids that have something other than 'topCprSig'.
      }

    instance Outputable SigEnv where
      ppr :: SigEnv -> SDoc
    ppr (SE { se_tops :: SigEnv -> UnVarSet
    se_tops = UnVarSet
    tops, se_sigs :: SigEnv -> VarEnv CprSig
    se_sigs = VarEnv CprSig
    sigs })
        = String -> SDoc
    text String
    "SE" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    braces ([SDoc] -> SDoc
    vcat
             [ String -> SDoc
    text String
    "se_tops =" SDoc -> SDoc -> SDoc
    <+> UnVarSet -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr UnVarSet
    tops
             , String -> SDoc
    text String
    "se_sigs =" SDoc -> SDoc -> SDoc
    <+> VarEnv CprSig -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr VarEnv CprSig
    sigs ])

    emptyAnalEnv :: FamInstEnvs -> AnalEnv
    emptyAnalEnv :: FamInstEnvs -> AnalEnv
    emptyAnalEnv FamInstEnvs
    fam_envs
      = AE
      { ae_sigs :: SigEnv
    ae_sigs = UnVarSet -> VarEnv CprSig -> SigEnv
    SE UnVarSet
    emptyUnVarSet VarEnv CprSig
    forall a. VarEnv a
    emptyVarEnv
      , ae_virgin :: Bool
    ae_virgin = Bool
    True
      , ae_fam_envs :: FamInstEnvs
    ae_fam_envs = FamInstEnvs
    fam_envs
      }

    modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
    modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
    modifySigEnv SigEnv -> SigEnv
    f AnalEnv
    env = AnalEnv
    env { ae_sigs :: SigEnv
    ae_sigs = SigEnv -> SigEnv
    f (AnalEnv -> SigEnv
    ae_sigs AnalEnv
    env) }

    lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig
    -- See Note [Efficient Top sigs in SigEnv]
    lookupSigEnv :: AnalEnv -> CoreBndr -> Maybe CprSig
    lookupSigEnv AE{ae_sigs :: AnalEnv -> SigEnv
    ae_sigs = SE UnVarSet
    tops VarEnv CprSig
    sigs} CoreBndr
    id
      | CoreBndr
    id CoreBndr -> UnVarSet -> Bool
    `elemUnVarSet` UnVarSet
    tops = CprSig -> Maybe CprSig
    forall a. a -> Maybe a
    Just CprSig
    topCprSig
      | Bool
    otherwise              = VarEnv CprSig -> CoreBndr -> Maybe CprSig
    forall a. VarEnv a -> CoreBndr -> Maybe a
    lookupVarEnv VarEnv CprSig
    sigs CoreBndr
    id

    extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv
    -- See Note [Efficient Top sigs in SigEnv]
    extendSigEnv :: AnalEnv -> CoreBndr -> CprSig -> AnalEnv
    extendSigEnv AnalEnv
    env CoreBndr
    id CprSig
    sig
      | CprSig -> Bool
    isTopCprSig CprSig
    sig
      = (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
    modifySigEnv (\SigEnv
    se -> SigEnv
    se{se_tops :: UnVarSet
    se_tops = CoreBndr -> UnVarSet -> UnVarSet
    extendUnVarSet CoreBndr
    id (SigEnv -> UnVarSet
    se_tops SigEnv
    se)}) AnalEnv
    env
      | Bool
    otherwise
      = (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
    modifySigEnv (\SigEnv
    se -> SigEnv
    se{se_sigs :: VarEnv CprSig
    se_sigs = VarEnv CprSig -> CoreBndr -> CprSig -> VarEnv CprSig
    forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
    extendVarEnv (SigEnv -> VarEnv CprSig
    se_sigs SigEnv
    se) CoreBndr
    id CprSig
    sig}) AnalEnv
    env

    -- | Extend an environment with the (Id, CPR sig) pairs
    extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv
    extendSigEnvList :: AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
    extendSigEnvList AnalEnv
    env [(CoreBndr, CprSig)]
    ids_cprs
      = (AnalEnv -> (CoreBndr, CprSig) -> AnalEnv)
    -> AnalEnv -> [(CoreBndr, CprSig)] -> AnalEnv
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\AnalEnv
    env (CoreBndr
    id, CprSig
    sig) -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
    extendSigEnv AnalEnv
    env CoreBndr
    id CprSig
    sig) AnalEnv
    env [(CoreBndr, CprSig)]
    ids_cprs

    -- | Extend an environment with the CPR sigs attached to the ids
    extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv
    extendSigEnvFromIds :: AnalEnv -> [CoreBndr] -> AnalEnv
    extendSigEnvFromIds AnalEnv
    env [CoreBndr]
    ids
      = (AnalEnv -> CoreBndr -> AnalEnv)
    -> AnalEnv -> [CoreBndr] -> AnalEnv
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\AnalEnv
    env CoreBndr
    id -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
    extendSigEnv AnalEnv
    env CoreBndr
    id (CoreBndr -> CprSig
    idCprInfo CoreBndr
    id)) AnalEnv
    env [CoreBndr]
    ids

    -- | Extend an environment with the same CPR sig for all ids
    extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv
    extendSigEnvAllSame :: AnalEnv -> [CoreBndr] -> CprSig -> AnalEnv
    extendSigEnvAllSame AnalEnv
    env [CoreBndr]
    ids CprSig
    sig
      = (AnalEnv -> CoreBndr -> AnalEnv)
    -> AnalEnv -> [CoreBndr] -> AnalEnv
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\AnalEnv
    env CoreBndr
    id -> AnalEnv -> CoreBndr -> CprSig -> AnalEnv
    extendSigEnv AnalEnv
    env CoreBndr
    id CprSig
    sig) AnalEnv
    env [CoreBndr]
    ids

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

    -- | A version of 'extendSigEnv' for a binder of which we don't see the RHS
    -- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders).
    -- In this case, we can still look at their demand to attach CPR signatures
    -- anticipating the unboxing done by worker/wrapper.
    -- See Note [CPR for binders that will be unboxed].
    extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv
    extendSigEnvForArg :: AnalEnv -> CoreBndr -> AnalEnv
    extendSigEnvForArg AnalEnv
    env CoreBndr
    id
      = AnalEnv -> CoreBndr -> CprSig -> AnalEnv
    extendSigEnv AnalEnv
    env CoreBndr
    id (CprType -> CprSig
    CprSig (AnalEnv -> Type -> Demand -> CprType
    argCprType AnalEnv
    env (CoreBndr -> Type
    idType CoreBndr
    id) (CoreBndr -> Demand
    idDemandInfo CoreBndr
    id)))

    -- | Produces a 'CprType' according to how a strict argument will be unboxed.
    -- Examples:
    --
    --   * A head-strict demand @1L@ on @Int@ would translate to @1@
    --   * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@
    --   * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@,
    --     because the unboxing strategy would not unbox the @a@.
    argCprType :: AnalEnv -> Type -> Demand -> CprType
    argCprType :: AnalEnv -> Type -> Demand -> CprType
    argCprType AnalEnv
    env Type
    arg_ty Demand
    dmd = Arity -> Cpr -> CprType
    CprType Arity
    0 (Type -> Demand -> Cpr
    go Type
    arg_ty Demand
    dmd)
      where
        go :: Type -> Demand -> Cpr
    go Type
    ty Demand
    dmd
          | Unbox (DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon
    dcpc_dc = DataCon
    dc, dcpc_tc_args :: DataConPatContext -> [Type]
    dcpc_tc_args = [Type]
    tc_args }) [Demand]
    ds
              <- FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand
    wantToUnbox (AnalEnv -> FamInstEnvs
    ae_fam_envs AnalEnv
    env) Bool
    no_inlineable_prag Type
    ty Demand
    dmd
          -- No existentials; see Note [Which types are unboxed?])
          -- Otherwise we'd need to call dataConRepInstPat here and thread a
          -- UniqSupply. So argCprType is a bit less aggressive than it could
          -- be, for the sake of coding convenience.
          , [CoreBndr] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (DataCon -> [CoreBndr]
    dataConExTyCoVars DataCon
    dc)
          , let arg_tys :: [Type]
    arg_tys = (Scaled Type -> Type) -> [Scaled Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing (DataCon -> [Type] -> [Scaled Type]
    dataConInstArgTys DataCon
    dc [Type]
    tc_args)
          = Arity -> [Cpr] -> Cpr
    ConCpr (DataCon -> Arity
    dataConTag DataCon
    dc) ((Type -> Demand -> Cpr) -> [Type] -> [Demand] -> [Cpr]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Type -> Demand -> Cpr
    go [Type]
    arg_tys [Demand]
    ds)
          | Bool
    otherwise
          = Cpr
    topCpr
        -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE
        -- function, we just assume that we aren't. That flag is only relevant
        -- to Note [Do not unpack class dictionaries], the few unboxing
        -- opportunities on dicts it prohibits are probably irrelevant to CPR.
        no_inlineable_prag :: Bool
    no_inlineable_prag = Bool
    False

    {- 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, to ensure that all expressions have been traversed at least once, and any
    unsound CPR annotations have been updated.

    Note [Efficient Top sigs in SigEnv]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    It's pretty common for binders in the SigEnv to have a 'topCprSig'.
    Wide records with 100 fields like in T9675 even will generate code where the
    majority of binders has Top signature. To save some allocations, we store
    those binders with a Top signature in a separate UnVarSet (which is an IntSet
    with a convenient Var-tailored API).

    Why store top signatures at all in the SigEnv? After all, when 'cprTransform'
    encounters a locally-bound Id without an entry in the SigEnv, it should behave
    as if that binder has a Top signature!
    Well, the problem is when case binders should have a Top signatures. They always
    have an unfolding and thus look to 'cprTransform' as if they bind a data
    structure, Note [CPR for data structures], and thus would always have the CPR
    property. So we need some mechanism to separate data structures from case
    binders with a Top signature, and the UnVarSet provides that in the least
    convoluted way I can think of.

    Note [CPR for binders that will be unboxed]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    If a lambda-bound variable will be unboxed by worker/wrapper (so it must be
    demanded strictly), then give it a CPR signature. Here's a concrete example
    ('f1' in test T10482a), assuming h is strict:

      f1 :: Int -> Int
      f1 x = case h x of
              A -> x
              B -> f1 (x-1)
              C -> x+1

    If we notice that 'x' is used strictly, we can give it the CPR
    property; and hence f1 gets the CPR property too.  It's sound (doesn't
    change strictness) to give it the CPR property because by the time 'x'
    is returned (case A above), it'll have been evaluated (by the wrapper
    of 'h' in the example).

    Moreover, if f itself is strict in x, then we'll pass x unboxed to
    f1, and so the boxed version *won't* be available; in that case it's
    very helpful to give 'x' the CPR property.

    This is all done in 'extendSigEnvForArg'.

    Note that

      * Whether or not something unboxes is decided by 'wantToUnbox', else we may
        get over-optimistic CPR results (e.g., from \(x :: a) -> x!).

      * If the demand unboxes deeply, we can give the binder a /nested/ CPR
        property, e.g.

          g :: (Int, Int) -> Int
          g p = case p of
            (x, y) | x < 0     -> 0
                   | otherwise -> x

        `x` should have the CPR property because it will be unboxed. We do so
        by giving `p` the Nested CPR property `1(1,)`, indicating that we not only
        have `p` available unboxed, but also its field `x`. Analysis of the Case
        will then transfer the CPR property to `x`.

        Before we were able to express Nested CPR, we used to guess which field
        binders should get the CPR property.
        See Historic Note [Optimistic field binder CPR].

      * See Note [CPR examples]

    Historic Note [Optimistic field binder CPR]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    This Note describes how we used to guess whether fields have the CPR property
    before we were able to express Nested CPR for arguments.

    Consider

      data T a = MkT a
      f :: T Int -> Int
      f x = ... (case x of
        MkT y -> y) ...

    And assume we know from strictness analysis that `f` is strict in `x` and its
    field `y` and we unbox both. Then we give `x` the CPR property according
    to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y`
    likewise will be unboxed and it should also get the CPR property. We'd
    need a *nested* CPR property here for `x` to express that and unwrap one level
    when we analyse the Case to give the CPR property to `y`.

    Lacking Nested CPR, we have to guess a bit, by looking for

      (A) Flat CPR on the scrutinee
      (B) A variable scrutinee. Otherwise surely it can't be a parameter.
      (C) Strict demand on the field binder `y` (or it binds a strict field)

    While (A) is a necessary condition to give a field the CPR property, there are
    ways in which (B) and (C) are too lax, leading to unsound analysis results and
    thus reboxing in the wrapper:

      (b) We could scrutinise some other variable than a parameter, like in

            g :: T Int -> Int
            g x = let z = foo x in -- assume `z` has CPR property
                  case z of MkT y -> y

          Lacking Nested CPR and multiple levels of unboxing, only the outer box
          of `z` will be available and a case on `y` won't actually cancel away.
          But it's simple, and nothing terrible happens if we get it wrong. e.g.
          #10694.

      (c) A strictly used field binder doesn't mean the function is strict in it.

            h :: T Int -> Int -> Int
            h !x 0 = 0
            h  x 0 = case x of MkT y -> y

          Here, `y` is used strictly, but the field of `x` certainly is not and
          consequently will not be available unboxed.
          Why not look at the demand of `x` instead to determine whether `y` is
          unboxed? Because the 'idDemandInfo' on `x` will not have been propagated
          to its occurrence in the scrutinee when CprAnal runs directly after
          DmdAnal.

    We used to give the case binder the CPR property unconditionally instead of
    deriving it from the case scrutinee.
    See Historical Note [Optimistic case binder CPR].

    Historical Note [Optimistic case binder CPR]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We used to give the case binder the CPR property unconditionally, which is too
    optimistic (#19232). Here are the details:

    Inside the alternative, the case binder always has the CPR property, meaning
    that a case on it will successfully cancel.
    Example:
      f True  x = case x of y { I# x' -> if x' ==# 3
                                         then y
                                         else I# 8 }
      f False x = I# 3
    By giving 'y' the CPR property, we ensure that 'f' does too, so we get
      f b x = case fw b x of { r -> I# r }
      fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
      fw False x = 3
    Of course there is the usual risk of re-boxing: we have 'x' available boxed
    and unboxed, but we return the unboxed version for the wrapper to box. If the
    wrapper doesn't cancel with its caller, we'll end up re-boxing something that
    we did have available in boxed form.

    Note [CPR for sum types]
    ~~~~~~~~~~~~~~~~~~~~~~~~
    At the moment we do not do CPR for let-bindings that
       * non-top level
       * bind a sum type
    Reason: I found that in some benchmarks we were losing let-no-escapes,
    which messed it all up.  Example
       let j = \x. ....
       in case y of
            True  -> j False
            False -> j True
    If we w/w this we get
       let j' = \x. ....
       in case y of
            True  -> case j' False of { (# a #) -> Just a }
            False -> case j' True of { (# a #) -> Just a }
    Notice that j' is not a let-no-escape any more.

    However this means in turn that the *enclosing* function
    may be CPR'd (via the returned Justs).  But in the case of
    sums, there may be Nothing alternatives; and that messes
    up the sum-type CPR.

    Conclusion: only do this for products.  It's still not
    guaranteed OK for products, but sums definitely lose sometimes.

    Note [CPR for thunks]
    ~~~~~~~~~~~~~~~~~~~~~
    If the rhs is a thunk, we usually forget the CPR info, because
    it is presumably shared (else it would have been inlined, and
    so we'd lose sharing if w/w'd it into a function).  E.g.

            let r = case expensive of
                      (a,b) -> (b,a)
            in ...

    If we marked r as having the CPR property, then we'd w/w into

            let $wr = \() -> case expensive of
                                (a,b) -> (# b, a #)
                r = case $wr () of
                      (# b,a #) -> (b,a)
            in ...

    But now r is a thunk, which won't be inlined, so we are no further ahead.
    But consider

            f x = let r = case expensive of (a,b) -> (b,a)
                  in if foo r then r else (x,x)

    Does f have the CPR property?  Well, no.

    However, if the strictness analyser has figured out (in a previous
    iteration) that it's strict, then we DON'T need to forget the CPR info.
    Instead we can retain the CPR info and do the thunk-splitting transform
    (see WorkWrap.splitThunk).

    This made a big difference to PrelBase.modInt, which had something like
            modInt = \ x -> let r = ... -> I# v in
                            ...body strict in r...
    r's RHS isn't a value yet; but modInt returns r in various branches, so
    if r doesn't have the CPR property then neither does modInt
    Another case I found in practice (in Complex.magnitude), looks like this:
                    let k = if ... then I# a else I# b
                    in ... body strict in k ....
    (For this example, it doesn't matter whether k is returned as part of
    the overall result; but it does matter that k's RHS has the CPR property.)
    Left to itself, the simplifier will make a join point thus:
                    let $j k = ...body strict in k...
                    if ... then $j (I# a) else $j (I# b)
    With thunk-splitting, we get instead
                    let $j x = let k = I#x in ...body strict in k...
                    in if ... then $j a else $j b
    This is much better; there's a good chance the I# won't get allocated.

    But what about botCpr? Consider
        lvl = error "boom"
        fac -1 = lvl
        fac 0 = 1
        fac n = n * fac (n-1)
    fac won't have the CPR property here when we trim every thunk! But the
    assumption is that error cases are rarely entered and we are diverging anyway,
    so WW doesn't hurt.

    Should we also trim CPR on DataCon application bindings?
    See Note [CPR for data structures]!

    Note [CPR for data structures]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Long static data structures (whether top-level or not) like

      xs = x1 : xs1
      xs1 = x2 : xs2
      xs2 = x3 : xs3

    should not get CPR signatures (#18154), because they

      * Never get WW'd, so their CPR signature should be irrelevant after analysis
        (in fact the signature might even be harmful for that reason)
      * Would need to be inlined/expanded to see their constructed product
      * Recording CPR on them blows up interface file sizes and is redundant with
        their unfolding. In case of Nested CPR, this blow-up can be quadratic!
        Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info
        for xs2 contains that for xs1. And so on.

    Hence we don't analyse or annotate data structures in 'cprAnalBind'. To
    implement this, the isDataStructure guard is triggered for bindings that satisfy

      (1) idArity id == 0 (otherwise it's a function)
      (2) exprIsHNF rhs   (otherwise it's a thunk, Note [CPR for thunks] applies)

    But we can't just stop giving DataCon application bindings the CPR *property*,
    for example

      fac 0 = I# 1#
      fac n = n * fac (n-1)

    fac certainly has the CPR property and should be WW'd! But FloatOut will
    transform the first clause to

      lvl = I# 1#
      fac 0 = lvl

    If lvl doesn't have the CPR property, fac won't either. But lvl is a data
    structure, and hence (see above) will not have a CPR signature. So instead, when
    'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR
    transformer, 'cprTransform' instead tries to get its unfolding (via
    'cprDataStructureUnfolding_maybe'), and analyses that instead.

    In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one
    for each data declaration. They should not have CPR signatures (blow up!).

    There is a perhaps surprising special case: KindRep bindings satisfy
    'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same
    time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is
    no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll
    return topCprType. And that is fine! We should refrain to look through NOINLINE
    data structures in general, as a constructed product could never be exposed
    after WW.

    It's also worth pointing out how ad-hoc this is: If we instead had

        f1 x = x:[]
        f2 x = x : f1 x
        f3 x = x : f2 x
        ...

    we still give every function an every deepening CPR signature. But it's very
    uncommon to find code like this, whereas the long static data structures from
    the beginning of this Note are very common because of GHC's strategy of ANF'ing
    data structure RHSs.

    Note [CPR examples]
    ~~~~~~~~~~~~~~~~~~~~
    Here are some examples (stranal/should_compile/T10482a) of the
    usefulness of Note [Optimistic field binder CPR].  The main
    point: all of these functions can have the CPR property.

        ------- f1 -----------
        -- x is used strictly by h, so it'll be available
        -- unboxed before it is returned in the True branch

        f1 :: Int -> Int
        f1 x = case h x x of
                True  -> x
                False -> f1 (x-1)

        ------- f3 -----------
        -- h is strict in x, so x will be unboxed before it
        -- is rerturned in the otherwise case.

        data T3 = MkT3 Int Int

        f1 :: T3 -> Int
        f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
                      | otherwise = x
    -}