[Builtins] Make 'toBuiltinRuntime' a class method

plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs

@@ -86,6 +86,8 @@ nopCostModel =
 nopCostParameters :: MachineParameters CekMachineCosts CekValue DefaultUni NopFuns
 nopCostParameters = toMachineParameters $ CostModel defaultCekMachineCosts nopCostModel
 
+instance HasConstantIn DefaultUni val => ToBuiltinsRuntime NopFuns val
+
 {- | The meanings of the builtins.  Each one takes a number of integer arguments
    and returns an integer without doing any other work.  We could have used
    units instead of integers, but using integers makes it possible to check that

plutus-core/plutus-core.cabal

@@ -230,8 +230,9 @@ library
         UntypedPlutusCore.Core.Instance.Recursive
         UntypedPlutusCore.Core.Plated
         UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts
-        UntypedPlutusCore.Evaluation.Machine.Cek.ExBudgetMode
+        UntypedPlutusCore.Evaluation.Machine.Cek.Default
         UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode
+        UntypedPlutusCore.Evaluation.Machine.Cek.ExBudgetMode
         UntypedPlutusCore.Mark
         UntypedPlutusCore.Rename.Internal
         UntypedPlutusCore.Simplify

plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs

@@ -127,9 +127,17 @@ instance (ToBuiltinMeaning uni fun1, ToBuiltinMeaning uni fun2) =>
     toBuiltinMeaning (Right fun) = case toBuiltinMeaning fun of
         BuiltinMeaning sch toF toExF -> BuiltinMeaning sch toF (toExF . snd)
 
+instance
+    ( HasConstantIn DefaultUni val
+    , ToBuiltinMeaning DefaultUni fun1
+    , ToBuiltinMeaning DefaultUni fun2
+    ) => ToBuiltinsRuntime (Either fun1 fun2) val
+
+instance HasConstantIn DefaultUni val => ToBuiltinsRuntime ExtensionFun val
+
 defBuiltinsRuntimeExt
-    :: HasConstantIn DefaultUni term
-    => BuiltinsRuntime (Either DefaultFun ExtensionFun) term
+    :: HasConstantIn DefaultUni val
+    => BuiltinsRuntime (Either DefaultFun ExtensionFun) val
 defBuiltinsRuntimeExt = toBuiltinsRuntime (defaultBuiltinCostModel, ())
 
 data PlcListRep (a :: GHC.Type)

plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs

@@ -35,6 +35,7 @@ import PlutusCore.Core
 import PlutusCore.Evaluation.Machine.Exception
 import PlutusCore.Evaluation.Result
 
+import Control.Lens ((#))
 import Control.Lens.TH (makeClassyPrisms)
 import Control.Monad.Except
 import Data.Coerce
@@ -171,6 +172,21 @@ instance AsUnliftingError ReadKnownError where
 instance AsEvaluationFailure ReadKnownError where
     _EvaluationFailure = _EvaluationFailureVia ReadKnownEvaluationFailure
 
+-- | An 'UnliftingError' for case when two type tags don't match.
+typeMismatchError
+    :: GShow uni
+    => uni (Esc a)
+    -> uni (Esc b)
+    -> UnliftingError
+typeMismatchError uniExp uniAct = fromString $ concat
+    [ "Type mismatch: "
+    , "expected: " ++ gshow uniExp
+    , "; actual: " ++ gshow uniAct
+    ]
+-- If this function is inlined, it pollutes Core output a lot, so we mark it as non-inlineable,
+-- given that we don't care about performance here, since evaluation is about to be terminated.
+{-# NOINLINE typeMismatchError #-}
+
 -- See Note [Unlifting values of built-in types].
 -- | Convert a constant embedded into a PLC term to the corresponding Haskell value.
 readKnownConstant
@@ -183,14 +199,9 @@ readKnownConstant mayCause val = asConstant mayCause val >>= oneShot \case
         -- 'geq' matches on its first argument first, so we make the type tag that will be known
         -- statically (because this function will be inlined) go first in order for GHC to optimize some of the matching away.
         case uniExp `geq` uniAct of
-            Just Refl -> pure x
-            Nothing   -> do
-                let err = fromString $ concat
-                        [ "Type mismatch: "
-                        , "expected: " ++ gshow uniExp
-                        , "; actual: " ++ gshow uniAct
-                        ]
-                throwingWithCause _UnliftingError err mayCause
+            Just Refl -> Right x
+            Nothing   -> Left $
+              ErrorWithCause (_UnliftingError # typeMismatchError uniExp uniAct) mayCause
 {-# INLINE readKnownConstant #-}
 
 -- See Note [Performance of KnownTypeIn instances].

plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs

@@ -1,6 +1,7 @@
 -- GHC doesn't like the definition of 'makeBuiltinMeaning'.
 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
+{-# LANGUAGE AllowAmbiguousTypes       #-}
 {-# LANGUAGE DataKinds                 #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances         #-}
@@ -113,6 +114,9 @@ Where all lower-case names are Haskell type variables). We'll call functions hav
 The end result is that the user only has to specify the type of the denotation of a built-in
 function and the 'TypeScheme' of the built-in function will be derived automatically. And in the
 monomorphic and simply-polymorphic cases no types need to be specified at all.
+
+Instances have @INLINE@ pragmas attached to methods, not sure if it helps, but it certainly
+doesn't hurt.
 -}
 
 type family GetArgs a :: [GHC.Type] where
@@ -126,19 +130,22 @@ class KnownMonotype val args res a | args res -> a, a -> res where
 -- | Once we've run out of term-level arguments, we return a 'TypeSchemeResult'.
 instance (res ~ res', KnownType val res) => KnownMonotype val '[] res res' where
     knownMonotype = TypeSchemeResult
+    {-# INLINE knownMonotype #-}
 
 -- | Every term-level argument becomes as 'TypeSchemeArrow'.
 instance (KnownType val arg, KnownMonotype val args res a) =>
             KnownMonotype val (arg ': args) res (arg -> a) where
     knownMonotype = TypeSchemeArrow knownMonotype
+    {-# INLINE knownMonotype #-}
 
 -- | A class that allows us to derive a polytype for a builtin.
 class KnownPolytype (binds :: [Some TyNameRep]) val args res a | args res -> a, a -> res where
-    knownPolytype :: Proxy binds -> TypeScheme val args res
+    knownPolytype :: TypeScheme val args res
 
 -- | Once we've run out of type-level arguments, we start handling term-level ones.
 instance KnownMonotype val args res a => KnownPolytype '[] val args res a where
-    knownPolytype _ = knownMonotype
+    knownPolytype = knownMonotype
+    {-# INLINE knownPolytype #-}
 
 -- Here we unpack an existentially packed @kind@ and constrain it afterwards!
 -- So promoted existentials are true sigmas! If we were at the term level, we'd have to pack
@@ -147,7 +154,8 @@ instance KnownMonotype val args res a => KnownPolytype '[] val args res a where
 -- | Every type-level argument becomes a 'TypeSchemeAll'.
 instance (KnownSymbol name, KnownNat uniq, KnownKind kind, KnownPolytype binds val args res a) =>
             KnownPolytype ('Some ('TyNameRep @kind name uniq) ': binds) val args res a where
-    knownPolytype _ = TypeSchemeAll @name @uniq @kind Proxy $ knownPolytype (Proxy @binds)
+    knownPolytype = TypeSchemeAll @name @uniq @kind Proxy $ knownPolytype @binds
+    {-# INLINE knownPolytype #-}
 
 -- See Note [Automatic derivation of type schemes]
 -- | Construct the meaning for a built-in function by automatically deriving its
@@ -161,4 +169,5 @@ makeBuiltinMeaning
        , ElaborateFromTo 0 j val a, KnownPolytype binds val args res a
        )
     => a -> (cost -> FoldArgsEx args) -> BuiltinMeaning val cost
-makeBuiltinMeaning = BuiltinMeaning (knownPolytype (Proxy @binds) :: TypeScheme val args res)
+makeBuiltinMeaning = BuiltinMeaning $ knownPolytype @binds @val @args @res
+{-# INLINE makeBuiltinMeaning #-}

plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs

@@ -1,15 +1,19 @@
-{-# LANGUAGE DataKinds      #-}
-{-# LANGUAGE GADTs          #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE TypeOperators  #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DefaultSignatures     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TypeOperators         #-}
 
-{-# LANGUAGE StrictData     #-}
+{-# LANGUAGE StrictData            #-}
 
 module PlutusCore.Builtin.Runtime where
 
 import PlutusPrelude
 
 import PlutusCore.Builtin.HasConstant
+import PlutusCore.Builtin.KnownType
 import PlutusCore.Builtin.Meaning
 import PlutusCore.Builtin.TypeScheme
 import PlutusCore.Core
@@ -19,7 +23,7 @@ import Control.Lens (ix, (^?))
 import Control.Monad.Except
 import Data.Array
 import Data.Kind qualified as GHC (Type)
-import PlutusCore.Builtin.KnownType
+import GHC.Exts (inline)
 
 -- | Same as 'TypeScheme' except this one doesn't contain any evaluation-irrelevant types stuff.
 data RuntimeScheme val (args :: [GHC.Type]) res where
@@ -66,7 +70,7 @@ newtype BuiltinsRuntime fun val = BuiltinsRuntime
 
 -- | Convert a 'TypeScheme' to a 'RuntimeScheme'.
 typeSchemeToRuntimeScheme :: TypeScheme val args res -> RuntimeScheme val args res
-typeSchemeToRuntimeScheme TypeSchemeResult       = RuntimeSchemeResult
+typeSchemeToRuntimeScheme TypeSchemeResult = RuntimeSchemeResult
 typeSchemeToRuntimeScheme (TypeSchemeArrow schB) =
     RuntimeSchemeArrow $ typeSchemeToRuntimeScheme schB
 typeSchemeToRuntimeScheme (TypeSchemeAll _ schK) =
@@ -77,13 +81,28 @@ toBuiltinRuntime :: cost -> BuiltinMeaning val cost -> BuiltinRuntime val
 toBuiltinRuntime cost (BuiltinMeaning sch f exF) =
     BuiltinRuntime (typeSchemeToRuntimeScheme sch) f (exF cost)
 
--- | Calculate runtime info for all built-in functions given denotations of builtins
--- and a cost model.
-toBuiltinsRuntime
-    :: (cost ~ CostingPart uni fun, HasConstantIn uni val, ToBuiltinMeaning uni fun)
-    => cost -> BuiltinsRuntime fun val
-toBuiltinsRuntime cost =
-    BuiltinsRuntime . tabulateArray $ toBuiltinRuntime cost . toBuiltinMeaning
+-- | This is a function turned into a class for the sake of specialization and inspection.
+-- Every instance of this class MUST use the default implementation of 'toBuiltinsRuntime',
+-- i.e. not define 'toBuiltinsRuntime' at all. Having this class allows us to inline away lots of
+-- abstractions used by the builtins machinery.
+--
+-- For performance-critical code both @fun@ and @val@ need to be specified as concrete data types
+-- for inlining to happen. In other places it's fine to only specify one of them.
+class ToBuiltinsRuntime fun val where
+    -- Somehow getting rid of the @uni ~ UniOf val@ constraint by substituting @UniOf val@ for @uni@
+    -- completely breaks inlining of 'toBuiltinMeaning'.
+    -- | Calculate runtime info for all built-in functions given a cost model.
+    toBuiltinsRuntime :: uni ~ UniOf val => CostingPart uni fun -> BuiltinsRuntime fun val
+    default toBuiltinsRuntime
+        :: (HasConstantIn uni val, ToBuiltinMeaning uni fun)
+        => CostingPart uni fun -> BuiltinsRuntime fun val
+    -- Do we want to mark this as @INLINE@? Or @NOINLINE@? The former has the advantage of allowing
+    -- us to optimize some of the @cost@-related operations away at the cost of potentially blowing
+    -- up compilation times or even the size of the executable (probably not though). The latter is
+    -- the opposite. Currently we let GHC decide: it won't inline 'toBuiltinsRuntime' if it's huge.
+    toBuiltinsRuntime cost =
+        -- 'toBuiltinMeaning' can be a huge function, hence an explicit 'inline'.
+        BuiltinsRuntime . tabulateArray $ toBuiltinRuntime cost . inline toBuiltinMeaning
 
 -- | Look up the runtime info of a built-in function during evaluation.
 lookupBuiltin

plutus-core/plutus-core/src/PlutusCore/Builtin/TypeScheme.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE DataKinds        #-}
 {-# LANGUAGE GADTs            #-}
 {-# LANGUAGE KindSignatures   #-}
+{-# LANGUAGE RankNTypes       #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies     #-}
 {-# LANGUAGE TypeOperators    #-}
@@ -34,20 +35,48 @@ import GHC.TypeLits
 
 infixr 9 `TypeSchemeArrow`
 
+{- Note [KnownType in TypeSchemeArrow]
+There's a @KnownType val arg@ constrained packed in the 'TypeSchemeArrow' constructor. We're not
+supposed to have it there, it really should be enough to have 'KnownTypeAst', because 'readKnown'
+is inlined as an explicit argument. Unfortunately, in the @Generators@ tests we use 'TypeScheme'
+for generation of arbitrary arguments of builtins and that requires 'makeKnown', which makes us
+have the whole 'KnownType' in 'TypeSchemeArrow', which also retains the unspecialized 'readKnown',
+which pollutes Core quite a bit and in particular makes it unclear whether the whole 'HasConstant'
+business is inlined away or not.
+
+There are two things that need to be done:
+
+1. 'KnownTypeIn' needs to be split into two classes. Unfortunately, it's not as easy as it may seem:
+   we did it in https://github.com/input-output-hk/plutus/pull/4420 and it introduced a 2-5%
+   slowdown
+2. the @Generators@ tests need to do something else. Explicitly constraining @args@ outside of
+   'TypeScheme' sounds like a promising strategy. Maybe we could just delete those tests altogether
+
+However it's also worth considering untangling 'RuntimeScheme' from 'TypeScheme' and generating the
+two in parallel, so that we only need to optimize the former. Then we will be able to afford having
+any kind of nonsense in 'TypeScheme'. Another reason for that would be the fact that Core output
+has 'typeSchemeToRuntimeScheme' all over the place as it can't be inlined due to being a recursive
+function, which we can't turn into an inlinable class method, because the indices of 'TypeScheme'
+don't reflect its structure due to the 'TypeSchemeAll' constructor not being reflected at the type
+level in any way. It's unlikely that having those 'typeSchemeToRuntimeScheme' has any impact on
+performance, because they're only evaluated once during initialization, but it certainly has impact
+on readability of the Core output.
+-}
+
+-- See Note [KnownType in TypeSchemeArrow].
 -- | Type schemes of primitive operations.
--- @as@ is a list of types of arguments, @r@ is the resulting type.
+-- @args@ is a list of types of arguments, @res@ is the resulting type.
 -- E.g. @Text -> Bool -> Integer@ is encoded as @TypeScheme val [Text, Bool] Integer@.
 data TypeScheme val (args :: [GHC.Type]) res where
     TypeSchemeResult
         :: KnownType val res
         => TypeScheme val '[] res
     TypeSchemeArrow
         :: KnownType val arg
-        => TypeScheme val args res -> TypeScheme val (arg ': args) res
+        => TypeScheme val args res
+        -> TypeScheme val (arg ': args) res
     TypeSchemeAll
         :: (KnownSymbol text, KnownNat uniq, KnownKind kind)
-           -- Here we require the user to manually provide the unique of a type variable.
-           -- That's nothing but silly, but I do not see what else we can do with the current design.
         => Proxy '(text, uniq, kind)
         -> TypeScheme val args res
         -> TypeScheme val args res

plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs

@@ -349,14 +349,14 @@ Here's how it's defined:
 
 I.e. @Opaque val rep@ is a wrapper around @val@, which stands for the type of value that an
 evaluator uses (the builtins machinery is designed to work with any evaluator and different
-evaluators define their type of values differently, for example 'CkValue' if the type of value for
+evaluators define their type of values differently, for example 'CkValue' is the type of value for
 the CK machine). The idea is simple: in order to apply the denotation of a builtin expecting, say,
 an 'Integer' constant we need to actually extract that 'Integer' from the AST of the given value,
 but if the denotation is polymorphic over the type of its argument, then we don't need to extract
 anything, we can just pass the AST of the value directly to the denotation. I.e. in order for a
-polymorphic function to become a monomorphic denotation (denotations are always monomorpic) all type
-variables in the type of that function need to be instantiated at the type of value that a given
-evaluator uses.
+polymorphic function to become a monomorphic denotation (denotations are always monomorphic) all
+type variables in the type of that function need to be instantiated at the type of value that a
+given evaluator uses.
 
 If we used just @val@ rathen than @Opaque val rep@, we'd specialize
 
@@ -790,6 +790,8 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
         makeBuiltinMeaning
             (\() -> [] @(Data,Data))
             (runCostingFunOneArgument . paramMkNilPairData)
+    -- Keeping the unfolding, so that this function can be inlined in 'toBuiltinsRuntime'.
+    {-# INLINABLE toBuiltinMeaning #-}
 
 -- It's set deliberately to give us "extra room" in the binary format to add things without running
 -- out of space for tags (expanding the space would change the binary format for people who're

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs

@@ -30,6 +30,7 @@ import PlutusPrelude
 
 import PlutusCore.Builtin
 import PlutusCore.Core
+import PlutusCore.Default
 import PlutusCore.Evaluation.Machine.Exception
 import PlutusCore.Evaluation.Result
 import PlutusCore.Name
@@ -43,7 +44,6 @@ import Data.DList (DList)
 import Data.DList qualified as DList
 import Data.STRef
 import Data.Text (Text)
-import Universe
 
 infix 4 |>, <|
 
@@ -59,6 +59,8 @@ data CkValue uni fun =
   | VBuiltin (Term TyName Name uni fun ()) (BuiltinRuntime (CkValue uni fun))
     deriving (Show)
 
+instance ToBuiltinsRuntime DefaultFun (CkValue DefaultUni DefaultFun)
+
 -- | Take pieces of a possibly partial builtin application and either create a 'CkValue' using
 -- 'makeKnown' or a partial builtin application depending on whether the built-in function is
 -- fully saturated or not.
@@ -118,8 +120,9 @@ emitCkM str = do
 type instance UniOf (CkValue uni fun) = uni
 
 instance HasConstant (CkValue uni fun) where
-    asConstant _        (VCon val) = pure val
-    asConstant mayCause _          = throwNotAConstant mayCause
+    asConstant mayCause = \case
+        VCon val -> pure val
+        _        -> throwNotAConstant mayCause
 
     fromConstant = VCon