{-# LANGUAGE ConstraintKinds  #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeFamilies     #-}
{-# LANGUAGE TypeOperators    #-}
{-# LANGUAGE ViewPatterns     #-}

{- |
An inlining pass.

This pass is essentially a copy of the PIR inliner, and should be KEPT IN SYNC with it.
It's hard to do this with true abstraction, so we just have to keep two copies reasonably
similar.

However, there are some differences. In the interests of making it easier to keep
things in sync, these are explicitly listed in Note [Differences from PIR inliner].
If you add another difference, please note it there! Obviously fewer differences is
better.

See Note [The problem of inlining destructors] for why this pass exists.
-}
module UntypedPlutusCore.Transform.Inline (inline, InlineHints (..)) where

import PlutusCore qualified as PLC
import PlutusCore.Annotation
import PlutusCore.Builtin qualified as PLC
import PlutusCore.MkPlc (mkIterApp)
import PlutusCore.Name.Unique
import PlutusCore.Name.UniqueMap qualified as UMap
import PlutusCore.Quote
import PlutusCore.Rename (Dupable, dupable, liftDupable)
import PlutusPrelude
import UntypedPlutusCore.Analysis.Usages qualified as Usages
import UntypedPlutusCore.Core qualified as UPLC
import UntypedPlutusCore.Core.Plated
import UntypedPlutusCore.Core.Type
import UntypedPlutusCore.MkUPlc
import UntypedPlutusCore.Purity
import UntypedPlutusCore.Rename ()
import UntypedPlutusCore.Size
import UntypedPlutusCore.Subst

import Control.Lens hiding (Strict)
import Control.Monad.Extra
import Control.Monad.Reader
import Control.Monad.State
import Witherable (wither)

{- Note [Differences from PIR inliner]
See the module comment for explanation for why this exists and is similar to the PIR inliner.

1. No types (obviously).
2. No strictness information (we only have lambda arguments, which are always strict).
3. Handling of multiple beta-reductions in one go, this is handled in PIR by a dedicated pass.
4. Simplistic purity analysis, in particular we don't try to be clever about builtins
(should mostly be handled in PIR).
-}

-- | Substitution range, 'SubstRng' in the paper.
newtype InlineTerm name uni fun a = Done (Dupable (Term name uni fun a))

{- | Term substitution, 'Subst' in the paper.
A map of unprocessed variable and its substitution range.
-}
newtype TermEnv name uni fun a = TermEnv
  {forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> UniqueMap TermUnique (InlineTerm name uni fun a)
_unTermEnv :: PLC.UniqueMap TermUnique (InlineTerm name uni fun a)}
  deriving newtype (NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
(TermEnv name uni fun a
 -> TermEnv name uni fun a -> TermEnv name uni fun a)
-> (NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a)
-> (forall b.
    Integral b =>
    b -> TermEnv name uni fun a -> TermEnv name uni fun a)
-> Semigroup (TermEnv name uni fun a)
forall b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall name (uni :: * -> *) fun a.
NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a
forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
forall name (uni :: * -> *) fun a b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a
$c<> :: forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
<> :: TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
$csconcat :: forall name (uni :: * -> *) fun a.
NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a
sconcat :: NonEmpty (TermEnv name uni fun a) -> TermEnv name uni fun a
$cstimes :: forall name (uni :: * -> *) fun a b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a
stimes :: forall b.
Integral b =>
b -> TermEnv name uni fun a -> TermEnv name uni fun a
Semigroup, Semigroup (TermEnv name uni fun a)
TermEnv name uni fun a
Semigroup (TermEnv name uni fun a) =>
TermEnv name uni fun a
-> (TermEnv name uni fun a
    -> TermEnv name uni fun a -> TermEnv name uni fun a)
-> ([TermEnv name uni fun a] -> TermEnv name uni fun a)
-> Monoid (TermEnv name uni fun a)
[TermEnv name uni fun a] -> TermEnv name uni fun a
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall name (uni :: * -> *) fun a.
Semigroup (TermEnv name uni fun a)
forall name (uni :: * -> *) fun a. TermEnv name uni fun a
forall name (uni :: * -> *) fun a.
[TermEnv name uni fun a] -> TermEnv name uni fun a
forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
$cmempty :: forall name (uni :: * -> *) fun a. TermEnv name uni fun a
mempty :: TermEnv name uni fun a
$cmappend :: forall name (uni :: * -> *) fun a.
TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
mappend :: TermEnv name uni fun a
-> TermEnv name uni fun a -> TermEnv name uni fun a
$cmconcat :: forall name (uni :: * -> *) fun a.
[TermEnv name uni fun a] -> TermEnv name uni fun a
mconcat :: [TermEnv name uni fun a] -> TermEnv name uni fun a
Monoid)

{- | Wrapper of term substitution so that it's similar to the PIR inliner.
See Note [Differences from PIR inliner] 1
-}
newtype Subst name uni fun a = Subst {forall name (uni :: * -> *) fun a.
Subst name uni fun a -> TermEnv name uni fun a
_termEnv :: TermEnv name uni fun a}
  deriving stock ((forall x. Subst name uni fun a -> Rep (Subst name uni fun a) x)
-> (forall x. Rep (Subst name uni fun a) x -> Subst name uni fun a)
-> Generic (Subst name uni fun a)
forall x. Rep (Subst name uni fun a) x -> Subst name uni fun a
forall x. Subst name uni fun a -> Rep (Subst name uni fun a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall name (uni :: * -> *) fun a x.
Rep (Subst name uni fun a) x -> Subst name uni fun a
forall name (uni :: * -> *) fun a x.
Subst name uni fun a -> Rep (Subst name uni fun a) x
$cfrom :: forall name (uni :: * -> *) fun a x.
Subst name uni fun a -> Rep (Subst name uni fun a) x
from :: forall x. Subst name uni fun a -> Rep (Subst name uni fun a) x
$cto :: forall name (uni :: * -> *) fun a x.
Rep (Subst name uni fun a) x -> Subst name uni fun a
to :: forall x. Rep (Subst name uni fun a) x -> Subst name uni fun a
Generic)
  deriving newtype (NonEmpty (Subst name uni fun a) -> Subst name uni fun a
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
(Subst name uni fun a
 -> Subst name uni fun a -> Subst name uni fun a)
-> (NonEmpty (Subst name uni fun a) -> Subst name uni fun a)
-> (forall b.
    Integral b =>
    b -> Subst name uni fun a -> Subst name uni fun a)
-> Semigroup (Subst name uni fun a)
forall b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall name (uni :: * -> *) fun a.
NonEmpty (Subst name uni fun a) -> Subst name uni fun a
forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
forall name (uni :: * -> *) fun a b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a
$c<> :: forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
<> :: Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
$csconcat :: forall name (uni :: * -> *) fun a.
NonEmpty (Subst name uni fun a) -> Subst name uni fun a
sconcat :: NonEmpty (Subst name uni fun a) -> Subst name uni fun a
$cstimes :: forall name (uni :: * -> *) fun a b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a
stimes :: forall b.
Integral b =>
b -> Subst name uni fun a -> Subst name uni fun a
Semigroup, Semigroup (Subst name uni fun a)
Subst name uni fun a
Semigroup (Subst name uni fun a) =>
Subst name uni fun a
-> (Subst name uni fun a
    -> Subst name uni fun a -> Subst name uni fun a)
-> ([Subst name uni fun a] -> Subst name uni fun a)
-> Monoid (Subst name uni fun a)
[Subst name uni fun a] -> Subst name uni fun a
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall name (uni :: * -> *) fun a. Semigroup (Subst name uni fun a)
forall name (uni :: * -> *) fun a. Subst name uni fun a
forall name (uni :: * -> *) fun a.
[Subst name uni fun a] -> Subst name uni fun a
forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
$cmempty :: forall name (uni :: * -> *) fun a. Subst name uni fun a
mempty :: Subst name uni fun a
$cmappend :: forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
mappend :: Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
$cmconcat :: forall name (uni :: * -> *) fun a.
[Subst name uni fun a] -> Subst name uni fun a
mconcat :: [Subst name uni fun a] -> Subst name uni fun a
Monoid)

makeLenses ''TermEnv
makeLenses ''Subst

data VarInfo name uni fun ann = VarInfo
  { forall name (uni :: * -> *) fun ann.
VarInfo name uni fun ann -> [name]
_varBinders :: [name]
  -- ^ Lambda binders in the RHS (definition) of the variable.
  , forall name (uni :: * -> *) fun ann.
VarInfo name uni fun ann -> Term name uni fun ann
_varRhs     :: Term name uni fun ann
  -- ^ The RHS (definition) of the variable.
  , forall name (uni :: * -> *) fun ann.
VarInfo name uni fun ann -> InlineTerm name uni fun ann
_varRhsBody :: InlineTerm name uni fun ann
  -- ^ The body of the RHS of the variable (i.e., RHS minus the binders). Using `InlineTerm`
  -- here to ensure the body is renamed when inlined.
  }

makeLenses ''VarInfo

-- | UPLC inliner state
data S name uni fun a = S
  { forall name (uni :: * -> *) fun a.
S name uni fun a -> Subst name uni fun a
_subst :: Subst name uni fun a
  , forall name (uni :: * -> *) fun a.
S name uni fun a -> UniqueMap TermUnique (VarInfo name uni fun a)
_vars  :: PLC.UniqueMap TermUnique (VarInfo name uni fun a)
  }

makeLenses ''S

instance Semigroup (S name uni fun a) where
  S Subst name uni fun a
a1 UniqueMap TermUnique (VarInfo name uni fun a)
b1 <> :: S name uni fun a -> S name uni fun a -> S name uni fun a
<> S Subst name uni fun a
a2 UniqueMap TermUnique (VarInfo name uni fun a)
b2 = Subst name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> S name uni fun a
forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> S name uni fun a
S (Subst name uni fun a
a1 Subst name uni fun a
-> Subst name uni fun a -> Subst name uni fun a
forall a. Semigroup a => a -> a -> a
<> Subst name uni fun a
a2) (UniqueMap TermUnique (VarInfo name uni fun a)
b1 UniqueMap TermUnique (VarInfo name uni fun a)
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> UniqueMap TermUnique (VarInfo name uni fun a)
forall a. Semigroup a => a -> a -> a
<> UniqueMap TermUnique (VarInfo name uni fun a)
b2)

instance Monoid (S name uni fun a) where
  mempty :: S name uni fun a
mempty = Subst name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> S name uni fun a
forall name (uni :: * -> *) fun a.
Subst name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> S name uni fun a
S Subst name uni fun a
forall a. Monoid a => a
mempty UniqueMap TermUnique (VarInfo name uni fun a)
forall a. Monoid a => a
mempty

type ExternalConstraints name uni fun m =
  ( HasUnique name TermUnique
  , Eq name
  , PLC.ToBuiltinMeaning uni fun
  , MonadQuote m
  )

type InliningConstraints name uni fun =
  ( HasUnique name TermUnique
  , Eq name
  , PLC.ToBuiltinMeaning uni fun
  )

-- See Note [Differences from PIR inliner] 2
data InlineInfo name fun a = InlineInfo
  { forall name fun a. InlineInfo name fun a -> Usages
_iiUsages                  :: Usages.Usages
  , forall name fun a. InlineInfo name fun a -> InlineHints name a
_iiHints                   :: InlineHints name a
  , forall name fun a.
InlineInfo name fun a -> BuiltinSemanticsVariant fun
_iiBuiltinSemanticsVariant :: PLC.BuiltinSemanticsVariant fun
  , forall name fun a. InlineInfo name fun a -> Bool
_iiInlineConstants         :: Bool
  }

makeLenses ''InlineInfo

-- Using a concrete monad makes a very large difference to the performance of this module
-- (determined from profiling)

-- | The monad the inliner runs in.
type InlineM name uni fun a = ReaderT (InlineInfo name fun a) (StateT (S name uni fun a) Quote)

-- | Look up the unprocessed variable in the substitution.
lookupTerm ::
  (HasUnique name TermUnique) =>
  name ->
  S name uni fun a ->
  Maybe (InlineTerm name uni fun a)
lookupTerm :: forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name -> S name uni fun a -> Maybe (InlineTerm name uni fun a)
lookupTerm name
n S name uni fun a
s = name
-> UniqueMap TermUnique (InlineTerm name uni fun a)
-> Maybe (InlineTerm name uni fun a)
forall name unique a.
HasUnique name unique =>
name -> UniqueMap unique a -> Maybe a
UMap.lookupName name
n (UniqueMap TermUnique (InlineTerm name uni fun a)
 -> Maybe (InlineTerm name uni fun a))
-> UniqueMap TermUnique (InlineTerm name uni fun a)
-> Maybe (InlineTerm name uni fun a)
forall a b. (a -> b) -> a -> b
$ S name uni fun a
s S name uni fun a
-> Getting
     (UniqueMap TermUnique (InlineTerm name uni fun a))
     (S name uni fun a)
     (UniqueMap TermUnique (InlineTerm name uni fun a))
-> UniqueMap TermUnique (InlineTerm name uni fun a)
forall s a. s -> Getting a s a -> a
^. (Subst name uni fun a
 -> Const
      (UniqueMap TermUnique (InlineTerm name uni fun a))
      (Subst name uni fun a))
-> S name uni fun a
-> Const
     (UniqueMap TermUnique (InlineTerm name uni fun a))
     (S name uni fun a)
forall name (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(Subst name uni fun a -> f (Subst name uni fun a))
-> S name uni fun a -> f (S name uni fun a)
subst ((Subst name uni fun a
  -> Const
       (UniqueMap TermUnique (InlineTerm name uni fun a))
       (Subst name uni fun a))
 -> S name uni fun a
 -> Const
      (UniqueMap TermUnique (InlineTerm name uni fun a))
      (S name uni fun a))
-> ((UniqueMap TermUnique (InlineTerm name uni fun a)
     -> Const
          (UniqueMap TermUnique (InlineTerm name uni fun a))
          (UniqueMap TermUnique (InlineTerm name uni fun a)))
    -> Subst name uni fun a
    -> Const
         (UniqueMap TermUnique (InlineTerm name uni fun a))
         (Subst name uni fun a))
-> Getting
     (UniqueMap TermUnique (InlineTerm name uni fun a))
     (S name uni fun a)
     (UniqueMap TermUnique (InlineTerm name uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermEnv name uni fun a
 -> Const
      (UniqueMap TermUnique (InlineTerm name uni fun a))
      (TermEnv name uni fun a))
-> Subst name uni fun a
-> Const
     (UniqueMap TermUnique (InlineTerm name uni fun a))
     (Subst name uni fun a)
forall name (uni :: * -> *) fun a name (uni :: * -> *) fun a
       (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (TermEnv name uni fun a) (f (TermEnv name uni fun a))
-> p (Subst name uni fun a) (f (Subst name uni fun a))
termEnv ((TermEnv name uni fun a
  -> Const
       (UniqueMap TermUnique (InlineTerm name uni fun a))
       (TermEnv name uni fun a))
 -> Subst name uni fun a
 -> Const
      (UniqueMap TermUnique (InlineTerm name uni fun a))
      (Subst name uni fun a))
-> ((UniqueMap TermUnique (InlineTerm name uni fun a)
     -> Const
          (UniqueMap TermUnique (InlineTerm name uni fun a))
          (UniqueMap TermUnique (InlineTerm name uni fun a)))
    -> TermEnv name uni fun a
    -> Const
         (UniqueMap TermUnique (InlineTerm name uni fun a))
         (TermEnv name uni fun a))
-> (UniqueMap TermUnique (InlineTerm name uni fun a)
    -> Const
         (UniqueMap TermUnique (InlineTerm name uni fun a))
         (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> Subst name uni fun a
-> Const
     (UniqueMap TermUnique (InlineTerm name uni fun a))
     (Subst name uni fun a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UniqueMap TermUnique (InlineTerm name uni fun a)
 -> Const
      (UniqueMap TermUnique (InlineTerm name uni fun a))
      (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> TermEnv name uni fun a
-> Const
     (UniqueMap TermUnique (InlineTerm name uni fun a))
     (TermEnv name uni fun a)
forall name (uni :: * -> *) fun a name (uni :: * -> *) fun a
       (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (UniqueMap TermUnique (InlineTerm name uni fun a))
  (f (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> p (TermEnv name uni fun a) (f (TermEnv name uni fun a))
unTermEnv

-- | Insert the unprocessed variable into the substitution.
extendTerm ::
  (HasUnique name TermUnique) =>
  -- | The name of the variable.
  name ->
  -- | The substitution range.
  InlineTerm name uni fun a ->
  -- | The substitution.
  S name uni fun a ->
  S name uni fun a
extendTerm :: forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name
-> InlineTerm name uni fun a
-> S name uni fun a
-> S name uni fun a
extendTerm name
n InlineTerm name uni fun a
clos S name uni fun a
s = S name uni fun a
s S name uni fun a
-> (S name uni fun a -> S name uni fun a) -> S name uni fun a
forall a b. a -> (a -> b) -> b
& (Subst name uni fun a -> Identity (Subst name uni fun a))
-> S name uni fun a -> Identity (S name uni fun a)
forall name (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(Subst name uni fun a -> f (Subst name uni fun a))
-> S name uni fun a -> f (S name uni fun a)
subst ((Subst name uni fun a -> Identity (Subst name uni fun a))
 -> S name uni fun a -> Identity (S name uni fun a))
-> ((UniqueMap TermUnique (InlineTerm name uni fun a)
     -> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
    -> Subst name uni fun a -> Identity (Subst name uni fun a))
-> (UniqueMap TermUnique (InlineTerm name uni fun a)
    -> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> S name uni fun a
-> Identity (S name uni fun a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermEnv name uni fun a -> Identity (TermEnv name uni fun a))
-> Subst name uni fun a -> Identity (Subst name uni fun a)
forall name (uni :: * -> *) fun a name (uni :: * -> *) fun a
       (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (TermEnv name uni fun a) (f (TermEnv name uni fun a))
-> p (Subst name uni fun a) (f (Subst name uni fun a))
termEnv ((TermEnv name uni fun a -> Identity (TermEnv name uni fun a))
 -> Subst name uni fun a -> Identity (Subst name uni fun a))
-> ((UniqueMap TermUnique (InlineTerm name uni fun a)
     -> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
    -> TermEnv name uni fun a -> Identity (TermEnv name uni fun a))
-> (UniqueMap TermUnique (InlineTerm name uni fun a)
    -> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> Subst name uni fun a
-> Identity (Subst name uni fun a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UniqueMap TermUnique (InlineTerm name uni fun a)
 -> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> TermEnv name uni fun a -> Identity (TermEnv name uni fun a)
forall name (uni :: * -> *) fun a name (uni :: * -> *) fun a
       (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (UniqueMap TermUnique (InlineTerm name uni fun a))
  (f (UniqueMap TermUnique (InlineTerm name uni fun a)))
-> p (TermEnv name uni fun a) (f (TermEnv name uni fun a))
unTermEnv ((UniqueMap TermUnique (InlineTerm name uni fun a)
  -> Identity (UniqueMap TermUnique (InlineTerm name uni fun a)))
 -> S name uni fun a -> Identity (S name uni fun a))
-> (UniqueMap TermUnique (InlineTerm name uni fun a)
    -> UniqueMap TermUnique (InlineTerm name uni fun a))
-> S name uni fun a
-> S name uni fun a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ name
-> InlineTerm name uni fun a
-> UniqueMap TermUnique (InlineTerm name uni fun a)
-> UniqueMap TermUnique (InlineTerm name uni fun a)
forall name unique a.
HasUnique name unique =>
name -> a -> UniqueMap unique a -> UniqueMap unique a
UMap.insertByName name
n InlineTerm name uni fun a
clos

lookupVarInfo ::
  (HasUnique name TermUnique) =>
  name ->
  S name uni fun a ->
  Maybe (VarInfo name uni fun a)
lookupVarInfo :: forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name -> S name uni fun a -> Maybe (VarInfo name uni fun a)
lookupVarInfo name
n S name uni fun a
s = name
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> Maybe (VarInfo name uni fun a)
forall name unique a.
HasUnique name unique =>
name -> UniqueMap unique a -> Maybe a
UMap.lookupName name
n (UniqueMap TermUnique (VarInfo name uni fun a)
 -> Maybe (VarInfo name uni fun a))
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> Maybe (VarInfo name uni fun a)
forall a b. (a -> b) -> a -> b
$ S name uni fun a
s S name uni fun a
-> Getting
     (UniqueMap TermUnique (VarInfo name uni fun a))
     (S name uni fun a)
     (UniqueMap TermUnique (VarInfo name uni fun a))
-> UniqueMap TermUnique (VarInfo name uni fun a)
forall s a. s -> Getting a s a -> a
^. Getting
  (UniqueMap TermUnique (VarInfo name uni fun a))
  (S name uni fun a)
  (UniqueMap TermUnique (VarInfo name uni fun a))
forall name (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(UniqueMap TermUnique (VarInfo name uni fun a)
 -> f (UniqueMap TermUnique (VarInfo name uni fun a)))
-> S name uni fun a -> f (S name uni fun a)
vars

extendVarInfo ::
  (HasUnique name TermUnique) =>
  name ->
  VarInfo name uni fun a ->
  S name uni fun a ->
  S name uni fun a
extendVarInfo :: forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name
-> VarInfo name uni fun a -> S name uni fun a -> S name uni fun a
extendVarInfo name
n VarInfo name uni fun a
info S name uni fun a
s = S name uni fun a
s S name uni fun a
-> (S name uni fun a -> S name uni fun a) -> S name uni fun a
forall a b. a -> (a -> b) -> b
& (UniqueMap TermUnique (VarInfo name uni fun a)
 -> Identity (UniqueMap TermUnique (VarInfo name uni fun a)))
-> S name uni fun a -> Identity (S name uni fun a)
forall name (uni :: * -> *) fun a (f :: * -> *).
Functor f =>
(UniqueMap TermUnique (VarInfo name uni fun a)
 -> f (UniqueMap TermUnique (VarInfo name uni fun a)))
-> S name uni fun a -> f (S name uni fun a)
vars ((UniqueMap TermUnique (VarInfo name uni fun a)
  -> Identity (UniqueMap TermUnique (VarInfo name uni fun a)))
 -> S name uni fun a -> Identity (S name uni fun a))
-> (UniqueMap TermUnique (VarInfo name uni fun a)
    -> UniqueMap TermUnique (VarInfo name uni fun a))
-> S name uni fun a
-> S name uni fun a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ name
-> VarInfo name uni fun a
-> UniqueMap TermUnique (VarInfo name uni fun a)
-> UniqueMap TermUnique (VarInfo name uni fun a)
forall name unique a.
HasUnique name unique =>
name -> a -> UniqueMap unique a -> UniqueMap unique a
UMap.insertByName name
n VarInfo name uni fun a
info

{- | Inline simple bindings. Relies on global uniqueness, and preserves it.
See Note [Inlining and global uniqueness]
-}
inline ::
  forall name uni fun m a.
  (ExternalConstraints name uni fun m) =>
  -- | inline constants
  Bool ->
  InlineHints name a ->
  PLC.BuiltinSemanticsVariant fun ->
  Term name uni fun a ->
  m (Term name uni fun a)
inline :: forall name (uni :: * -> *) fun (m :: * -> *) a.
ExternalConstraints name uni fun m =>
Bool
-> InlineHints name a
-> BuiltinSemanticsVariant fun
-> Term name uni fun a
-> m (Term name uni fun a)
inline Bool
inlineConstants InlineHints name a
hints BuiltinSemanticsVariant fun
builtinSemanticsVariant Term name uni fun a
t =
  Quote (Term name uni fun a) -> m (Term name uni fun a)
forall a. Quote a -> m a
forall (m :: * -> *) a. MonadQuote m => Quote a -> m a
liftQuote (Quote (Term name uni fun a) -> m (Term name uni fun a))
-> Quote (Term name uni fun a) -> m (Term name uni fun a)
forall a b. (a -> b) -> a -> b
$ (StateT (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
 -> S name uni fun a -> Quote (Term name uni fun a))
-> S name uni fun a
-> StateT
     (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
-> Quote (Term name uni fun a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
-> S name uni fun a -> Quote (Term name uni fun a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT S name uni fun a
forall a. Monoid a => a
mempty (StateT (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
 -> Quote (Term name uni fun a))
-> StateT
     (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
-> Quote (Term name uni fun a)
forall a b. (a -> b) -> a -> b
$ ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  (Term name uni fun a)
-> InlineInfo name fun a
-> StateT
     (S name uni fun a) (QuoteT Identity) (Term name uni fun a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm Term name uni fun a
t) InlineInfo
    { _iiUsages :: Usages
_iiUsages = Term name uni fun a -> Usages
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
Term name uni fun a -> Usages
Usages.termUsages Term name uni fun a
t
    , _iiHints :: InlineHints name a
_iiHints  = InlineHints name a
hints
    , _iiBuiltinSemanticsVariant :: BuiltinSemanticsVariant fun
_iiBuiltinSemanticsVariant = BuiltinSemanticsVariant fun
builtinSemanticsVariant
    , _iiInlineConstants :: Bool
_iiInlineConstants = Bool
inlineConstants
    }

-- See Note [Differences from PIR inliner] 3

{- | Extract the list of applications from a term, a bit like a "multi-beta" reduction.

Some examples will help:
[(\x . t) a] -> Just ([(x, a)], t)

[[[(\x . (\y . (\z . t))) a] b] c] -> Just ([(x, a), (y, b), (z, c)]) t)

[[(\x . t) a] b] -> Nothing
-}
extractApps :: Term name uni fun a -> Maybe ([UTermDef name uni fun a], Term name uni fun a)
extractApps :: forall name (uni :: * -> *) fun a.
Term name uni fun a
-> Maybe ([UTermDef name uni fun a], Term name uni fun a)
extractApps = [Term name uni fun a]
-> Term name uni fun a
-> Maybe
     ([Def (UVarDecl name a) (Term name uni fun a)],
      Term name uni fun a)
forall {name} {uni :: * -> *} {fun} {ann}.
[Term name uni fun ann]
-> Term name uni fun ann
-> Maybe
     ([Def (UVarDecl name ann) (Term name uni fun ann)],
      Term name uni fun ann)
go []
  where
    go :: [Term name uni fun ann]
-> Term name uni fun ann
-> Maybe
     ([Def (UVarDecl name ann) (Term name uni fun ann)],
      Term name uni fun ann)
go [Term name uni fun ann]
argStack (Apply ann
_ Term name uni fun ann
f Term name uni fun ann
arg) = [Term name uni fun ann]
-> Term name uni fun ann
-> Maybe
     ([Def (UVarDecl name ann) (Term name uni fun ann)],
      Term name uni fun ann)
go (Term name uni fun ann
arg Term name uni fun ann
-> [Term name uni fun ann] -> [Term name uni fun ann]
forall a. a -> [a] -> [a]
: [Term name uni fun ann]
argStack) Term name uni fun ann
f
    go [Term name uni fun ann]
argStack Term name uni fun ann
t               = [Term name uni fun ann]
-> [Def (UVarDecl name ann) (Term name uni fun ann)]
-> Term name uni fun ann
-> Maybe
     ([Def (UVarDecl name ann) (Term name uni fun ann)],
      Term name uni fun ann)
forall {val} {name} {ann} {uni :: * -> *} {fun}.
[val]
-> [Def (UVarDecl name ann) val]
-> Term name uni fun ann
-> Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
matchArgs [Term name uni fun ann]
argStack [] Term name uni fun ann
t
    matchArgs :: [val]
-> [Def (UVarDecl name ann) val]
-> Term name uni fun ann
-> Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
matchArgs (val
arg : [val]
rest) [Def (UVarDecl name ann) val]
acc (LamAbs ann
a name
n Term name uni fun ann
body) =
      [val]
-> [Def (UVarDecl name ann) val]
-> Term name uni fun ann
-> Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
matchArgs [val]
rest (UVarDecl name ann -> val -> Def (UVarDecl name ann) val
forall var val. var -> val -> Def var val
Def (ann -> name -> UVarDecl name ann
forall name ann. ann -> name -> UVarDecl name ann
UVarDecl ann
a name
n) val
arg Def (UVarDecl name ann) val
-> [Def (UVarDecl name ann) val] -> [Def (UVarDecl name ann) val]
forall a. a -> [a] -> [a]
: [Def (UVarDecl name ann) val]
acc) Term name uni fun ann
body
    matchArgs [] [Def (UVarDecl name ann) val]
acc Term name uni fun ann
t =
      if [Def (UVarDecl name ann) val] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Def (UVarDecl name ann) val]
acc then Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
forall a. Maybe a
Nothing else ([Def (UVarDecl name ann) val], Term name uni fun ann)
-> Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
forall a. a -> Maybe a
Just ([Def (UVarDecl name ann) val] -> [Def (UVarDecl name ann) val]
forall a. [a] -> [a]
reverse [Def (UVarDecl name ann) val]
acc, Term name uni fun ann
t)
    matchArgs (val
_ : [val]
_) [Def (UVarDecl name ann) val]
_ Term name uni fun ann
_ = Maybe ([Def (UVarDecl name ann) val], Term name uni fun ann)
forall a. Maybe a
Nothing

-- | The inverse of 'extractApps'.
restoreApps :: [UTermDef name uni fun a] -> Term name uni fun a -> Term name uni fun a
restoreApps :: forall name (uni :: * -> *) fun a.
[UTermDef name uni fun a]
-> Term name uni fun a -> Term name uni fun a
restoreApps [UTermDef name uni fun a]
defs Term name uni fun a
t = [Term name uni fun a]
-> Term name uni fun a
-> [UTermDef name uni fun a]
-> Term name uni fun a
forall {name} {uni :: * -> *} {fun} {ann}.
[Term name uni fun ann]
-> Term name uni fun ann
-> [Def (UVarDecl name ann) (Term name uni fun ann)]
-> Term name uni fun ann
makeLams [] Term name uni fun a
t ([UTermDef name uni fun a] -> [UTermDef name uni fun a]
forall a. [a] -> [a]
reverse [UTermDef name uni fun a]
defs)
  where
    makeLams :: [Term name uni fun ann]
-> Term name uni fun ann
-> [Def (UVarDecl name ann) (Term name uni fun ann)]
-> Term name uni fun ann
makeLams [Term name uni fun ann]
args Term name uni fun ann
acc (Def (UVarDecl ann
a name
n) Term name uni fun ann
rhs : [Def (UVarDecl name ann) (Term name uni fun ann)]
rest) = [Term name uni fun ann]
-> Term name uni fun ann
-> [Def (UVarDecl name ann) (Term name uni fun ann)]
-> Term name uni fun ann
makeLams (Term name uni fun ann
rhs Term name uni fun ann
-> [Term name uni fun ann] -> [Term name uni fun ann]
forall a. a -> [a] -> [a]
: [Term name uni fun ann]
args) (ann -> name -> Term name uni fun ann -> Term name uni fun ann
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
LamAbs ann
a name
n Term name uni fun ann
acc) [Def (UVarDecl name ann) (Term name uni fun ann)]
rest
    makeLams [Term name uni fun ann]
args Term name uni fun ann
acc []                              = [Term name uni fun ann]
-> Term name uni fun ann -> Term name uni fun ann
forall {name} {uni :: * -> *} {fun} {ann}.
[Term name uni fun ann]
-> Term name uni fun ann -> Term name uni fun ann
makeApps [Term name uni fun ann]
args Term name uni fun ann
acc
    -- This isn't the best annotation, but it will do
    makeApps :: [Term name uni fun ann]
-> Term name uni fun ann -> Term name uni fun ann
makeApps (Term name uni fun ann
arg : [Term name uni fun ann]
args) Term name uni fun ann
acc = [Term name uni fun ann]
-> Term name uni fun ann -> Term name uni fun ann
makeApps [Term name uni fun ann]
args (ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply (Term name uni fun ann -> ann
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> ann
termAnn Term name uni fun ann
acc) Term name uni fun ann
acc Term name uni fun ann
arg)
    makeApps [] Term name uni fun ann
acc           = Term name uni fun ann
acc

-- | Run the inliner on a `UntypedPlutusCore.Core.Type.Term`.
processTerm ::
  forall name uni fun a.
  (InliningConstraints name uni fun) =>
  Term name uni fun a ->
  InlineM name uni fun a (Term name uni fun a)
processTerm :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm = Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
handleTerm
  where
    handleTerm :: Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
    handleTerm :: Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
handleTerm = \case
      v :: Term name uni fun a
v@(Var a
_ name
n) -> Term name uni fun a
-> Maybe (Term name uni fun a) -> Term name uni fun a
forall a. a -> Maybe a -> a
fromMaybe Term name uni fun a
v (Maybe (Term name uni fun a) -> Term name uni fun a)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe (Term name uni fun a))
-> InlineM name uni fun a (Term name uni fun a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> name
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe (Term name uni fun a))
substName name
n
      -- See Note [Differences from PIR inliner] 3
      (Term name uni fun a
-> Maybe ([UTermDef name uni fun a], Term name uni fun a)
forall name (uni :: * -> *) fun a.
Term name uni fun a
-> Maybe ([UTermDef name uni fun a], Term name uni fun a)
extractApps -> Just ([UTermDef name uni fun a]
bs, Term name uni fun a
t)) -> do
        [UTermDef name uni fun a]
bs' <- (UTermDef name uni fun a
 -> ReaderT
      (InlineInfo name fun a)
      (StateT (S name uni fun a) (QuoteT Identity))
      (Maybe (UTermDef name uni fun a)))
-> [UTermDef name uni fun a]
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     [UTermDef name uni fun a]
forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f (Maybe b)) -> [a] -> f [b]
wither (Term name uni fun a
-> UTermDef name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe (UTermDef name uni fun a))
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a
-> UTermDef name uni fun a
-> InlineM name uni fun a (Maybe (UTermDef name uni fun a))
processSingleBinding Term name uni fun a
t) [UTermDef name uni fun a]
bs
        Term name uni fun a
t' <- Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm Term name uni fun a
t
        Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term name uni fun a
 -> InlineM name uni fun a (Term name uni fun a))
-> Term name uni fun a
-> InlineM name uni fun a (Term name uni fun a)
forall a b. (a -> b) -> a -> b
$ [UTermDef name uni fun a]
-> Term name uni fun a -> Term name uni fun a
forall name (uni :: * -> *) fun a.
[UTermDef name uni fun a]
-> Term name uni fun a -> Term name uni fun a
restoreApps [UTermDef name uni fun a]
bs' Term name uni fun a
t'
      Term name uni fun a
t -> Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
inlineSaturatedApp (Term name uni fun a
 -> InlineM name uni fun a (Term name uni fun a))
-> InlineM name uni fun a (Term name uni fun a)
-> InlineM name uni fun a (Term name uni fun a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LensLike
  (WrappedMonad
     (ReaderT
        (InlineInfo name fun a)
        (StateT (S name uni fun a) (QuoteT Identity))))
  (Term name uni fun a)
  (Term name uni fun a)
  (Term name uni fun a)
  (Term name uni fun a)
-> Term name uni fun a
-> (Term name uni fun a
    -> InlineM name uni fun a (Term name uni fun a))
-> InlineM name uni fun a (Term name uni fun a)
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> s -> (a -> m b) -> m t
forMOf LensLike
  (WrappedMonad
     (ReaderT
        (InlineInfo name fun a)
        (StateT (S name uni fun a) (QuoteT Identity))))
  (Term name uni fun a)
  (Term name uni fun a)
  (Term name uni fun a)
  (Term name uni fun a)
forall name (uni :: * -> *) fun ann (f :: * -> *).
Applicative f =>
(Term name uni fun ann -> f (Term name uni fun ann))
-> Term name uni fun ann -> f (Term name uni fun ann)
termSubterms Term name uni fun a
t Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm

    -- See Note [Renaming strategy]
    substName :: name -> InlineM name uni fun a (Maybe (Term name uni fun a))
    substName :: name
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe (Term name uni fun a))
substName name
name = (S name uni fun a -> Maybe (InlineTerm name uni fun a))
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe (InlineTerm name uni fun a))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (name -> S name uni fun a -> Maybe (InlineTerm name uni fun a)
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name -> S name uni fun a -> Maybe (InlineTerm name uni fun a)
lookupTerm name
name) ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  (Maybe (InlineTerm name uni fun a))
-> (Maybe (InlineTerm name uni fun a)
    -> ReaderT
         (InlineInfo name fun a)
         (StateT (S name uni fun a) (QuoteT Identity))
         (Maybe (Term name uni fun a)))
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe (Term name uni fun a))
forall a b.
ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  a
-> (a
    -> ReaderT
         (InlineInfo name fun a)
         (StateT (S name uni fun a) (QuoteT Identity))
         b)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (InlineTerm name uni fun a
 -> InlineM name uni fun a (Term name uni fun a))
-> Maybe (InlineTerm name uni fun a)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe (Term name uni fun a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse InlineTerm name uni fun a
-> InlineM name uni fun a (Term name uni fun a)
renameTerm
    -- See Note [Inlining approach and 'Secrets of the GHC Inliner']
    renameTerm :: InlineTerm name uni fun a -> InlineM name uni fun a (Term name uni fun a)
    renameTerm :: InlineTerm name uni fun a
-> InlineM name uni fun a (Term name uni fun a)
renameTerm = \case
      -- Already processed term, just rename and put it in, don't do any
      -- further optimization here.
      Done Dupable (Term name uni fun a)
t -> Dupable (Term name uni fun a)
-> InlineM name uni fun a (Term name uni fun a)
forall (m :: * -> *) a.
(MonadQuote m, Rename a) =>
Dupable a -> m a
liftDupable Dupable (Term name uni fun a)
t

processSingleBinding ::
  (InliningConstraints name uni fun) =>
  Term name uni fun a ->
  UTermDef name uni fun a ->
  InlineM name uni fun a (Maybe (UTermDef name uni fun a))
processSingleBinding :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a
-> UTermDef name uni fun a
-> InlineM name uni fun a (Maybe (UTermDef name uni fun a))
processSingleBinding Term name uni fun a
body (Def vd :: UVarDecl name a
vd@(UVarDecl a
a name
n) Term name uni fun a
rhs0) = do
  Term name uni fun a
-> a
-> name
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a
-> a
-> name
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
maybeAddSubst Term name uni fun a
body a
a name
n Term name uni fun a
rhs0 InlineM name uni fun a (Maybe (Term name uni fun a))
-> (Maybe (Term name uni fun a)
    -> InlineM
         name
         uni
         fun
         a
         (Maybe (Def (UVarDecl name a) (Term name uni fun a))))
-> InlineM
     name
     uni
     fun
     a
     (Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall a b.
ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  a
-> (a
    -> ReaderT
         (InlineInfo name fun a)
         (StateT (S name uni fun a) (QuoteT Identity))
         b)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Term name uni fun a
rhs -> do
      let ([name]
binders, Term name uni fun a
rhsBody) = Term name uni fun a -> ([name], Term name uni fun a)
forall name (uni :: * -> *) fun a.
Term name uni fun a -> ([name], Term name uni fun a)
UPLC.splitParams Term name uni fun a
rhs
      (S name uni fun a -> S name uni fun a)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((S name uni fun a -> S name uni fun a)
 -> ReaderT
      (InlineInfo name fun a)
      (StateT (S name uni fun a) (QuoteT Identity))
      ())
-> (VarInfo name uni fun a -> S name uni fun a -> S name uni fun a)
-> VarInfo name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. name
-> VarInfo name uni fun a -> S name uni fun a -> S name uni fun a
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name
-> VarInfo name uni fun a -> S name uni fun a -> S name uni fun a
extendVarInfo name
n (VarInfo name uni fun a
 -> ReaderT
      (InlineInfo name fun a)
      (StateT (S name uni fun a) (QuoteT Identity))
      ())
-> VarInfo name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     ()
forall a b. (a -> b) -> a -> b
$
        VarInfo
          { _varBinders :: [name]
_varBinders = [name]
binders
          , _varRhs :: Term name uni fun a
_varRhs = Term name uni fun a
rhs
          , _varRhsBody :: InlineTerm name uni fun a
_varRhsBody = Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall name (uni :: * -> *) fun a.
Dupable (Term name uni fun a) -> InlineTerm name uni fun a
Done (Term name uni fun a -> Dupable (Term name uni fun a)
forall a. a -> Dupable a
dupable Term name uni fun a
rhsBody)
          }
      Maybe (Def (UVarDecl name a) (Term name uni fun a))
-> InlineM
     name
     uni
     fun
     a
     (Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Def (UVarDecl name a) (Term name uni fun a))
 -> InlineM
      name
      uni
      fun
      a
      (Maybe (Def (UVarDecl name a) (Term name uni fun a))))
-> (Def (UVarDecl name a) (Term name uni fun a)
    -> Maybe (Def (UVarDecl name a) (Term name uni fun a)))
-> Def (UVarDecl name a) (Term name uni fun a)
-> InlineM
     name
     uni
     fun
     a
     (Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Def (UVarDecl name a) (Term name uni fun a)
-> Maybe (Def (UVarDecl name a) (Term name uni fun a))
forall a. a -> Maybe a
Just (Def (UVarDecl name a) (Term name uni fun a)
 -> InlineM
      name
      uni
      fun
      a
      (Maybe (Def (UVarDecl name a) (Term name uni fun a))))
-> Def (UVarDecl name a) (Term name uni fun a)
-> InlineM
     name
     uni
     fun
     a
     (Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall a b. (a -> b) -> a -> b
$ UVarDecl name a
-> Term name uni fun a
-> Def (UVarDecl name a) (Term name uni fun a)
forall var val. var -> val -> Def var val
Def UVarDecl name a
vd Term name uni fun a
rhs
    Maybe (Term name uni fun a)
Nothing -> Maybe (Def (UVarDecl name a) (Term name uni fun a))
-> InlineM
     name
     uni
     fun
     a
     (Maybe (Def (UVarDecl name a) (Term name uni fun a)))
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Def (UVarDecl name a) (Term name uni fun a))
forall a. Maybe a
Nothing

{- | Check against the heuristics we have for inlining and either inline the term binding or not.
The arguments to this function are the fields of the `TermBinding` being processed.
Nothing means that we are inlining the term:
  * we have extended the substitution, and
  * we are removing the binding (hence we return Nothing).
-}
maybeAddSubst ::
  forall name uni fun a.
  (InliningConstraints name uni fun) =>
  Term name uni fun a ->
  a ->
  name ->
  Term name uni fun a ->
  InlineM name uni fun a (Maybe (Term name uni fun a))
maybeAddSubst :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a
-> a
-> name
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
maybeAddSubst Term name uni fun a
body a
a name
n Term name uni fun a
rhs0 = do
  Term name uni fun a
rhs <- Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
processTerm Term name uni fun a
rhs0

  -- Check whether we've been told specifically to inline this
  InlineHints name a
hints <- Getting
  (InlineHints name a) (InlineInfo name fun a) (InlineHints name a)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (InlineHints name a)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (InlineHints name a) (InlineInfo name fun a) (InlineHints name a)
forall name fun a name a (f :: * -> *).
Functor f =>
(InlineHints name a -> f (InlineHints name a))
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiHints
  let hinted :: Bool
hinted = InlineHints name a -> a -> name -> Bool
forall name a. InlineHints name a -> a -> name -> Bool
shouldInline InlineHints name a
hints a
a name
n

  if Bool
hinted -- if we've been told specifically, then do it right away
    then InlineTerm name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall b.
InlineTerm name uni fun a -> InlineM name uni fun a (Maybe b)
extendAndDrop (Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall name (uni :: * -> *) fun a.
Dupable (Term name uni fun a) -> InlineTerm name uni fun a
Done (Dupable (Term name uni fun a) -> InlineTerm name uni fun a)
-> Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Dupable (Term name uni fun a)
forall a. a -> Dupable a
dupable Term name uni fun a
rhs)
    else
      ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  Bool
-> InlineM name uni fun a (Maybe (Term name uni fun a))
-> InlineM name uni fun a (Maybe (Term name uni fun a))
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM
        (name
-> Term name uni fun a
-> Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     Bool
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name
-> Term name uni fun a
-> Term name uni fun a
-> InlineM name uni fun a Bool
shouldUnconditionallyInline name
n Term name uni fun a
rhs Term name uni fun a
body)
        (InlineTerm name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall b.
InlineTerm name uni fun a -> InlineM name uni fun a (Maybe b)
extendAndDrop (Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall name (uni :: * -> *) fun a.
Dupable (Term name uni fun a) -> InlineTerm name uni fun a
Done (Dupable (Term name uni fun a) -> InlineTerm name uni fun a)
-> Dupable (Term name uni fun a) -> InlineTerm name uni fun a
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Dupable (Term name uni fun a)
forall a. a -> Dupable a
dupable Term name uni fun a
rhs))
        (Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Term name uni fun a)
 -> InlineM name uni fun a (Maybe (Term name uni fun a)))
-> Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Maybe (Term name uni fun a)
forall a. a -> Maybe a
Just Term name uni fun a
rhs)
  where
    extendAndDrop ::
      forall b.
      InlineTerm name uni fun a ->
      InlineM name uni fun a (Maybe b)
    extendAndDrop :: forall b.
InlineTerm name uni fun a -> InlineM name uni fun a (Maybe b)
extendAndDrop InlineTerm name uni fun a
t = (S name uni fun a -> S name uni fun a)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (name
-> InlineTerm name uni fun a
-> S name uni fun a
-> S name uni fun a
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name
-> InlineTerm name uni fun a
-> S name uni fun a
-> S name uni fun a
extendTerm name
n InlineTerm name uni fun a
t) ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  ()
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe b)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe b)
forall a b.
ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     b
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe b
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe b)
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing

shouldUnconditionallyInline ::
  (InliningConstraints name uni fun) =>
  name ->
  Term name uni fun a ->
  Term name uni fun a ->
  InlineM name uni fun a Bool
shouldUnconditionallyInline :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name
-> Term name uni fun a
-> Term name uni fun a
-> InlineM name uni fun a Bool
shouldUnconditionallyInline name
n Term name uni fun a
rhs Term name uni fun a
body = do
  Bool
isTermPure <- Term name uni fun a -> InlineM name uni fun a Bool
forall (uni :: * -> *) fun name a.
ToBuiltinMeaning uni fun =>
Term name uni fun a -> InlineM name uni fun a Bool
checkPurity Term name uni fun a
rhs
  Bool
inlineConstants <- Getting Bool (InlineInfo name fun a) Bool
-> InlineM name uni fun a Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool (InlineInfo name fun a) Bool
forall name fun a (f :: * -> *).
Functor f =>
(Bool -> f Bool)
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiInlineConstants
  Bool -> InlineM name uni fun a Bool
preUnconditional Bool
isTermPure InlineM name uni fun a Bool
-> InlineM name uni fun a Bool -> InlineM name uni fun a Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
||^ Bool -> Bool -> InlineM name uni fun a Bool
postUnconditional Bool
inlineConstants Bool
isTermPure
  where
    -- similar to the paper, preUnconditional inlining checks that the binder is 'OnceSafe'.
    -- I.e., it's used at most once AND it neither duplicate code or work.
    -- While we don't check for lambda etc like in the paper, `effectSafe` ensures that it
    -- isn't doing any substantial work.
    -- We actually also inline 'Dead' binders (i.e., remove dead code) here.
    preUnconditional :: Bool -> InlineM name uni fun a Bool
preUnconditional Bool
isTermPure = name -> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name -> InlineM name uni fun a Bool
nameUsedAtMostOnce name
n InlineM name uni fun a Bool
-> InlineM name uni fun a Bool -> InlineM name uni fun a Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Term name uni fun a -> name -> Bool -> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> name -> Bool -> InlineM name uni fun a Bool
effectSafe Term name uni fun a
body name
n Bool
isTermPure
    -- See Note [Inlining approach and 'Secrets of the GHC Inliner'] and [Inlining and
    -- purity]. This is the case where we don't know that the number of occurrences is
    -- exactly one, so there's no point checking if the term is immediately evaluated.
    postUnconditional :: Bool -> Bool -> InlineM name uni fun a Bool
postUnconditional Bool
inlineConstants Bool
isTermPure =
      Bool -> InlineM name uni fun a Bool
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isTermPure InlineM name uni fun a Bool
-> InlineM name uni fun a Bool -> InlineM name uni fun a Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Bool -> Term name uni fun a -> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> InlineM name uni fun a Bool
acceptable Bool
inlineConstants Term name uni fun a
rhs

-- | Check if term is pure. See Note [Inlining and purity]
checkPurity :: PLC.ToBuiltinMeaning uni fun => Term name uni fun a -> InlineM name uni fun a Bool
checkPurity :: forall (uni :: * -> *) fun name a.
ToBuiltinMeaning uni fun =>
Term name uni fun a -> InlineM name uni fun a Bool
checkPurity Term name uni fun a
t = do
  BuiltinSemanticsVariant fun
builtinSemanticsVariant <- Getting
  (BuiltinSemanticsVariant fun)
  (InlineInfo name fun a)
  (BuiltinSemanticsVariant fun)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (BuiltinSemanticsVariant fun)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (BuiltinSemanticsVariant fun)
  (InlineInfo name fun a)
  (BuiltinSemanticsVariant fun)
forall name fun a fun (f :: * -> *).
Functor f =>
(BuiltinSemanticsVariant fun -> f (BuiltinSemanticsVariant fun))
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiBuiltinSemanticsVariant
  Bool -> InlineM name uni fun a Bool
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> InlineM name uni fun a Bool)
-> Bool -> InlineM name uni fun a Bool
forall a b. (a -> b) -> a -> b
$ BuiltinSemanticsVariant fun -> Term name uni fun a -> Bool
forall (uni :: * -> *) fun name a.
ToBuiltinMeaning uni fun =>
BuiltinSemanticsVariant fun -> Term name uni fun a -> Bool
isPure BuiltinSemanticsVariant fun
builtinSemanticsVariant Term name uni fun a
t

nameUsedAtMostOnce ::
  forall name uni fun a.
  (InliningConstraints name uni fun) =>
  name ->
  InlineM name uni fun a Bool
nameUsedAtMostOnce :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name -> InlineM name uni fun a Bool
nameUsedAtMostOnce name
n = do
  Usages
usgs <- Getting Usages (InlineInfo name fun a) Usages
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     Usages
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Usages (InlineInfo name fun a) Usages
forall name fun a (f :: * -> *).
Functor f =>
(Usages -> f Usages)
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiUsages
  -- 'inlining' terms used 0 times is a cheap way to remove dead code while we're here
  Bool -> InlineM name uni fun a Bool
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> InlineM name uni fun a Bool)
-> Bool -> InlineM name uni fun a Bool
forall a b. (a -> b) -> a -> b
$ name -> Usages -> Int
forall n unique. HasUnique n unique => n -> Usages -> Int
Usages.getUsageCount name
n Usages
usgs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1

isFirstVarBeforeEffects
    :: forall name uni fun ann. InliningConstraints name uni fun
    => name
    -> Term name uni fun ann
    -> InlineM name uni fun ann Bool
isFirstVarBeforeEffects :: forall name (uni :: * -> *) fun ann.
InliningConstraints name uni fun =>
name -> Term name uni fun ann -> InlineM name uni fun ann Bool
isFirstVarBeforeEffects name
n Term name uni fun ann
t = do
  BuiltinSemanticsVariant fun
builtinSemanticsVariant <- Getting
  (BuiltinSemanticsVariant fun)
  (InlineInfo name fun ann)
  (BuiltinSemanticsVariant fun)
-> ReaderT
     (InlineInfo name fun ann)
     (StateT (S name uni fun ann) (QuoteT Identity))
     (BuiltinSemanticsVariant fun)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (BuiltinSemanticsVariant fun)
  (InlineInfo name fun ann)
  (BuiltinSemanticsVariant fun)
forall name fun a fun (f :: * -> *).
Functor f =>
(BuiltinSemanticsVariant fun -> f (BuiltinSemanticsVariant fun))
-> InlineInfo name fun a -> f (InlineInfo name fun a)
iiBuiltinSemanticsVariant
  -- This can in the worst case traverse a lot of the term, which could lead to us
  -- doing ~quadratic work as we process the program. However in practice most terms
  -- have a relatively short evaluation order before we hit Unknown, so it's not too bad.
  Bool -> InlineM name uni fun ann Bool
forall a.
a
-> ReaderT
     (InlineInfo name fun ann)
     (StateT (S name uni fun ann) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> InlineM name uni fun ann Bool)
-> Bool -> InlineM name uni fun ann Bool
forall a b. (a -> b) -> a -> b
$ [EvalTerm name uni fun ann] -> Bool
go (EvalOrder name uni fun ann -> [EvalTerm name uni fun ann]
forall name (uni :: * -> *) fun a.
EvalOrder name uni fun a -> [EvalTerm name uni fun a]
unEvalOrder (BuiltinSemanticsVariant fun
-> Term name uni fun ann -> EvalOrder name uni fun ann
forall name (uni :: * -> *) fun a.
ToBuiltinMeaning uni fun =>
BuiltinSemanticsVariant fun
-> Term name uni fun a -> EvalOrder name uni fun a
termEvaluationOrder BuiltinSemanticsVariant fun
builtinSemanticsVariant Term name uni fun ann
t))
  where
    -- Found the variable we're looking for!
    go :: [EvalTerm name uni fun ann] -> Bool
go ((EvalTerm Purity
_ WorkFreedom
_ (Var ann
_ name
n')):[EvalTerm name uni fun ann]
_) | name
n name -> name -> Bool
forall a. Eq a => a -> a -> Bool
== name
n' = Bool
True
    -- Found a pure term, ignore it and continue
    go ((EvalTerm Purity
Pure WorkFreedom
_ Term name uni fun ann
_):[EvalTerm name uni fun ann]
rest) = [EvalTerm name uni fun ann] -> Bool
go [EvalTerm name uni fun ann]
rest
    -- Found a possibly impure term, our variable is definitely not first
    go ((EvalTerm Purity
MaybeImpure WorkFreedom
_ Term name uni fun ann
_):[EvalTerm name uni fun ann]
_) = Bool
False
    -- Don't know, be conservative
    go (EvalTerm name uni fun ann
Unknown:[EvalTerm name uni fun ann]
_) = Bool
False
    go [] = Bool
False

effectSafe ::
  forall name uni fun a.
  (InliningConstraints name uni fun) =>
  Term name uni fun a ->
  name ->
  -- | is it pure?
  Bool ->
  InlineM name uni fun a Bool
effectSafe :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> name -> Bool -> InlineM name uni fun a Bool
effectSafe Term name uni fun a
body name
n Bool
purity = do
  Bool
immediatelyEvaluated <- name -> Term name uni fun a -> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun ann.
InliningConstraints name uni fun =>
name -> Term name uni fun ann -> InlineM name uni fun ann Bool
isFirstVarBeforeEffects name
n Term name uni fun a
body
  Bool -> InlineM name uni fun a Bool
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> InlineM name uni fun a Bool)
-> Bool -> InlineM name uni fun a Bool
forall a b. (a -> b) -> a -> b
$ Bool
purity Bool -> Bool -> Bool
|| Bool
immediatelyEvaluated

{- | Should we inline? Should only inline things that won't duplicate work or code.
See Note [Inlining approach and 'Secrets of the GHC Inliner']
-}
acceptable ::
  -- | inline constants
  Bool ->
  Term name uni fun a ->
  InlineM name uni fun a Bool
acceptable :: forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> InlineM name uni fun a Bool
acceptable Bool
inlineConstants Term name uni fun a
t =
  -- See Note [Inlining criteria]
  Bool
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     Bool
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
 -> ReaderT
      (InlineInfo name fun a)
      (StateT (S name uni fun a) (QuoteT Identity))
      Bool)
-> Bool
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     Bool
forall a b. (a -> b) -> a -> b
$ Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a. Term name uni fun a -> Bool
costIsAcceptable Term name uni fun a
t Bool -> Bool -> Bool
&& Bool -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants Term name uni fun a
t

{- | Is the cost increase (in terms of evaluation work) of inlining a variable whose RHS is
the given term acceptable?
-}
costIsAcceptable :: Term name uni fun a -> Bool
costIsAcceptable :: forall name (uni :: * -> *) fun a. Term name uni fun a -> Bool
costIsAcceptable = \case
  Builtin{} -> Bool
True
  Var{} -> Bool
True
  Constant{} -> Bool
True
  Error{} -> Bool
True
  -- This will mean that we create closures at each use site instead of
  -- once, but that's a very low cost which we're okay rounding to 0.
  LamAbs{} -> Bool
True
  Apply{} -> Bool
False
  -- Inlining constructors of size 1 or 0 seems okay, but does result in doing
  -- the work for the elements at each use site.
  Constr a
_ Word64
_ [Term name uni fun a]
es -> case [Term name uni fun a]
es of
    []  -> Bool
True
    [Term name uni fun a
e] -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a. Term name uni fun a -> Bool
costIsAcceptable Term name uni fun a
e
    [Term name uni fun a]
_   -> Bool
False
  -- Inlining a case means redoing the match at each use site
  Case{} -> Bool
False
  Force{} -> Bool
False
  Delay{} -> Bool
True

{- | Is the size increase (in the AST) of inlining a variable whose RHS is
the given term acceptable?
-}
sizeIsAcceptable ::
  -- | inline constants
  Bool ->
  Term name uni fun a ->
  Bool
sizeIsAcceptable :: forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants = \case
  Builtin{} -> Bool
True
  Var{} -> Bool
True
  Error{} -> Bool
True
  -- See Note [Differences from PIR inliner] 4
  LamAbs{} -> Bool
False
  -- Inlining constructors of size 1 or 0 seems okay
  Constr a
_ Word64
_ [Term name uni fun a]
es -> case [Term name uni fun a]
es of
    []  -> Bool
True
    [Term name uni fun a
e] -> Bool -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants Term name uni fun a
e
    [Term name uni fun a]
_   -> Bool
False
  -- Cases are pretty big, due to the case branches
  Case{} -> Bool
False
  -- Inlining constants is deemed acceptable if the 'inlineConstants'
  -- flag is turned on, see Note [Inlining constants].
  Constant{} -> Bool
inlineConstants
  Apply{} -> Bool
False
  Force a
_ Term name uni fun a
t -> Bool -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants Term name uni fun a
t
  Delay a
_ Term name uni fun a
t -> Bool -> Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a.
Bool -> Term name uni fun a -> Bool
sizeIsAcceptable Bool
inlineConstants Term name uni fun a
t

-- | Fully apply and beta reduce.
fullyApplyAndBetaReduce ::
  forall name uni fun a.
  (InliningConstraints name uni fun) =>
  VarInfo name uni fun a ->
  [(a, Term name uni fun a)] ->
  InlineM name uni fun a (Maybe (Term name uni fun a))
fullyApplyAndBetaReduce :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
VarInfo name uni fun a
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
fullyApplyAndBetaReduce VarInfo name uni fun a
info [(a, Term name uni fun a)]
args0 = do
  Term name uni fun a
rhsBody <- Dupable (Term name uni fun a)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall (m :: * -> *) a.
(MonadQuote m, Rename a) =>
Dupable a -> m a
liftDupable (let Done Dupable (Term name uni fun a)
rhsBody = VarInfo name uni fun a
info VarInfo name uni fun a
-> Getting
     (InlineTerm name uni fun a)
     (VarInfo name uni fun a)
     (InlineTerm name uni fun a)
-> InlineTerm name uni fun a
forall s a. s -> Getting a s a -> a
^. Getting
  (InlineTerm name uni fun a)
  (VarInfo name uni fun a)
  (InlineTerm name uni fun a)
forall name (uni :: * -> *) fun ann (f :: * -> *).
Functor f =>
(InlineTerm name uni fun ann -> f (InlineTerm name uni fun ann))
-> VarInfo name uni fun ann -> f (VarInfo name uni fun ann)
varRhsBody in Dupable (Term name uni fun a)
rhsBody)
  let go ::
        Term name uni fun a ->
        [name] ->
        [(a, Term name uni fun a)] ->
        InlineM name uni fun a (Maybe (Term name uni fun a))
      go :: Term name uni fun a
-> [name]
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
go Term name uni fun a
acc [name]
bs [(a, Term name uni fun a)]
args = case ([name]
bs, [(a, Term name uni fun a)]
args) of
        ([], [(a, Term name uni fun a)]
_) -> Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Term name uni fun a)
 -> InlineM name uni fun a (Maybe (Term name uni fun a)))
-> (Term name uni fun a -> Maybe (Term name uni fun a))
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term name uni fun a -> Maybe (Term name uni fun a)
forall a. a -> Maybe a
Just (Term name uni fun a
 -> InlineM name uni fun a (Maybe (Term name uni fun a)))
-> Term name uni fun a
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a b. (a -> b) -> a -> b
$ Term name uni fun a
-> [(a, Term name uni fun a)] -> Term name uni fun a
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
mkIterApp Term name uni fun a
acc [(a, Term name uni fun a)]
args
        (name
param : [name]
params, (a
_ann, Term name uni fun a
arg) : [(a, Term name uni fun a)]
args') -> do
          Bool
safe <- name -> Term name uni fun a -> InlineM name uni fun a Bool
safeToBetaReduce name
param Term name uni fun a
arg
          if Bool
safe
            then do
              Term name uni fun a
acc' <-
                (name -> InlineM name uni fun a (Maybe (Term name uni fun a)))
-> Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall (m :: * -> *) name (uni :: * -> *) fun ann.
Monad m =>
(name -> m (Maybe (Term name uni fun ann)))
-> Term name uni fun ann -> m (Term name uni fun ann)
termSubstNamesM
                  (\name
n -> if name
n name -> name -> Bool
forall a. Eq a => a -> a -> Bool
== name
param then Term name uni fun a -> Maybe (Term name uni fun a)
forall a. a -> Maybe a
Just (Term name uni fun a -> Maybe (Term name uni fun a))
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall a (m :: * -> *). (Rename a, MonadQuote m) => a -> m a
forall (m :: * -> *).
MonadQuote m =>
Term name uni fun a -> m (Term name uni fun a)
PLC.rename Term name uni fun a
arg else Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Term name uni fun a)
forall a. Maybe a
Nothing)
                  Term name uni fun a
acc
              Term name uni fun a
-> [name]
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
go Term name uni fun a
acc' [name]
params [(a, Term name uni fun a)]
args'
            else Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Term name uni fun a)
forall a. Maybe a
Nothing
        ([name], [(a, Term name uni fun a)])
_ -> Maybe (Term name uni fun a)
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Term name uni fun a)
forall a. Maybe a
Nothing

      -- Is it safe to turn `(\a -> body) arg` into `body [a := arg]`?
      -- The criteria is the same as the criteria for unconditionally inlining `a`,
      -- since inlining is the same as beta reduction.
      safeToBetaReduce ::
        name ->
        Term name uni fun a ->
        InlineM name uni fun a Bool
      safeToBetaReduce :: name -> Term name uni fun a -> InlineM name uni fun a Bool
safeToBetaReduce name
a Term name uni fun a
arg = name
-> Term name uni fun a
-> Term name uni fun a
-> InlineM name uni fun a Bool
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
name
-> Term name uni fun a
-> Term name uni fun a
-> InlineM name uni fun a Bool
shouldUnconditionallyInline name
a Term name uni fun a
arg Term name uni fun a
rhsBody
  Term name uni fun a
-> [name]
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
go Term name uni fun a
rhsBody (VarInfo name uni fun a
info VarInfo name uni fun a
-> Getting [name] (VarInfo name uni fun a) [name] -> [name]
forall s a. s -> Getting a s a -> a
^. Getting [name] (VarInfo name uni fun a) [name]
forall name (uni :: * -> *) fun ann (f :: * -> *).
Functor f =>
([name] -> f [name])
-> VarInfo name uni fun ann -> f (VarInfo name uni fun ann)
varBinders) [(a, Term name uni fun a)]
args0

{- | This works in the same way as `PlutusIR.Transform.Inline.CallSiteInline.inlineSaturatedApp`.
See Note [Inlining and beta reduction of functions].
-}
inlineSaturatedApp ::
  forall name uni fun a.
  (InliningConstraints name uni fun) =>
  Term name uni fun a ->
  InlineM name uni fun a (Term name uni fun a)
inlineSaturatedApp :: forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
Term name uni fun a -> InlineM name uni fun a (Term name uni fun a)
inlineSaturatedApp Term name uni fun a
t
  | (Var a
_ann name
name, [(a, Term name uni fun a)]
args) <- Term name uni fun a
-> (Term name uni fun a, [(a, Term name uni fun a)])
forall name (uni :: * -> *) fun a.
Term name uni fun a
-> (Term name uni fun a, [(a, Term name uni fun a)])
UPLC.splitApplication Term name uni fun a
t =
      (S name uni fun a -> Maybe (VarInfo name uni fun a))
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Maybe (VarInfo name uni fun a))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (name -> S name uni fun a -> Maybe (VarInfo name uni fun a)
forall name (uni :: * -> *) fun a.
HasUnique name TermUnique =>
name -> S name uni fun a -> Maybe (VarInfo name uni fun a)
lookupVarInfo name
name) ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  (Maybe (VarInfo name uni fun a))
-> (Maybe (VarInfo name uni fun a)
    -> ReaderT
         (InlineInfo name fun a)
         (StateT (S name uni fun a) (QuoteT Identity))
         (Term name uni fun a))
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall a b.
ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  a
-> (a
    -> ReaderT
         (InlineInfo name fun a)
         (StateT (S name uni fun a) (QuoteT Identity))
         b)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (VarInfo name uni fun a)
Nothing -> Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term name uni fun a
t
        Just VarInfo name uni fun a
varInfo ->
          VarInfo name uni fun a
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
forall name (uni :: * -> *) fun a.
InliningConstraints name uni fun =>
VarInfo name uni fun a
-> [(a, Term name uni fun a)]
-> InlineM name uni fun a (Maybe (Term name uni fun a))
fullyApplyAndBetaReduce VarInfo name uni fun a
varInfo [(a, Term name uni fun a)]
args InlineM name uni fun a (Maybe (Term name uni fun a))
-> (Maybe (Term name uni fun a)
    -> ReaderT
         (InlineInfo name fun a)
         (StateT (S name uni fun a) (QuoteT Identity))
         (Term name uni fun a))
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall a b.
ReaderT
  (InlineInfo name fun a)
  (StateT (S name uni fun a) (QuoteT Identity))
  a
-> (a
    -> ReaderT
         (InlineInfo name fun a)
         (StateT (S name uni fun a) (QuoteT Identity))
         b)
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (Term name uni fun a)
Nothing -> Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term name uni fun a
t
            Just Term name uni fun a
fullyApplied -> do
              let
                -- Inline only if the size is no bigger than not inlining.
                sizeIsOk :: Bool
sizeIsOk = Term name uni fun a -> Size
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> Size
termSize Term name uni fun a
fullyApplied Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
<= Term name uni fun a -> Size
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> Size
termSize Term name uni fun a
t
                rhs :: Term name uni fun a
rhs = VarInfo name uni fun a
varInfo VarInfo name uni fun a
-> Getting
     (Term name uni fun a)
     (VarInfo name uni fun a)
     (Term name uni fun a)
-> Term name uni fun a
forall s a. s -> Getting a s a -> a
^. Getting
  (Term name uni fun a)
  (VarInfo name uni fun a)
  (Term name uni fun a)
forall name (uni :: * -> *) fun ann (f :: * -> *).
Functor f =>
(Term name uni fun ann -> f (Term name uni fun ann))
-> VarInfo name uni fun ann -> f (VarInfo name uni fun ann)
varRhs
                -- Cost is always OK if the RHS is a LamAbs, but may not be otherwise.
                costIsOk :: Bool
costIsOk = Term name uni fun a -> Bool
forall name (uni :: * -> *) fun a. Term name uni fun a -> Bool
costIsAcceptable Term name uni fun a
rhs
              -- The RHS is always pure if it is a LamAbs, but may not be otherwise.
              Bool
rhsPure <- Term name uni fun a -> InlineM name uni fun a Bool
forall (uni :: * -> *) fun name a.
ToBuiltinMeaning uni fun =>
Term name uni fun a -> InlineM name uni fun a Bool
checkPurity Term name uni fun a
rhs
              Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term name uni fun a
 -> ReaderT
      (InlineInfo name fun a)
      (StateT (S name uni fun a) (QuoteT Identity))
      (Term name uni fun a))
-> Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall a b. (a -> b) -> a -> b
$ if Bool
sizeIsOk Bool -> Bool -> Bool
&& Bool
costIsOk Bool -> Bool -> Bool
&& Bool
rhsPure then Term name uni fun a
fullyApplied else Term name uni fun a
t
  | Bool
otherwise = Term name uni fun a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     (Term name uni fun a)
forall a.
a
-> ReaderT
     (InlineInfo name fun a)
     (StateT (S name uni fun a) (QuoteT Identity))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term name uni fun a
t