{-# 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 }