-- editorconfig-checker-disable-file
{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE StrictData      #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies    #-}
{-# LANGUAGE TypeOperators   #-}

module PlutusCore.Evaluation.Machine.MachineParameters
where

import PlutusCore (UniOf)
import PlutusCore.Builtin

import Control.DeepSeq
import Control.Lens
import GHC.Exts (inline)
import GHC.Generics
import NoThunks.Class

{-| We need to account for the costs of evaluator steps and also built-in function
   evaluation.  The models for these have different structures and are used in
   different parts of the code, so inside the valuator we pass separate objects
   about most of the time .  It's convenient for clients of the evaluator to
   only have to worry about a single object, so the CostModel type bundles the
   two together.  We could conceivably have different evaluators with different
   internal costs, so we keep the machine costs abstract.  The model for Cek
   machine steps is in UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts.
-}
data CostModel machinecosts builtincosts =
    CostModel {
      forall machinecosts builtincosts.
CostModel machinecosts builtincosts -> machinecosts
_machineCostModel :: machinecosts
    , forall machinecosts builtincosts.
CostModel machinecosts builtincosts -> builtincosts
_builtinCostModel :: builtincosts
    } deriving stock (CostModel machinecosts builtincosts
-> CostModel machinecosts builtincosts -> Bool
(CostModel machinecosts builtincosts
 -> CostModel machinecosts builtincosts -> Bool)
-> (CostModel machinecosts builtincosts
    -> CostModel machinecosts builtincosts -> Bool)
-> Eq (CostModel machinecosts builtincosts)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall machinecosts builtincosts.
(Eq machinecosts, Eq builtincosts) =>
CostModel machinecosts builtincosts
-> CostModel machinecosts builtincosts -> Bool
$c== :: forall machinecosts builtincosts.
(Eq machinecosts, Eq builtincosts) =>
CostModel machinecosts builtincosts
-> CostModel machinecosts builtincosts -> Bool
== :: CostModel machinecosts builtincosts
-> CostModel machinecosts builtincosts -> Bool
$c/= :: forall machinecosts builtincosts.
(Eq machinecosts, Eq builtincosts) =>
CostModel machinecosts builtincosts
-> CostModel machinecosts builtincosts -> Bool
/= :: CostModel machinecosts builtincosts
-> CostModel machinecosts builtincosts -> Bool
Eq, Int -> CostModel machinecosts builtincosts -> ShowS
[CostModel machinecosts builtincosts] -> ShowS
CostModel machinecosts builtincosts -> String
(Int -> CostModel machinecosts builtincosts -> ShowS)
-> (CostModel machinecosts builtincosts -> String)
-> ([CostModel machinecosts builtincosts] -> ShowS)
-> Show (CostModel machinecosts builtincosts)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall machinecosts builtincosts.
(Show machinecosts, Show builtincosts) =>
Int -> CostModel machinecosts builtincosts -> ShowS
forall machinecosts builtincosts.
(Show machinecosts, Show builtincosts) =>
[CostModel machinecosts builtincosts] -> ShowS
forall machinecosts builtincosts.
(Show machinecosts, Show builtincosts) =>
CostModel machinecosts builtincosts -> String
$cshowsPrec :: forall machinecosts builtincosts.
(Show machinecosts, Show builtincosts) =>
Int -> CostModel machinecosts builtincosts -> ShowS
showsPrec :: Int -> CostModel machinecosts builtincosts -> ShowS
$cshow :: forall machinecosts builtincosts.
(Show machinecosts, Show builtincosts) =>
CostModel machinecosts builtincosts -> String
show :: CostModel machinecosts builtincosts -> String
$cshowList :: forall machinecosts builtincosts.
(Show machinecosts, Show builtincosts) =>
[CostModel machinecosts builtincosts] -> ShowS
showList :: [CostModel machinecosts builtincosts] -> ShowS
Show)
makeLenses ''CostModel

-- | The part of 'MachineParameters' that is individual for each semantics variant of 'DefaultFun'.
--
-- 'CaserBuiltin' isn't included, because it only explicitly depends on the protocol version and not
-- the language version (even though there's an implicit dependency on the language version: older
-- languages don't support 'Case' in general, but it's safe to ignore that, because support for
-- 'Case' is controlled by the AST version, which is a separate check during deserialisation).
data MachineVariantParameters machineCosts fun val =
    MachineVariantParameters {
      forall machineCosts fun val.
MachineVariantParameters machineCosts fun val -> machineCosts
machineCosts    :: machineCosts
    , forall machineCosts fun val.
MachineVariantParameters machineCosts fun val
-> BuiltinsRuntime fun val
builtinsRuntime :: BuiltinsRuntime fun val
    }
    deriving stock (forall x.
 MachineVariantParameters machineCosts fun val
 -> Rep (MachineVariantParameters machineCosts fun val) x)
-> (forall x.
    Rep (MachineVariantParameters machineCosts fun val) x
    -> MachineVariantParameters machineCosts fun val)
-> Generic (MachineVariantParameters machineCosts fun val)
forall x.
Rep (MachineVariantParameters machineCosts fun val) x
-> MachineVariantParameters machineCosts fun val
forall x.
MachineVariantParameters machineCosts fun val
-> Rep (MachineVariantParameters machineCosts fun val) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall machineCosts fun val x.
Rep (MachineVariantParameters machineCosts fun val) x
-> MachineVariantParameters machineCosts fun val
forall machineCosts fun val x.
MachineVariantParameters machineCosts fun val
-> Rep (MachineVariantParameters machineCosts fun val) x
$cfrom :: forall machineCosts fun val x.
MachineVariantParameters machineCosts fun val
-> Rep (MachineVariantParameters machineCosts fun val) x
from :: forall x.
MachineVariantParameters machineCosts fun val
-> Rep (MachineVariantParameters machineCosts fun val) x
$cto :: forall machineCosts fun val x.
Rep (MachineVariantParameters machineCosts fun val) x
-> MachineVariantParameters machineCosts fun val
to :: forall x.
Rep (MachineVariantParameters machineCosts fun val) x
-> MachineVariantParameters machineCosts fun val
Generic
    deriving anyclass (MachineVariantParameters machineCosts fun val -> ()
(MachineVariantParameters machineCosts fun val -> ())
-> NFData (MachineVariantParameters machineCosts fun val)
forall a. (a -> ()) -> NFData a
forall machineCosts fun val.
(NFData machineCosts, Bounded fun, Enum fun) =>
MachineVariantParameters machineCosts fun val -> ()
$crnf :: forall machineCosts fun val.
(NFData machineCosts, Bounded fun, Enum fun) =>
MachineVariantParameters machineCosts fun val -> ()
rnf :: MachineVariantParameters machineCosts fun val -> ()
NFData)

{-| At execution time we need a 'BuiltinsRuntime' object which includes both the cost model for
builtins and their denotations. This bundles one of those together with the cost model for evaluator
steps and a 'CaserBuiltin' specifying how casing on values of built-in types works.
The @val@ type will be 'CekValue' when we're using this with the CEK machine.
-}
data MachineParameters machineCosts fun val =
    MachineParameters {
      forall machineCosts fun val.
MachineParameters machineCosts fun val -> CaserBuiltin (UniOf val)
machineCaserBuiltin      :: CaserBuiltin (UniOf val)
    , forall machineCosts fun val.
MachineParameters machineCosts fun val
-> MachineVariantParameters machineCosts fun val
machineVariantParameters :: MachineVariantParameters machineCosts fun val
    }
    deriving stock (forall x.
 MachineParameters machineCosts fun val
 -> Rep (MachineParameters machineCosts fun val) x)
-> (forall x.
    Rep (MachineParameters machineCosts fun val) x
    -> MachineParameters machineCosts fun val)
-> Generic (MachineParameters machineCosts fun val)
forall x.
Rep (MachineParameters machineCosts fun val) x
-> MachineParameters machineCosts fun val
forall x.
MachineParameters machineCosts fun val
-> Rep (MachineParameters machineCosts fun val) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall machineCosts fun val x.
Rep (MachineParameters machineCosts fun val) x
-> MachineParameters machineCosts fun val
forall machineCosts fun val x.
MachineParameters machineCosts fun val
-> Rep (MachineParameters machineCosts fun val) x
$cfrom :: forall machineCosts fun val x.
MachineParameters machineCosts fun val
-> Rep (MachineParameters machineCosts fun val) x
from :: forall x.
MachineParameters machineCosts fun val
-> Rep (MachineParameters machineCosts fun val) x
$cto :: forall machineCosts fun val x.
Rep (MachineParameters machineCosts fun val) x
-> MachineParameters machineCosts fun val
to :: forall x.
Rep (MachineParameters machineCosts fun val) x
-> MachineParameters machineCosts fun val
Generic
    deriving anyclass (MachineParameters machineCosts fun val -> ()
(MachineParameters machineCosts fun val -> ())
-> NFData (MachineParameters machineCosts fun val)
forall a. (a -> ()) -> NFData a
forall machineCosts fun val.
(NFData machineCosts, Bounded fun, Enum fun) =>
MachineParameters machineCosts fun val -> ()
$crnf :: forall machineCosts fun val.
(NFData machineCosts, Bounded fun, Enum fun) =>
MachineParameters machineCosts fun val -> ()
rnf :: MachineParameters machineCosts fun val -> ()
NFData)

-- For some reason the generic instance gives incorrect nothunk errors,
-- see https://github.com/input-output-hk/nothunks/issues/24
instance (NoThunks machinecosts, Bounded fun, Enum fun) => NoThunks (MachineVariantParameters machinecosts fun val) where
  wNoThunks :: Context
-> MachineVariantParameters machinecosts fun val
-> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (MachineVariantParameters machinecosts
costs BuiltinsRuntime fun val
runtime) =
      [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [ Context -> machinecosts -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx machinecosts
costs, Context -> BuiltinsRuntime fun val -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx BuiltinsRuntime fun val
runtime ]

instance (NoThunks machinecosts, Bounded fun, Enum fun) => NoThunks (MachineParameters machinecosts fun val) where
  wNoThunks :: Context
-> MachineParameters machinecosts fun val -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (MachineParameters CaserBuiltin (UniOf val)
caser MachineVariantParameters machinecosts fun val
varPars) =
      [IO (Maybe ThunkInfo)] -> IO (Maybe ThunkInfo)
allNoThunks [ Context -> CaserBuiltin (UniOf val) -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx CaserBuiltin (UniOf val)
caser, Context
-> MachineVariantParameters machinecosts fun val
-> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx MachineVariantParameters machinecosts fun val
varPars ]

{- Note [The CostingPart constraint in mkMachineVariantParameters]
Discharging the @CostingPart uni fun ~ builtincosts@ constraint in 'mkMachineParameters' causes GHC
to fail to inline the function at its call site regardless of the @INLINE@ pragma and an explicit
'inline' call.

We think that this is because discharging the @CostingPart uni fun ~ builtincosts@ constraint in the
type of 'mkMachineParameters' somehow causes it to be compiled into @expr `Cast@` co@ , where @co@'s
type is

    (CostingPart DefaultUni DefaultFun) ... ~R# ... BuiltinCostModel ...

and this fails to inline, because in order for @inline f@ to work, @f@ must be compiled into either
a @Var@, or an @App@ whose head is a @Var@, according to https://gitlab.haskell.org/ghc/ghc/-/blob/1f02b7430b2fbab403d7ffdde9cfd006e884678e/compiler/prelude/PrelRules.hs#L1442-1449
And if @f@ is compiled into a @Cast@ like 'mkMachineParameters' with the discharged constraint, then
inlining won't work. We don't know why it's implemented this way in GHC.

It seems fully applying @f@ helps, i.e.

    - inline mkMachineParameters unlMode <$> <...>
    + (\x -> inline (mkMachineParameters unlMode x)) <$> <...>

which makes sense: if @f@ receives all its type and term args then there's less reason to throw a
@Cast@ in there.
-}

-- See Note [Inlining meanings of builtins].
{-| This just uses 'toBuiltinsRuntime' function to convert a BuiltinCostModel to a BuiltinsRuntime. -}
mkMachineVariantParameters ::
    ( -- WARNING: do not discharge the equality constraint as that causes GHC to fail to inline the
      -- function at its call site, see Note [The CostingPart constraint in mkMachineParameters].
      CostingPart uni fun ~ builtincosts
    , HasMeaningIn uni val
    , ToBuiltinMeaning uni fun
    )
    => BuiltinSemanticsVariant fun
    -> CostModel machineCosts builtincosts
    -> MachineVariantParameters machineCosts fun val
mkMachineVariantParameters :: forall (uni :: * -> *) fun builtincosts val machineCosts.
(CostingPart uni fun ~ builtincosts, HasMeaningIn uni val,
 ToBuiltinMeaning uni fun) =>
BuiltinSemanticsVariant fun
-> CostModel machineCosts builtincosts
-> MachineVariantParameters machineCosts fun val
mkMachineVariantParameters BuiltinSemanticsVariant fun
semvar (CostModel machineCosts
mchnCosts builtincosts
builtinCosts) =
    machineCosts
-> BuiltinsRuntime fun val
-> MachineVariantParameters machineCosts fun val
forall machineCosts fun val.
machineCosts
-> BuiltinsRuntime fun val
-> MachineVariantParameters machineCosts fun val
MachineVariantParameters machineCosts
mchnCosts (BuiltinsRuntime fun val
 -> MachineVariantParameters machineCosts fun val)
-> BuiltinsRuntime fun val
-> MachineVariantParameters machineCosts fun val
forall a b. (a -> b) -> a -> b
$ (BuiltinSemanticsVariant fun
 -> builtincosts -> BuiltinsRuntime fun val)
-> BuiltinSemanticsVariant fun
-> builtincosts
-> BuiltinsRuntime fun val
forall a. a -> a
inline BuiltinSemanticsVariant fun
-> builtincosts -> BuiltinsRuntime fun val
forall cost (uni :: * -> *) fun val.
(cost ~ CostingPart uni fun, ToBuiltinMeaning uni fun,
 HasMeaningIn uni val) =>
BuiltinSemanticsVariant fun -> cost -> BuiltinsRuntime fun val
toBuiltinsRuntime BuiltinSemanticsVariant fun
semvar builtincosts
builtinCosts
{-# INLINE mkMachineVariantParameters #-}