From ce5acfe71f5fbc1178f6b973178a9f565e8c8579 Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Wed, 4 May 2022 23:46:30 +0200
Subject: [PATCH 01/10] [Builtins] Optimize 'MakeKnownM'
---
.../src/PlutusCore/Builtin/KnownType.hs | 80 +++++++++++++++----
.../src/PlutusCore/Builtin/Meaning.hs | 3 +-
.../src/PlutusCore/Builtin/Runtime.hs | 4 +-
.../src/PlutusCore/Evaluation/Machine/Ck.hs | 10 +--
.../plutus-core/test/Evaluation/Spec.hs | 4 +-
.../Evaluation/Machine/Cek/Internal.hs | 11 +--
6 files changed, 81 insertions(+), 31 deletions(-)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index 604441c0b8d..8d5f3653f76 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -18,20 +18,18 @@ module PlutusCore.Builtin.KnownType
, 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
@@ -195,12 +193,68 @@ a ton of instances (and add new ones whenever we need them), wrap and unwrap all
-- See Note [MakeKnownM and ReadKnownM being type synonyms].
-- | The monad that 'makeKnown' runs in.
-type MakeKnownM = ExceptT KnownTypeError Emitter
+data MakeKnownM a
+ = MakeKnownFailure !(DList Text) !KnownTypeError
+ | MakeKnownSuccess !a
+ | MakeKnownSuccessWithLogs !(DList Text) !a
+
+fmapWithLogs :: DList Text -> (a -> b) -> MakeKnownM a -> MakeKnownM b
+fmapWithLogs logs1 f = \case
+ MakeKnownFailure logs2 err -> MakeKnownFailure (logs1 <> logs2) err
+ MakeKnownSuccess x -> MakeKnownSuccessWithLogs logs1 (f x)
+ MakeKnownSuccessWithLogs logs2 x -> MakeKnownSuccessWithLogs (logs1 <> logs2) (f x)
+{-# INLINE fmapWithLogs #-}
+
+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 #-}
+
+ _ <$ 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 = fmapWithLogs logs f a
+ {-# INLINE (<*>) #-}
+
+ 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 (>>) #-}
-- See Note [MakeKnownM and ReadKnownM being type synonyms].
-- | The monad that 'readKnown' runs in.
type ReadKnownM = Either KnownTypeError
+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
@@ -253,15 +307,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 +325,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 +342,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
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs
index f6ffb5c567d..9cf0f36f11c 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs
+++ b/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'.
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs
index 3fe36f0a5e4..30f3b741567 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs
@@ -104,8 +104,8 @@ data UnliftingMode
-- instantiating '_broToExF' with a cost model to get the costing function for the builtin.
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
}
diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs
index e80de2a9696..237f759f721 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs
+++ b/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 ()
diff --git a/plutus-core/plutus-core/test/Evaluation/Spec.hs b/plutus-core/plutus-core/test/Evaluation/Spec.hs
index 34785a73375..45d40171751 100644
--- a/plutus-core/plutus-core/test/Evaluation/Spec.hs
+++ b/plutus-core/plutus-core/test/Evaluation/Spec.hs
@@ -55,7 +55,7 @@ prop_builtinsDon'tThrow bn = property $ do
mbErr <-
liftIO $
catch
- (($> Nothing) . evaluate . runEmitter . runExceptT $ eval args)
+ (($> Nothing) . evaluate $ eval args)
(pure . pure)
whenJust mbErr $ \(e :: SomeException) -> do
annotate "Builtin function evaluation failed"
@@ -79,7 +79,7 @@ prop_builtinsDon'tThrow bn = property $ do
MakeKnownM Term
go sch f args = case (sch, args) of
(RuntimeSchemeArrow sch', a : as) -> do
- res <- liftEither (f a)
+ res <- liftReadKnownM (f a)
go sch' res as
(RuntimeSchemeResult, []) -> f
(RuntimeSchemeAll sch', _) -> go sch' f args
diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs
index 3a780ab10ee..1054988a313 100644
--- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs
+++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs
@@ -565,11 +565,12 @@ evalBuiltinApp
evalBuiltinApp fun term env 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 env runtime
{-# INLINE evalBuiltinApp #-}
From ade58d8f3fcb463bbdc1917e2c1d0a5840101ae5 Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Mon, 9 May 2022 23:00:37 +0200
Subject: [PATCH 02/10] Docs
---
.../src/PlutusCore/Builtin/KnownType.hs | 32 ++++++++++++-------
.../src/PlutusCore/Builtin/Runtime.hs | 4 +++
2 files changed, 25 insertions(+), 11 deletions(-)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index 8d5f3653f76..168fa25820f 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -182,22 +182,22 @@ 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.
+-- 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.
data MakeKnownM a
= MakeKnownFailure !(DList Text) !KnownTypeError
| MakeKnownSuccess !a
| MakeKnownSuccessWithLogs !(DList Text) !a
+-- | Prepend logs to a 'MakeKnownM' computation and 'fmap' it.
fmapWithLogs :: DList Text -> (a -> b) -> MakeKnownM a -> MakeKnownM b
fmapWithLogs logs1 f = \case
MakeKnownFailure logs2 err -> MakeKnownFailure (logs1 <> logs2) err
@@ -205,6 +205,7 @@ fmapWithLogs logs1 f = \case
MakeKnownSuccessWithLogs logs2 x -> MakeKnownSuccessWithLogs (logs1 <> logs2) (f x)
{-# INLINE fmapWithLogs #-}
+-- | Prepend logs to a 'MakeKnownM' computation.
withLogs :: DList Text -> MakeKnownM a -> MakeKnownM a
withLogs logs1 = \case
MakeKnownFailure logs2 err -> MakeKnownFailure (logs1 <> logs2) err
@@ -213,11 +214,14 @@ withLogs logs1 = \case
{-# INLINE withLogs #-}
instance Functor MakeKnownM where
+ -- Written out explicitly, because for some inexplicable reason GHC fails to inline
+ -- @fmapWithLogs mempty@ despite the pragma.
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
@@ -246,10 +250,16 @@ instance Monad MakeKnownM where
(>>) = (*>)
{-# INLINE (>>) #-}
--- See 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 '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
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs
index 30f3b741567..ed8b2ce63e7 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs
@@ -102,6 +102,10 @@ 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)
From 54665b928463523953352a3135e319f522dcc67a Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Tue, 10 May 2022 14:14:03 +0200
Subject: [PATCH 03/10] Drop 'fmapWithLogs'
---
.../plutus-core/src/PlutusCore/Builtin/KnownType.hs | 10 +---------
1 file changed, 1 insertion(+), 9 deletions(-)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index 168fa25820f..f2573c93e87 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -197,14 +197,6 @@ data MakeKnownM a
| MakeKnownSuccess !a
| MakeKnownSuccessWithLogs !(DList Text) !a
--- | Prepend logs to a 'MakeKnownM' computation and 'fmap' it.
-fmapWithLogs :: DList Text -> (a -> b) -> MakeKnownM a -> MakeKnownM b
-fmapWithLogs logs1 f = \case
- MakeKnownFailure logs2 err -> MakeKnownFailure (logs1 <> logs2) err
- MakeKnownSuccess x -> MakeKnownSuccessWithLogs logs1 (f x)
- MakeKnownSuccessWithLogs logs2 x -> MakeKnownSuccessWithLogs (logs1 <> logs2) (f x)
-{-# INLINE fmapWithLogs #-}
-
-- | Prepend logs to a 'MakeKnownM' computation.
withLogs :: DList Text -> MakeKnownM a -> MakeKnownM a
withLogs logs1 = \case
@@ -233,7 +225,7 @@ instance Applicative MakeKnownM where
MakeKnownFailure logs err <*> _ = MakeKnownFailure logs err
MakeKnownSuccess f <*> a = fmap f a
- MakeKnownSuccessWithLogs logs f <*> a = fmapWithLogs logs f a
+ MakeKnownSuccessWithLogs logs f <*> a = withLogs logs $ fmap f a
{-# INLINE (<*>) #-}
MakeKnownFailure logs err *> _ = MakeKnownFailure logs err
From 6377aa69f59f506787390413706b83542ff00c1c Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Tue, 10 May 2022 15:01:47 +0200
Subject: [PATCH 04/10] Add 'StrictData'
---
.../src/PlutusCore/Builtin/KnownType.hs | 17 ++++++++++-------
1 file changed, 10 insertions(+), 7 deletions(-)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index f2573c93e87..53cae255e76 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -13,6 +13,8 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StrictData #-}
+
module PlutusCore.Builtin.KnownType
( KnownTypeError
, throwKnownTypeErrorWithCause
@@ -193,9 +195,9 @@ typeMismatchError uniExp uniAct = fromString $ concat
-- Moving from @ExceptT KnownTypeError Emitter@ to this data type gave us a speedup of 8% of total
-- evaluation time.
data MakeKnownM a
- = MakeKnownFailure !(DList Text) !KnownTypeError
- | MakeKnownSuccess !a
- | MakeKnownSuccessWithLogs !(DList Text) !a
+ = MakeKnownFailure (DList Text) KnownTypeError
+ | MakeKnownSuccess a
+ | MakeKnownSuccessWithLogs (DList Text) a
-- | Prepend logs to a 'MakeKnownM' computation.
withLogs :: DList Text -> MakeKnownM a -> MakeKnownM a
@@ -288,10 +290,11 @@ 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.
- makeKnown x = pure . fromConstant . someValue $! x
+ -- Everything on evaluation path has to be strict, hence we don't do any extra forcing here 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.
+ makeKnown = pure . fromConstant . someValue
{-# INLINE makeKnown #-}
type MakeKnown val = MakeKnownIn (UniOf val) val
From c27e088cad4c6bbdc6d596b21ebf33bde13a7fa1 Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Tue, 10 May 2022 16:06:18 +0200
Subject: [PATCH 05/10] Drop 'StrictData'
---
plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs | 2 --
1 file changed, 2 deletions(-)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index 53cae255e76..9479f78d189 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -13,8 +13,6 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE StrictData #-}
-
module PlutusCore.Builtin.KnownType
( KnownTypeError
, throwKnownTypeErrorWithCause
From f6845efe811ab0082fc58273aeda2ab9aacfb936 Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Tue, 10 May 2022 16:20:14 +0200
Subject: [PATCH 06/10] A bit more comments
---
plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index 9479f78d189..a89e77b176c 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -192,6 +192,10 @@ typeMismatchError uniExp uniAct = fromString $ concat
--
-- 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
@@ -228,6 +232,8 @@ instance Applicative MakeKnownM where
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
From 20f4e15e2ed54433bf5117f9ca64fef94241fe95 Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Tue, 10 May 2022 17:04:06 +0200
Subject: [PATCH 07/10] And now do the forcing properly
---
plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index a89e77b176c..74f88d06c00 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -298,7 +298,7 @@ class uni ~ UniOf val => MakeKnownIn uni val a where
-- 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.
- makeKnown = pure . fromConstant . someValue
+ makeKnown x = pure . fromConstant . someValue $! x
{-# INLINE makeKnown #-}
type MakeKnown val = MakeKnownIn (UniOf val) val
From d06d3af8dbf1f8155024127b336681b0900a5731 Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Tue, 10 May 2022 17:46:50 +0200
Subject: [PATCH 08/10] Revert "Drop 'StrictData'"
This reverts commit c27e088cad4c6bbdc6d596b21ebf33bde13a7fa1.
---
plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs | 2 ++
1 file changed, 2 insertions(+)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index 74f88d06c00..21eab085c97 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -13,6 +13,8 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StrictData #-}
+
module PlutusCore.Builtin.KnownType
( KnownTypeError
, throwKnownTypeErrorWithCause
From f93d9df525195b22eedd8020a103a3494643c53e Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Tue, 10 May 2022 17:47:45 +0200
Subject: [PATCH 09/10] Fixups
---
plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs | 4 +---
1 file changed, 1 insertion(+), 3 deletions(-)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index 21eab085c97..15fa17103d4 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -212,8 +212,6 @@ withLogs logs1 = \case
{-# INLINE withLogs #-}
instance Functor MakeKnownM where
- -- Written out explicitly, because for some inexplicable reason GHC fails to inline
- -- @fmapWithLogs mempty@ despite the pragma.
fmap _ (MakeKnownFailure logs err) = MakeKnownFailure logs err
fmap f (MakeKnownSuccess x) = MakeKnownSuccess (f x)
fmap f (MakeKnownSuccessWithLogs logs x) = MakeKnownSuccessWithLogs logs (f x)
@@ -300,7 +298,7 @@ class uni ~ UniOf val => MakeKnownIn uni val a where
-- 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.
- makeKnown x = pure . fromConstant . someValue $! x
+ makeKnown = pure . fromConstant . someValue
{-# INLINE makeKnown #-}
type MakeKnown val = MakeKnownIn (UniOf val) val
From bd8071f910ab0b53f23eacd9dc6ccdd29e1f2d5a Mon Sep 17 00:00:00 2001
From: effectfully <effectfully@gmail.com>
Date: Wed, 11 May 2022 01:09:11 +0200
Subject: [PATCH 10/10] Back to the bang
---
.../src/PlutusCore/Builtin/KnownType.hs | 14 +++++++++-----
1 file changed, 9 insertions(+), 5 deletions(-)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
index 15fa17103d4..1a8489d1cb8 100644
--- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
+++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs
@@ -294,11 +294,15 @@ 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
- -- Everything on evaluation path has to be strict, hence we don't do any extra forcing here 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.
- makeKnown = pure . fromConstant . someValue
+ -- 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 #-}
type MakeKnown val = MakeKnownIn (UniOf val) val