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

module PlutusCore.Evaluation.Machine.MachineParameters
where

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

{-| 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.  The 'term' 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 -> machinecosts
machineCosts    :: machinecosts
    , forall machinecosts fun val.
MachineParameters machinecosts fun val -> BuiltinsRuntime fun val
builtinsRuntime :: BuiltinsRuntime 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 (MachineParameters machinecosts fun val) where
  wNoThunks :: Context
-> MachineParameters machinecosts fun val -> IO (Maybe ThunkInfo)
wNoThunks Context
ctx (MachineParameters 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 ]

{- Note [The CostingPart constraint in mkMachineParameters]
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. -}
mkMachineParameters ::
    ( -- 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
    -> MachineParameters machinecosts fun val
mkMachineParameters :: forall (uni :: * -> *) fun builtincosts val machinecosts.
(CostingPart uni fun ~ builtincosts, HasMeaningIn uni val,
 ToBuiltinMeaning uni fun) =>
BuiltinSemanticsVariant fun
-> CostModel machinecosts builtincosts
-> MachineParameters machinecosts fun val
mkMachineParameters BuiltinSemanticsVariant fun
semvar (CostModel machinecosts
mchnCosts builtincosts
builtinCosts) =
    machinecosts
-> BuiltinsRuntime fun val
-> MachineParameters machinecosts fun val
forall machinecosts fun val.
machinecosts
-> BuiltinsRuntime fun val
-> MachineParameters machinecosts fun val
MachineParameters machinecosts
mchnCosts ((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 mkMachineParameters #-}