    module GHC.Stg.Make
      ( MkStgRhs (..)
      , mkTopStgRhs
      , mkStgRhs
      , mkStgRhsCon_maybe
      , mkTopStgRhsCon_maybe
      )
    where

    import GHC.Prelude
    import GHC.Unit.Module

    import GHC.Core.DataCon
    import GHC.Core.Type (Type)

    import GHC.Stg.Syntax
    import GHC.Stg.Utils (stripStgTicksTop)

    import GHC.Types.Id
    import GHC.Types.Name
    import GHC.Types.CostCentre
    import GHC.Types.Demand    ( isAtMostOnceDmd )
    import GHC.Types.Tickish

    -- Represents the RHS of a binding for use with mk(Top)StgRhs and
    -- mk(Top)StgRhsCon_maybe.
    data MkStgRhs = MkStgRhs
      { MkStgRhs -> [Id]
    rhs_args :: [Id]     -- ^ Empty for thunks
      , MkStgRhs -> StgExpr
    rhs_expr :: StgExpr  -- ^ RHS expression
      , MkStgRhs -> Type
    rhs_type :: Type     -- ^ RHS type (only used in the JS backend: layering violation)
      , MkStgRhs -> Bool
    rhs_is_join :: !Bool -- ^ Is it a RHS for a join-point?
      }

    -- Generate a top-level RHS. Any new cost centres generated for CAFs will be
    -- appended to `CollectedCCs` argument.
    mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
                -> Bool -> Module -> CollectedCCs
                -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
    mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
    -> Bool
    -> Module
    -> CollectedCCs
    -> Id
    -> MkStgRhs
    -> (StgRhs, CollectedCCs)
    mkTopStgRhs Module -> DataCon -> [StgArg] -> Bool
    allow_toplevel_con_app Bool
    opt_AutoSccsOnIndividualCafs Module
    this_mod CollectedCCs
    ccs Id
    bndr mk_rhs :: MkStgRhs
    mk_rhs@(MkStgRhs [Id]
    bndrs StgExpr
    rhs Type
    typ Bool
    _)
      -- try to make a StgRhsCon first
      | Just StgRhs
    rhs_con <- (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
    mkTopStgRhsCon_maybe (Module -> DataCon -> [StgArg] -> Bool
    allow_toplevel_con_app Module
    this_mod) MkStgRhs
    mk_rhs
      = ( StgRhs
    rhs_con, CollectedCCs
    ccs )

      | Bool -> Bool
    not ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    bndrs)
      = -- The list of arguments is non-empty, so not CAF
        ( XRhsClosure 'Vanilla
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'Vanilla]
    -> StgExpr
    -> Type
    -> StgRhs
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> Type
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    NoExtFieldSilent
    noExtFieldSilent
                        CostCentreStack
    dontCareCCS
                        UpdateFlag
    ReEntrant
                        [Id]
    [BinderP 'Vanilla]
    bndrs StgExpr
    rhs Type
    typ
        , CollectedCCs
    ccs )

      -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
      | Bool
    opt_AutoSccsOnIndividualCafs
      = ( XRhsClosure 'Vanilla
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'Vanilla]
    -> StgExpr
    -> Type
    -> StgRhs
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> Type
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    NoExtFieldSilent
    noExtFieldSilent
                        CostCentreStack
    caf_ccs
                        UpdateFlag
    upd_flag [] StgExpr
    rhs Type
    typ
        , CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
    collectCC CostCentre
    caf_cc CostCentreStack
    caf_ccs CollectedCCs
    ccs )

      | Bool
    otherwise
      = ( XRhsClosure 'Vanilla
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'Vanilla]
    -> StgExpr
    -> Type
    -> StgRhs
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> Type
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    NoExtFieldSilent
    noExtFieldSilent
                        CostCentreStack
    all_cafs_ccs
                        UpdateFlag
    upd_flag [] StgExpr
    rhs Type
    typ
        , CollectedCCs
    ccs )

      where
        upd_flag :: UpdateFlag
    upd_flag | Demand -> Bool
    isAtMostOnceDmd (Id -> Demand
    idDemandInfo Id
    bndr) = UpdateFlag
    SingleEntry
                 | Bool
    otherwise                           = UpdateFlag
    Updatable

        -- CAF cost centres generated for -fcaf-all
        caf_cc :: CostCentre
    caf_cc = Id -> Module -> CostCentre
    mkAutoCC Id
    bndr Module
    modl
        caf_ccs :: CostCentreStack
    caf_ccs = CostCentre -> CostCentreStack
    mkSingletonCCS CostCentre
    caf_cc
               -- careful: the binder might be :Main.main,
               -- which doesn't belong to module mod_name.
               -- bug #249, tests prof001, prof002
        modl :: Module
    modl | Just Module
    m <- Name -> Maybe Module
    nameModule_maybe (Id -> Name
    idName Id
    bndr) = Module
    m
             | Bool
    otherwise = Module
    this_mod

        -- default CAF cost centre
        (CostCentre
    _, CostCentreStack
    all_cafs_ccs) = Module -> (CostCentre, CostCentreStack)
    getAllCAFsCC Module
    this_mod

    -- Generate a non-top-level RHS. Cost-centre is always currentCCS,
    -- see Note [Cost-centre initialization plan].
    mkStgRhs :: Id -> MkStgRhs -> StgRhs
    mkStgRhs :: Id -> MkStgRhs -> StgRhs
    mkStgRhs Id
    bndr mk_rhs :: MkStgRhs
    mk_rhs@(MkStgRhs [Id]
    bndrs StgExpr
    rhs Type
    typ Bool
    is_join)
      -- try to make a StgRhsCon first
      | Just StgRhs
    rhs_con <- MkStgRhs -> Maybe StgRhs
    mkStgRhsCon_maybe MkStgRhs
    mk_rhs
      = StgRhs
    rhs_con

      | Bool
    otherwise
      = XRhsClosure 'Vanilla
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP 'Vanilla]
    -> StgExpr
    -> Type
    -> StgRhs
    forall (pass :: StgPass).
    XRhsClosure pass
    -> CostCentreStack
    -> UpdateFlag
    -> [BinderP pass]
    -> GenStgExpr pass
    -> Type
    -> GenStgRhs pass
    StgRhsClosure XRhsClosure 'Vanilla
    NoExtFieldSilent
    noExtFieldSilent
                      CostCentreStack
    currentCCS
                      UpdateFlag
    upd_flag [Id]
    [BinderP 'Vanilla]
    bndrs StgExpr
    rhs Type
    typ
      where
        upd_flag :: UpdateFlag
    upd_flag | Bool
    is_join                             = UpdateFlag
    JumpedTo
                 | Bool -> Bool
    not ([Id] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Id]
    bndrs)                    = UpdateFlag
    ReEntrant
                 | Demand -> Bool
    isAtMostOnceDmd (Id -> Demand
    idDemandInfo Id
    bndr) = UpdateFlag
    SingleEntry
                 | Bool
    otherwise                           = UpdateFlag
    Updatable

      {-
        SDM: disabled.  Eval/Apply can't handle functions with arity zero very
        well; and making these into simple non-updatable thunks breaks other
        assumptions (namely that they will be entered only once).

        upd_flag | isPAP env rhs  = ReEntrant
                 | otherwise      = Updatable

    -- Detect thunks which will reduce immediately to PAPs, and make them
    -- non-updatable.  This has several advantages:
    --
    --         - the non-updatable thunk behaves exactly like the PAP,
    --
    --         - the thunk is more efficient to enter, because it is
    --           specialised to the task.
    --
    --         - we save one update frame, one stg_update_PAP, one update
    --           and lots of PAP_enters.
    --
    --         - in the case where the thunk is top-level, we save building
    --           a black hole and furthermore the thunk isn't considered to
    --           be a CAF any more, so it doesn't appear in any SRTs.
    --
    -- We do it here, because the arity information is accurate, and we need
    -- to do it before the SRT pass to save the SRT entries associated with
    -- any top-level PAPs.

    isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
                                  where
                                     arity = stgArity f (lookupBinding env f)
    isPAP env _               = False

    -}

    {- ToDo:
              upd = if isOnceDem dem
                        then (if isNotTop toplev
                                then SingleEntry    -- HA!  Paydirt for "dem"
                                else
                         (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
                         Updatable)
                    else Updatable
            -- For now we forbid SingleEntry CAFs; they tickle the
            -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
            -- and I don't understand why.  There's only one SE_CAF (well,
            -- only one that tickled a great gaping bug in an earlier attempt
            -- at ClosureInfo.getEntryConvention) in the whole of nofib,
            -- specifically Main.lvl6 in spectral/cryptarithm2.
            -- So no great loss.  KSW 2000-07.
    -}

    -- | Try to make a non top-level StgRhsCon if appropriate
    mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs
    mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs
    mkStgRhsCon_maybe (MkStgRhs [Id]
    bndrs StgExpr
    rhs Type
    typ Bool
    is_join)
      | [] <- [Id]
    bndrs
      , Bool -> Bool
    not Bool
    is_join
      , ([StgTickish]
    ticks, StgConApp DataCon
    con ConstructorNumber
    mn [StgArg]
    args [[PrimRep]]
    _) <- (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
    forall (p :: StgPass).
    (StgTickish -> Bool)
    -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
    stripStgTicksTop (Bool -> Bool
    not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StgTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishIsCode) StgExpr
    rhs
      = StgRhs -> Maybe StgRhs
    forall a. a -> Maybe a
    Just (CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> Type
    -> StgRhs
    forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> Type
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    currentCCS DataCon
    con ConstructorNumber
    mn [StgTickish]
    ticks [StgArg]
    args Type
    typ)

      | Bool
    otherwise = Maybe StgRhs
    forall a. Maybe a
    Nothing

    -- | Try to make a top-level StgRhsCon if appropriate
    mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
    mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
    mkTopStgRhsCon_maybe DataCon -> [StgArg] -> Bool
    allow_static_con_app (MkStgRhs [Id]
    bndrs StgExpr
    rhs Type
    typ Bool
    is_join)
      | [] <- [Id]
    bndrs
      , Bool -> Bool
    not Bool
    is_join -- shouldn't happen at top-level
      , ([StgTickish]
    ticks, StgConApp DataCon
    con ConstructorNumber
    mn [StgArg]
    args [[PrimRep]]
    _) <- (StgTickish -> Bool) -> StgExpr -> ([StgTickish], StgExpr)
    forall (p :: StgPass).
    (StgTickish -> Bool)
    -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
    stripStgTicksTop (Bool -> Bool
    not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . StgTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishIsCode) StgExpr
    rhs
      , DataCon -> [StgArg] -> Bool
    allow_static_con_app DataCon
    con [StgArg]
    args
      = StgRhs -> Maybe StgRhs
    forall a. a -> Maybe a
    Just (CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> Type
    -> StgRhs
    forall (pass :: StgPass).
    CostCentreStack
    -> DataCon
    -> ConstructorNumber
    -> [StgTickish]
    -> [StgArg]
    -> Type
    -> GenStgRhs pass
    StgRhsCon CostCentreStack
    dontCareCCS DataCon
    con ConstructorNumber
    mn [StgTickish]
    ticks [StgArg]
    args Type
    typ)

      | Bool
    otherwise = Maybe StgRhs
    forall a. Maybe a
    Nothing