    {-# LANGUAGE CPP #-}

    -- | Unfolding creation
    module GHC.Core.Unfold.Make
       ( noUnfolding
       , mkUnfolding
       , mkCoreUnfolding
       , mkFinalUnfolding
       , mkSimpleUnfolding
       , mkWorkerUnfolding
       , mkInlineUnfolding
       , mkInlineUnfoldingWithArity
       , mkInlinableUnfolding
       , mkWwInlineRule
       , mkCompulsoryUnfolding
       , mkCompulsoryUnfolding'
       , mkDFunUnfolding
       , specUnfolding
       )
    where

    #include "HsVersions.h"

    import GHC.Prelude
    import GHC.Core
    import GHC.Core.Unfold
    import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
    import GHC.Core.Opt.Arity   ( manifestArity )
    import GHC.Core.DataCon
    import GHC.Core.Utils
    import GHC.Types.Basic
    import GHC.Types.Id
    import GHC.Types.Demand ( StrictSig, isDeadEndSig )

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

    -- the very simple optimiser is used to optimise unfoldings
    import {-# SOURCE #-} GHC.Core.SimpleOpt

    mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding
    -- "Final" in the sense that this is a GlobalId that will not be further
    -- simplified; so the unfolding should be occurrence-analysed
    mkFinalUnfolding :: UnfoldingOpts
    -> UnfoldingSource -> StrictSig -> CoreArg -> Unfolding
    mkFinalUnfolding UnfoldingOpts
    opts UnfoldingSource
    src StrictSig
    strict_sig CoreArg
    expr
      = UnfoldingOpts
    -> UnfoldingSource -> Bool -> Bool -> CoreArg -> Unfolding
    mkUnfolding UnfoldingOpts
    opts UnfoldingSource
    src
                    Bool
    True {- Top level -}
                    (StrictSig -> Bool
    isDeadEndSig StrictSig
    strict_sig)
                    CoreArg
    expr

    -- | Used for things that absolutely must be unfolded
    mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
    mkCompulsoryUnfolding :: SimpleOpts -> CoreArg -> Unfolding
    mkCompulsoryUnfolding SimpleOpts
    opts CoreArg
    expr = CoreArg -> Unfolding
    mkCompulsoryUnfolding' (HasDebugCallStack => SimpleOpts -> CoreArg -> CoreArg
    SimpleOpts -> CoreArg -> CoreArg
    simpleOptExpr SimpleOpts
    opts CoreArg
    expr)

    -- | Same as 'mkCompulsoryUnfolding' but no simple optimiser pass is performed
    -- on the unfolding.
    mkCompulsoryUnfolding' :: CoreExpr -> Unfolding
    mkCompulsoryUnfolding' :: CoreArg -> Unfolding
    mkCompulsoryUnfolding' CoreArg
    expr
      = UnfoldingSource
    -> Bool -> CoreArg -> UnfoldingGuidance -> Unfolding
    mkCoreUnfolding UnfoldingSource
    InlineCompulsory Bool
    True
                        CoreArg
    expr
                        (UnfWhen { ug_arity :: Arity
    ug_arity = Arity
    0    -- Arity of unfolding doesn't matter
                                 , ug_unsat_ok :: Bool
    ug_unsat_ok = Bool
    unSaturatedOk, ug_boring_ok :: Bool
    ug_boring_ok = Bool
    boringCxtOk })

    -- Note [Top-level flag on inline rules]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- Slight hack: note that mk_inline_rules conservatively sets the
    -- top-level flag to True.  It gets set more accurately by the simplifier
    -- Simplify.simplUnfolding.

    mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
    mkSimpleUnfolding :: UnfoldingOpts -> CoreArg -> Unfolding
    mkSimpleUnfolding !UnfoldingOpts
    opts CoreArg
    rhs
      = UnfoldingOpts
    -> UnfoldingSource -> Bool -> Bool -> CoreArg -> Unfolding
    mkUnfolding UnfoldingOpts
    opts UnfoldingSource
    InlineRhs Bool
    False Bool
    False CoreArg
    rhs

    mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
    mkDFunUnfolding :: [Var] -> DataCon -> [CoreArg] -> Unfolding
    mkDFunUnfolding [Var]
    bndrs DataCon
    con [CoreArg]
    ops
      = DFunUnfolding { df_bndrs :: [Var]
    df_bndrs = [Var]
    bndrs
                      , df_con :: DataCon
    df_con = DataCon
    con
                      , df_args :: [CoreArg]
    df_args = (CoreArg -> CoreArg) -> [CoreArg] -> [CoreArg]
    forall a b. (a -> b) -> [a] -> [b]
    map CoreArg -> CoreArg
    occurAnalyseExpr [CoreArg]
    ops }
                      -- See Note [Occurrence analysis of unfoldings]

    mkWwInlineRule :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
    mkWwInlineRule :: SimpleOpts -> CoreArg -> Arity -> Unfolding
    mkWwInlineRule SimpleOpts
    opts CoreArg
    expr Arity
    arity
      = UnfoldingSource
    -> Bool -> CoreArg -> UnfoldingGuidance -> Unfolding
    mkCoreUnfolding UnfoldingSource
    InlineStable Bool
    True
                       (HasDebugCallStack => SimpleOpts -> CoreArg -> CoreArg
    SimpleOpts -> CoreArg -> CoreArg
    simpleOptExpr SimpleOpts
    opts CoreArg
    expr)
                       (UnfWhen { ug_arity :: Arity
    ug_arity = Arity
    arity, ug_unsat_ok :: Bool
    ug_unsat_ok = Bool
    unSaturatedOk
                                , ug_boring_ok :: Bool
    ug_boring_ok = Bool
    boringCxtNotOk })

    mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding
    -- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap
    mkWorkerUnfolding :: SimpleOpts -> (CoreArg -> CoreArg) -> Unfolding -> Unfolding
    mkWorkerUnfolding SimpleOpts
    opts CoreArg -> CoreArg
    work_fn
                      (CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
    uf_src = UnfoldingSource
    src, uf_tmpl :: Unfolding -> CoreArg
    uf_tmpl = CoreArg
    tmpl
                                     , uf_is_top :: Unfolding -> Bool
    uf_is_top = Bool
    top_lvl })
      | UnfoldingSource -> Bool
    isStableSource UnfoldingSource
    src
      = UnfoldingSource
    -> Bool -> CoreArg -> UnfoldingGuidance -> Unfolding
    mkCoreUnfolding UnfoldingSource
    src Bool
    top_lvl CoreArg
    new_tmpl UnfoldingGuidance
    guidance
      where
        new_tmpl :: CoreArg
    new_tmpl = HasDebugCallStack => SimpleOpts -> CoreArg -> CoreArg
    SimpleOpts -> CoreArg -> CoreArg
    simpleOptExpr SimpleOpts
    opts (CoreArg -> CoreArg
    work_fn CoreArg
    tmpl)
        guidance :: UnfoldingGuidance
    guidance = UnfoldingOpts -> Bool -> CoreArg -> UnfoldingGuidance
    calcUnfoldingGuidance (SimpleOpts -> UnfoldingOpts
    so_uf_opts SimpleOpts
    opts) Bool
    False CoreArg
    new_tmpl

    mkWorkerUnfolding SimpleOpts
    _ CoreArg -> CoreArg
    _ Unfolding
    _ = Unfolding
    noUnfolding

    -- | Make an unfolding that may be used unsaturated
    -- (ug_unsat_ok = unSaturatedOk) and that is reported as having its
    -- manifest arity (the number of outer lambdas applications will
    -- resolve before doing any work).
    mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
    mkInlineUnfolding :: SimpleOpts -> CoreArg -> Unfolding
    mkInlineUnfolding SimpleOpts
    opts CoreArg
    expr
      = UnfoldingSource
    -> Bool -> CoreArg -> UnfoldingGuidance -> Unfolding
    mkCoreUnfolding UnfoldingSource
    InlineStable
                        Bool
    True         -- Note [Top-level flag on inline rules]
                        CoreArg
    expr' UnfoldingGuidance
    guide
      where
        expr' :: CoreArg
    expr' = HasDebugCallStack => SimpleOpts -> CoreArg -> CoreArg
    SimpleOpts -> CoreArg -> CoreArg
    simpleOptExpr SimpleOpts
    opts CoreArg
    expr
        guide :: UnfoldingGuidance
    guide = UnfWhen { ug_arity :: Arity
    ug_arity = CoreArg -> Arity
    manifestArity CoreArg
    expr'
                        , ug_unsat_ok :: Bool
    ug_unsat_ok = Bool
    unSaturatedOk
                        , ug_boring_ok :: Bool
    ug_boring_ok = Bool
    boring_ok }
        boring_ok :: Bool
    boring_ok = CoreArg -> Bool
    inlineBoringOk CoreArg
    expr'

    -- | Make an unfolding that will be used once the RHS has been saturated
    -- to the given arity.
    mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding
    mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreArg -> Unfolding
    mkInlineUnfoldingWithArity Arity
    arity SimpleOpts
    opts CoreArg
    expr
      = UnfoldingSource
    -> Bool -> CoreArg -> UnfoldingGuidance -> Unfolding
    mkCoreUnfolding UnfoldingSource
    InlineStable
                        Bool
    True         -- Note [Top-level flag on inline rules]
                        CoreArg
    expr' UnfoldingGuidance
    guide
      where
        expr' :: CoreArg
    expr' = HasDebugCallStack => SimpleOpts -> CoreArg -> CoreArg
    SimpleOpts -> CoreArg -> CoreArg
    simpleOptExpr SimpleOpts
    opts CoreArg
    expr
        guide :: UnfoldingGuidance
    guide = UnfWhen { ug_arity :: Arity
    ug_arity = Arity
    arity
                        , ug_unsat_ok :: Bool
    ug_unsat_ok = Bool
    needSaturated
                        , ug_boring_ok :: Bool
    ug_boring_ok = Bool
    boring_ok }
        -- See Note [INLINE pragmas and boring contexts] as to why we need to look
        -- at the arity here.
        boring_ok :: Bool
    boring_ok | Arity
    arity Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    0 = Bool
    True
                  | Bool
    otherwise  = CoreArg -> Bool
    inlineBoringOk CoreArg
    expr'

    mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
    mkInlinableUnfolding :: SimpleOpts -> CoreArg -> Unfolding
    mkInlinableUnfolding SimpleOpts
    opts CoreArg
    expr
      = UnfoldingOpts
    -> UnfoldingSource -> Bool -> Bool -> CoreArg -> Unfolding
    mkUnfolding (SimpleOpts -> UnfoldingOpts
    so_uf_opts SimpleOpts
    opts) UnfoldingSource
    InlineStable Bool
    False Bool
    False CoreArg
    expr'
      where
        expr' :: CoreArg
    expr' = HasDebugCallStack => SimpleOpts -> CoreArg -> CoreArg
    SimpleOpts -> CoreArg -> CoreArg
    simpleOptExpr SimpleOpts
    opts CoreArg
    expr

    specUnfolding :: SimpleOpts
                  -> [Var] -> (CoreExpr -> CoreExpr)
                  -> [CoreArg]   -- LHS arguments in the RULE
                  -> Unfolding -> Unfolding
    -- See Note [Specialising unfoldings]
    -- specUnfolding spec_bndrs spec_args unf
    --   = \spec_bndrs. unf spec_args
    --
    specUnfolding :: SimpleOpts
    -> [Var]
    -> (CoreArg -> CoreArg)
    -> [CoreArg]
    -> Unfolding
    -> Unfolding
    specUnfolding SimpleOpts
    opts [Var]
    spec_bndrs CoreArg -> CoreArg
    spec_app [CoreArg]
    rule_lhs_args
                  df :: Unfolding
    df@(DFunUnfolding { df_bndrs :: Unfolding -> [Var]
    df_bndrs = [Var]
    old_bndrs, df_con :: Unfolding -> DataCon
    df_con = DataCon
    con, df_args :: Unfolding -> [CoreArg]
    df_args = [CoreArg]
    args })
      = ASSERT2( rule_lhs_args `equalLength` old_bndrs
               , ppr df $$ ppr rule_lhs_args )
               -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise
        [Var] -> DataCon -> [CoreArg] -> Unfolding
    mkDFunUnfolding [Var]
    spec_bndrs DataCon
    con ((CoreArg -> CoreArg) -> [CoreArg] -> [CoreArg]
    forall a b. (a -> b) -> [a] -> [b]
    map CoreArg -> CoreArg
    spec_arg [CoreArg]
    args)
          -- For DFunUnfoldings we transform
          --       \obs. MkD <op1> ... <opn>
          -- to
          --       \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>
      where
        spec_arg :: CoreArg -> CoreArg
    spec_arg CoreArg
    arg = HasDebugCallStack => SimpleOpts -> CoreArg -> CoreArg
    SimpleOpts -> CoreArg -> CoreArg
    simpleOptExpr SimpleOpts
    opts (CoreArg -> CoreArg) -> CoreArg -> CoreArg
    forall a b. (a -> b) -> a -> b
    $
                       CoreArg -> CoreArg
    spec_app ([Var] -> CoreArg -> CoreArg
    forall b. [b] -> Expr b -> Expr b
    mkLams [Var]
    old_bndrs CoreArg
    arg)
                       -- The beta-redexes created by spec_app will be
                       -- simplified away by simplOptExpr

    specUnfolding SimpleOpts
    opts [Var]
    spec_bndrs CoreArg -> CoreArg
    spec_app [CoreArg]
    rule_lhs_args
                  (CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
    uf_src = UnfoldingSource
    src, uf_tmpl :: Unfolding -> CoreArg
    uf_tmpl = CoreArg
    tmpl
                                 , uf_is_top :: Unfolding -> Bool
    uf_is_top = Bool
    top_lvl
                                 , uf_guidance :: Unfolding -> UnfoldingGuidance
    uf_guidance = UnfoldingGuidance
    old_guidance })
     | UnfoldingSource -> Bool
    isStableSource UnfoldingSource
    src  -- See Note [Specialising unfoldings]
     , UnfWhen { ug_arity :: UnfoldingGuidance -> Arity
    ug_arity     = Arity
    old_arity } <- UnfoldingGuidance
    old_guidance
     = UnfoldingSource
    -> Bool -> CoreArg -> UnfoldingGuidance -> Unfolding
    mkCoreUnfolding UnfoldingSource
    src Bool
    top_lvl CoreArg
    new_tmpl
                       (UnfoldingGuidance
    old_guidance { ug_arity :: Arity
    ug_arity = Arity
    old_arity Arity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    - Arity
    arity_decrease })
     where
       new_tmpl :: CoreArg
    new_tmpl = HasDebugCallStack => SimpleOpts -> CoreArg -> CoreArg
    SimpleOpts -> CoreArg -> CoreArg
    simpleOptExpr SimpleOpts
    opts (CoreArg -> CoreArg) -> CoreArg -> CoreArg
    forall a b. (a -> b) -> a -> b
    $
                  [Var] -> CoreArg -> CoreArg
    forall b. [b] -> Expr b -> Expr b
    mkLams [Var]
    spec_bndrs    (CoreArg -> CoreArg) -> CoreArg -> CoreArg
    forall a b. (a -> b) -> a -> b
    $
                  CoreArg -> CoreArg
    spec_app CoreArg
    tmpl  -- The beta-redexes created by spec_app
                                 -- will besimplified away by simplOptExpr
       arity_decrease :: Arity
    arity_decrease = (CoreArg -> Bool) -> [CoreArg] -> Arity
    forall a. (a -> Bool) -> [a] -> Arity
    count CoreArg -> Bool
    forall b. Expr b -> Bool
    isValArg [CoreArg]
    rule_lhs_args Arity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    - (Var -> Bool) -> [Var] -> Arity
    forall a. (a -> Bool) -> [a] -> Arity
    count Var -> Bool
    isId [Var]
    spec_bndrs

    specUnfolding SimpleOpts
    _ [Var]
    _ CoreArg -> CoreArg
    _ [CoreArg]
    _ Unfolding
    _ = Unfolding
    noUnfolding

    {- Note [Specialising unfoldings]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When we specialise a function for some given type-class arguments, we use
    specUnfolding to specialise its unfolding.  Some important points:

    * If the original function has a DFunUnfolding, the specialised one
      must do so too!  Otherwise we lose the magic rules that make it
      interact with ClassOps

    * There is a bit of hack for INLINABLE functions:
         f :: Ord a => ....
         f = <big-rhs>
         {- INLINABLE f #-}
      Now if we specialise f, should the specialised version still have
      an INLINABLE pragma?  If it does, we'll capture a specialised copy
      of <big-rhs> as its unfolding, and that probably won't inline.  But
      if we don't, the specialised version of <big-rhs> might be small
      enough to inline at a call site. This happens with Control.Monad.liftM3,
      and can cause a lot more allocation as a result (nofib n-body shows this).

      Moreover, keeping the INLINABLE thing isn't much help, because
      the specialised function (probably) isn't overloaded any more.

      Conclusion: drop the INLINEALE pragma.  In practice what this means is:
         if a stable unfolding has UnfoldingGuidance of UnfWhen,
            we keep it (so the specialised thing too will always inline)
         if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs
            (which arises from INLINABLE), we discard it

    Note [Honour INLINE on 0-ary bindings]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider

       x = <expensive>
       {-# INLINE x #-}

       f y = ...x...

    The semantics of an INLINE pragma is

      inline x at every call site, provided it is saturated;
      that is, applied to at least as many arguments as appear
      on the LHS of the Haskell source definition.

    (This source-code-derived arity is stored in the `ug_arity` field of
    the `UnfoldingGuidance`.)

    In the example, x's ug_arity is 0, so we should inline it at every use
    site.  It's rare to have such an INLINE pragma (usually INLINE Is on
    functions), but it's occasionally very important (#15578, #15519).
    In #15519 we had something like
       x = case (g a b) of I# r -> T r
       {-# INLINE x #-}
       f y = ...(h x)....

    where h is strict.  So we got
       f y = ...(case g a b of I# r -> h (T r))...

    and that in turn allowed SpecConstr to ramp up performance.

    How do we deliver on this?  By adjusting the ug_boring_ok
    flag in mkInlineUnfoldingWithArity; see
    Note [INLINE pragmas and boring contexts]

    NB: there is a real risk that full laziness will float it right back
    out again. Consider again
      x = factorial 200
      {-# INLINE x #-}
      f y = ...x...

    After inlining we get
      f y = ...(factorial 200)...

    but it's entirely possible that full laziness will do
      lvl23 = factorial 200
      f y = ...lvl23...

    That's a problem for another day.

    Note [INLINE pragmas and boring contexts]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    An INLINE pragma uses mkInlineUnfoldingWithArity to build the
    unfolding.  That sets the ug_boring_ok flag to False if the function
    is not tiny (inlineBoringOK), so that even INLINE functions are not
    inlined in an utterly boring context.  E.g.
         \x y. Just (f y x)
    Nothing is gained by inlining f here, even if it has an INLINE
    pragma.

    But for 0-ary bindings, we want to inline regardless; see
    Note [Honour INLINE on 0-ary bindings].

    I'm a bit worried that it's possible for the same kind of problem
    to arise for non-0-ary functions too, but let's wait and see.
    -}

    mkUnfolding :: UnfoldingOpts
                -> UnfoldingSource
                -> Bool       -- Is top-level
                -> Bool       -- Definitely a bottoming binding
                              -- (only relevant for top-level bindings)
                -> CoreExpr
                -> Unfolding
    -- Calculates unfolding guidance
    -- Occurrence-analyses the expression before capturing it
    mkUnfolding :: UnfoldingOpts
    -> UnfoldingSource -> Bool -> Bool -> CoreArg -> Unfolding
    mkUnfolding UnfoldingOpts
    opts UnfoldingSource
    src Bool
    top_lvl Bool
    is_bottoming CoreArg
    expr
      = UnfoldingSource
    -> Bool -> CoreArg -> UnfoldingGuidance -> Unfolding
    mkCoreUnfolding UnfoldingSource
    src Bool
    top_lvl CoreArg
    expr UnfoldingGuidance
    guidance
      where
        is_top_bottoming :: Bool
    is_top_bottoming = Bool
    top_lvl Bool -> Bool -> Bool
    && Bool
    is_bottoming
        guidance :: UnfoldingGuidance
    guidance         = UnfoldingOpts -> Bool -> CoreArg -> UnfoldingGuidance
    calcUnfoldingGuidance UnfoldingOpts
    opts Bool
    is_top_bottoming CoreArg
    expr
            -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!
            -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]

    mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
                    -> UnfoldingGuidance -> Unfolding
    -- Occurrence-analyses the expression before capturing it
    mkCoreUnfolding :: UnfoldingSource
    -> Bool -> CoreArg -> UnfoldingGuidance -> Unfolding
    mkCoreUnfolding UnfoldingSource
    src Bool
    top_lvl CoreArg
    expr UnfoldingGuidance
    guidance
      = CoreUnfolding { uf_tmpl :: CoreArg
    uf_tmpl         = CoreArg -> CoreArg
    occurAnalyseExpr CoreArg
    expr,
                          -- See Note [Occurrence analysis of unfoldings]
                        uf_src :: UnfoldingSource
    uf_src          = UnfoldingSource
    src,
                        uf_is_top :: Bool
    uf_is_top       = Bool
    top_lvl,
                        uf_is_value :: Bool
    uf_is_value     = CoreArg -> Bool
    exprIsHNF        CoreArg
    expr,
                        uf_is_conlike :: Bool
    uf_is_conlike   = CoreArg -> Bool
    exprIsConLike    CoreArg
    expr,
                        uf_is_work_free :: Bool
    uf_is_work_free = CoreArg -> Bool
    exprIsWorkFree   CoreArg
    expr,
                        uf_expandable :: Bool
    uf_expandable   = CoreArg -> Bool
    exprIsExpandable CoreArg
    expr,
                        uf_guidance :: UnfoldingGuidance
    uf_guidance     = UnfoldingGuidance
    guidance }