[Builtins] Optimize 'MakeKnownM'

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

@@ -13,25 +13,25 @@
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
+{-# LANGUAGE StrictData            #-}
+
 module PlutusCore.Builtin.KnownType
     ( KnownTypeError
     , throwKnownTypeErrorWithCause
     , KnownBuiltinTypeIn
     , KnownBuiltinType
-    , MakeKnownM
+    , MakeKnownM (..)
     , ReadKnownM
+    , liftReadKnownM
     , readKnownConstant
     , MakeKnownIn (..)
     , MakeKnown
     , ReadKnownIn (..)
     , ReadKnown
-    , makeKnownRun
     , makeKnownOrFail
     , readKnownSelf
     ) where
 
-import PlutusPrelude (reoption)
-
 import PlutusCore.Builtin.Emitter
 import PlutusCore.Builtin.HasConstant
 import PlutusCore.Builtin.Polymorphism
@@ -184,23 +184,85 @@ typeMismatchError uniExp uniAct = fromString $ concat
 -- failure message and evaluation is about to be shut anyway.
 {-# NOINLINE typeMismatchError #-}
 
-{- Note [MakeKnownM and ReadKnownM being type synonyms]
-Normally it's a good idea for an exported abstraction not to be a type synonym, since a @newtype@
-is cheap, looks good in error messages and clearly emphasize an abstraction barrier. However we
-make 'MakeKnownM' and 'ReadKnownM' type synonyms for convenience: that way we don't need to derive
-a ton of instances (and add new ones whenever we need them), wrap and unwrap all the time
-(including in user code), which can be non-trivial for such performance-sensitive code (see e.g.
-'coerceVia' and 'coerceArg') and there is no abstraction barrier anyway.
--}
-
--- See Note [MakeKnownM and ReadKnownM being type synonyms].
 -- | The monad that 'makeKnown' runs in.
-type MakeKnownM = ExceptT KnownTypeError Emitter
-
--- See Note [MakeKnownM and ReadKnownM being type synonyms].
+-- Equivalent to @ExceptT KnownTypeError Emitter@, except optimized in two ways:
+--
+-- 1. everything is strict
+-- 2. has the 'MakeKnownSuccess' constructor that is used for returning a value with no logs
+--    attached, which is the most common case for us, so it helps a lot not to construct and
+--    deconstruct a redundant tuple
+--
+-- Moving from @ExceptT KnownTypeError Emitter@ to this data type gave us a speedup of 8% of total
+-- evaluation time.
+--
+-- Logs are represented as a 'DList', because we don't particularly care about the efficiency of
+-- logging, since there's no logging on the chain and builtins don't emit much anyway. Otherwise
+-- we'd have to use @text-builder@ or @text-builder-linear@ or something of this sort.
+data MakeKnownM a
+    = MakeKnownFailure (DList Text) KnownTypeError
+    | MakeKnownSuccess a
+    | MakeKnownSuccessWithLogs (DList Text) a
+
+-- | Prepend logs to a 'MakeKnownM' computation.
+withLogs :: DList Text -> MakeKnownM a -> MakeKnownM a
+withLogs logs1 = \case
+    MakeKnownFailure logs2 err       -> MakeKnownFailure (logs1 <> logs2) err
+    MakeKnownSuccess x               -> MakeKnownSuccessWithLogs logs1 x
+    MakeKnownSuccessWithLogs logs2 x -> MakeKnownSuccessWithLogs (logs1 <> logs2) x
+{-# INLINE withLogs #-}
+
+instance Functor MakeKnownM where
+    fmap _ (MakeKnownFailure logs err)       = MakeKnownFailure logs err
+    fmap f (MakeKnownSuccess x)              = MakeKnownSuccess (f x)
+    fmap f (MakeKnownSuccessWithLogs logs x) = MakeKnownSuccessWithLogs logs (f x)
+    {-# INLINE fmap #-}
+
+    -- Written out explicitly just in case (see @fmap@ above for what the case might be).
+    _ <$ MakeKnownFailure logs err       = MakeKnownFailure logs err
+    x <$ MakeKnownSuccess _              = MakeKnownSuccess x
+    x <$ MakeKnownSuccessWithLogs logs _ = MakeKnownSuccessWithLogs logs x
+    {-# INLINE (<$) #-}
+
+instance Applicative MakeKnownM where
+    pure = MakeKnownSuccess
+    {-# INLINE pure #-}
+
+    MakeKnownFailure logs err       <*> _ = MakeKnownFailure logs err
+    MakeKnownSuccess f              <*> a = fmap f a
+    MakeKnownSuccessWithLogs logs f <*> a = withLogs logs $ fmap f a
+    {-# INLINE (<*>) #-}
+
+    -- Better than the default implementation, because the value in the 'MakeKnownSuccess' case
+    -- doesn't need to be retained.
+    MakeKnownFailure logs err       *> _ = MakeKnownFailure logs err
+    MakeKnownSuccess _              *> a = a
+    MakeKnownSuccessWithLogs logs _ *> a = withLogs logs a
+    {-# INLINE (*>) #-}
+
+instance Monad MakeKnownM where
+    MakeKnownFailure logs err       >>= _ = MakeKnownFailure logs err
+    MakeKnownSuccess x              >>= f = f x
+    MakeKnownSuccessWithLogs logs x >>= f = withLogs logs $ f x
+    {-# INLINE (>>=) #-}
+
+    (>>) = (*>)
+    {-# INLINE (>>) #-}
+
+-- Normally it's a good idea for an exported abstraction not to be a type synonym, since a @newtype@
+-- is cheap, looks good in error messages and clearly emphasize an abstraction barrier. However we
+-- make 'ReadKnownM' type synonyms for convenience: that way we don't need to derive all the
+-- instances (and add new ones whenever we need them), wrap and unwrap all the time
+-- (including in user code), which can be non-trivial for such performance-sensitive code (see e.g.
+-- 'coerceVia' and 'coerceArg') and there is no abstraction barrier anyway.
 -- | The monad that 'readKnown' runs in.
 type ReadKnownM = Either KnownTypeError
 
+-- | Lift a 'ReadKnownM' computation into 'MakeKnownM'.
+liftReadKnownM :: ReadKnownM a -> MakeKnownM a
+liftReadKnownM (Left err) = MakeKnownFailure mempty err
+liftReadKnownM (Right x)  = MakeKnownSuccess x
+{-# INLINE liftReadKnownM #-}
+
 -- See Note [Unlifting values of built-in types].
 -- | Convert a constant embedded into a PLC term to the corresponding Haskell value.
 readKnownConstant :: forall val a. KnownBuiltinType val a => val -> ReadKnownM a
@@ -232,9 +294,14 @@ class uni ~ UniOf val => MakeKnownIn uni val a where
     -- The inverse of 'readKnown'.
     makeKnown :: a -> MakeKnownM val
     default makeKnown :: KnownBuiltinType val a => a -> MakeKnownM val
-    -- Forcing the value to avoid space leaks. Note that the value is only forced to WHNF,
-    -- so care must be taken to ensure that every value of a type from the universe gets forced
-    -- to NF whenever it's forced to WHNF.
+    -- Everything on evaluation path has to be strict in production, so in theory we don't need to
+    -- force anything here. In practice however all kinds of weird things happen in tests and @val@
+    -- can be non-strict enough to cause trouble here, so we're forcing the argument. Looking at the
+    -- generated Core, the forcing amounts to pulling a @case@ out of the 'fromConstant' call,
+    -- which doesn't affect the overall cost and benchmarking results suggest the same.
+    --
+    -- Note that the value is only forced to WHNF, so care must be taken to ensure that every value
+    -- of a type from the universe gets forced to NF whenever it's forced to WHNF.
     makeKnown x = pure . fromConstant . someValue $! x
     {-# INLINE makeKnown #-}
 
@@ -253,15 +320,12 @@ class uni ~ UniOf val => ReadKnownIn uni val a where
 
 type ReadKnown val = ReadKnownIn (UniOf val) val
 
-makeKnownRun
-    :: MakeKnownIn uni val a
-    => a -> (ReadKnownM val, DList Text)
-makeKnownRun = runEmitter . runExceptT . makeKnown
-{-# INLINE makeKnownRun #-}
-
 -- | Same as 'makeKnown', but allows for neither emitting nor storing the cause of a failure.
 makeKnownOrFail :: MakeKnownIn uni val a => a -> EvaluationResult val
-makeKnownOrFail = reoption . fst . makeKnownRun
+makeKnownOrFail x = case makeKnown x of
+    MakeKnownFailure _ _           -> EvaluationFailure
+    MakeKnownSuccess val           -> EvaluationSuccess val
+    MakeKnownSuccessWithLogs _ val -> EvaluationSuccess val
 {-# INLINE makeKnownOrFail #-}
 
 -- | Same as 'readKnown', but the cause of a potential failure is the provided term itself.
@@ -274,7 +338,7 @@ readKnownSelf val = either (throwKnownTypeErrorWithCause val) pure $ readKnown v
 {-# INLINE readKnownSelf #-}
 
 instance MakeKnownIn uni val a => MakeKnownIn uni val (EvaluationResult a) where
-    makeKnown EvaluationFailure     = throwing_ _EvaluationFailure
+    makeKnown EvaluationFailure     = MakeKnownFailure mempty KnownTypeEvaluationFailure
     makeKnown (EvaluationSuccess x) = makeKnown x
     {-# INLINE makeKnown #-}
 
@@ -291,7 +355,8 @@ instance
     readKnown _ = throwing _UnliftingError "Panic: 'TypeError' was bypassed"
 
 instance MakeKnownIn uni val a => MakeKnownIn uni val (Emitter a) where
-    makeKnown = lift >=> makeKnown
+    makeKnown a = case runEmitter a of
+        (x, logs) -> withLogs logs $ makeKnown x
     {-# INLINE makeKnown #-}
 
 instance

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

@@ -31,7 +31,6 @@ import PlutusCore.Builtin.TypeScheme
 import PlutusCore.Core
 import PlutusCore.Name
 
-import Control.Monad.Except
 import Data.Array
 import Data.Kind qualified as GHC
 import Data.Proxy
@@ -177,7 +176,7 @@ instance (res ~ res', Typeable res, KnownTypeAst (UniOf val) res, MakeKnown val
 
     -- For deferred unlifting we need to lift the 'ReadKnownM' action into 'MakeKnownM',
     -- hence 'liftEither'.
-    toDeferredF getRes = liftEither getRes >>= makeKnown
+    toDeferredF getRes = liftReadKnownM getRes >>= makeKnown
     {-# INLINE toDeferredF #-}
 
 -- | Every term-level argument becomes as 'TypeSchemeArrow'.

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

@@ -102,10 +102,14 @@ data UnliftingMode
 -- former by choosing the runtime denotation of the builtin (either '_broImmediateF' for immediate
 -- unlifting or '_broDeferredF' for deferred unlifting, see 'UnliftingMode' for details) and by
 -- instantiating '_broToExF' with a cost model to get the costing function for the builtin.
+--
+-- The runtime denotations are lazy, so that we don't need to worry about a builtin being bottom
+-- (happens in tests). The production path is not affected by that, since 'BuiltinRuntimeOptions'
+-- doesn't survive optimization.
 data BuiltinRuntimeOptions n val cost = BuiltinRuntimeOptions
     { _broRuntimeScheme :: RuntimeScheme n
-    , _broImmediateF    :: ToRuntimeDenotationType val n
-    , _broDeferredF     :: ToRuntimeDenotationType val n
+    , _broImmediateF    :: ~(ToRuntimeDenotationType val n)
+    , _broDeferredF     :: ~(ToRuntimeDenotationType val n)
     , _broToExF         :: cost -> ToCostingType n
     }
 

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

@@ -67,12 +67,10 @@ evalBuiltinApp
     -> BuiltinRuntime (CkValue uni fun)
     -> CkM uni fun s (CkValue uni fun)
 evalBuiltinApp term runtime@(BuiltinRuntime sch getX _) = case sch of
-    RuntimeSchemeResult -> do
-        let (errOrRes, logs) = runEmitter $ runExceptT getX
-        emitCkM logs
-        case errOrRes of
-            Left err  -> throwKnownTypeErrorWithCause term err
-            Right res -> pure res
+    RuntimeSchemeResult -> case getX of
+        MakeKnownFailure logs err       -> emitCkM logs *> throwKnownTypeErrorWithCause term err
+        MakeKnownSuccess x              -> pure x
+        MakeKnownSuccessWithLogs logs x -> emitCkM logs $> x
     _ -> pure $ VBuiltin term runtime
 
 ckValueToTerm :: CkValue uni fun -> Term TyName Name uni fun ()

plutus-core/plutus-core/test/Evaluation/Spec.hs

@@ -125,7 +125,7 @@ prop_builtinEvaluation bn mkGen f = property $ do
             MakeKnownM (Term uni fun)
         go sch fn args = case (sch, args) of
             (RuntimeSchemeArrow sch', a : as) -> do
-                res <- liftEither (fn a)
+                res <- liftReadKnownM (fn a)
                 go sch' res as
             (RuntimeSchemeResult, []) -> fn
             (RuntimeSchemeAll sch', _) -> go sch' fn args

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs

@@ -569,11 +569,12 @@ evalBuiltinApp
 evalBuiltinApp fun term runtime@(BuiltinRuntime sch getX cost) = case sch of
     RuntimeSchemeResult -> do
         spendBudgetCek (BBuiltinApp fun) cost
-        let !(errOrRes, logs) = runEmitter $ runExceptT getX
-        ?cekEmitter logs
-        case errOrRes of
-            Left err  -> throwKnownTypeErrorWithCause term err
-            Right res -> pure res
+        case getX of
+            MakeKnownFailure logs err       -> do
+                ?cekEmitter logs
+                throwKnownTypeErrorWithCause term err
+            MakeKnownSuccess x              -> pure x
+            MakeKnownSuccessWithLogs logs x -> ?cekEmitter logs $> x
     _ -> pure $ VBuiltin fun term runtime
 {-# INLINE evalBuiltinApp #-}