[Builtins] Monomorphize 'makeKnown'

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

@@ -144,7 +144,7 @@ instance KnownTypeAst DefaultUni Void where
         a <- freshTyName "a"
         pure $ TyForall () a (Type ()) $ TyVar () a
 instance UniOf term ~ DefaultUni => KnownTypeIn DefaultUni term Void where
-    makeKnown _ _ = absurd
+    makeKnown _ = absurd
     readKnown mayCause _ = throwingWithCause _UnliftingError "Can't unlift a 'Void'" mayCause
 
 data BuiltinErrorCall = BuiltinErrorCall

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

@@ -1,27 +1,22 @@
-{-# LANGUAGE RankNTypes #-}
-
 module PlutusCore.Builtin.Emitter
     ( Emitter (..)
-    , emitM
+    , runEmitter
+    , emit
     ) where
 
+import Control.Monad.Trans.Writer.Strict (Writer, runWriter, tell)
+import Data.DList as DList
 import Data.Text (Text)
 
--- | A monad for logging that does not hardcode any concrete first-order encoding and instead packs
--- a @Monad m@ constraint and a @Text -> m ()@ argument internally, so that built-in functions that
--- do logging can work in any monad (for example, @CkM@ or @CekM@), for which there exists a
--- logging function.
+-- | A monad for logging.
 newtype Emitter a = Emitter
-    { unEmitter :: forall m. Monad m => (Text -> m ()) -> m a
-    } deriving (Functor)
-
--- newtype-deriving doesn't work with 'Emitter'.
-instance Applicative Emitter where
-    pure x = Emitter $ \_ -> pure x
-    Emitter f <*> Emitter a = Emitter $ \emit -> f emit <*> a emit
+    { unEmitter :: Writer (DList Text) a
+    } deriving newtype (Functor, Applicative, Monad)
 
-instance Monad Emitter where
-    Emitter a >>= f = Emitter $ \emit -> a emit >>= \x -> unEmitter (f x) emit
+runEmitter :: Emitter a -> (a, DList Text)
+runEmitter = runWriter . unEmitter
+{-# INLINE runEmitter #-}
 
-emitM :: Text -> Emitter ()
-emitM text = Emitter ($ text)
+emit :: Text -> Emitter ()
+emit = Emitter . tell . pure
+{-# INLINE emit #-}

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

@@ -15,18 +15,23 @@
 {-# LANGUAGE UndecidableSuperClasses #-}
 
 module PlutusCore.Builtin.KnownType
-    ( ReadKnownError
+    ( MakeKnownError
+    , ReadKnownError
     , throwReadKnownErrorWithCause
+    , throwMakeKnownErrorWithCause
     , KnownBuiltinTypeIn
     , KnownBuiltinType
     , readKnownConstant
     , KnownTypeIn (..)
     , KnownType
-    , TestTypesFromTheUniverseAreAllKnown
-    , readKnownSelf
+    , makeKnownRun
     , makeKnownOrFail
+    , readKnownSelf
+    , TestTypesFromTheUniverseAreAllKnown
     ) where
 
+import PlutusPrelude (reoption)
+
 import PlutusCore.Builtin.Emitter
 import PlutusCore.Builtin.HasConstant
 import PlutusCore.Builtin.KnownTypeAst
@@ -38,7 +43,7 @@ import PlutusCore.Evaluation.Result
 import Control.Lens.TH (makeClassyPrisms)
 import Control.Monad.Except
 import Data.Coerce
-import Data.Kind qualified as GHC (Type)
+import Data.DList (DList)
 import Data.String
 import Data.Text (Text)
 import GHC.Exts (inline, oneShot)
@@ -149,14 +154,36 @@ Overall, asking the user to manually unlift from @Opaque val [a]@ is just always
 faster than any kind of fancy encoding.
 -}
 
+-- | The type of errors that 'makeKnown' can return.
+data MakeKnownError
+    = MakeKnownEvaluationFailure
+    deriving (Eq)
+
 -- | The type of errors that 'readKnown' can return.
 data ReadKnownError
     = ReadKnownUnliftingError UnliftingError
     | ReadKnownEvaluationFailure
     deriving (Eq)
 
+makeClassyPrisms ''MakeKnownError
 makeClassyPrisms ''ReadKnownError
 
+instance AsEvaluationFailure MakeKnownError where
+    _EvaluationFailure = _EvaluationFailureVia MakeKnownEvaluationFailure
+
+instance AsUnliftingError ReadKnownError where
+    _UnliftingError = _ReadKnownUnliftingError
+
+instance AsEvaluationFailure ReadKnownError where
+    _EvaluationFailure = _EvaluationFailureVia ReadKnownEvaluationFailure
+
+-- | Throw a @ErrorWithCause ReadKnownError cause@.
+throwMakeKnownErrorWithCause
+    :: (MonadError (ErrorWithCause err cause) m, AsEvaluationFailure err)
+    => ErrorWithCause MakeKnownError cause -> m void
+throwMakeKnownErrorWithCause (ErrorWithCause rkErr cause) = case rkErr of
+    MakeKnownEvaluationFailure -> throwingWithCause _EvaluationFailure () cause
+
 -- | Throw a @ErrorWithCause ReadKnownError cause@.
 throwReadKnownErrorWithCause
     :: (MonadError (ErrorWithCause err cause) m, AsUnliftingError err, AsEvaluationFailure err)
@@ -165,12 +192,6 @@ throwReadKnownErrorWithCause (ErrorWithCause rkErr cause) = case rkErr of
     ReadKnownUnliftingError unlErr -> throwingWithCause _UnliftingError unlErr cause
     ReadKnownEvaluationFailure     -> throwingWithCause _EvaluationFailure () cause
 
-instance AsUnliftingError ReadKnownError where
-    _UnliftingError = _ReadKnownUnliftingError
-
-instance AsEvaluationFailure ReadKnownError where
-    _EvaluationFailure = _EvaluationFailureVia ReadKnownEvaluationFailure
-
 -- See Note [Unlifting values of built-in types].
 -- | Convert a constant embedded into a PLC term to the corresponding Haskell value.
 readKnownConstant
@@ -211,19 +232,14 @@ readKnownConstant mayCause val = asConstant mayCause val >>= oneShot \case
 class uni ~ UniOf val => KnownTypeIn uni val a where
     -- | Convert a Haskell value to the corresponding PLC val.
     -- The inverse of 'readKnown'.
-    makeKnown
-        :: ( MonadError (ErrorWithCause err cause) m, AsEvaluationFailure err
-           )
-        => (Text -> m ()) -> Maybe cause -> a -> m val
+    makeKnown :: Maybe cause -> a -> ExceptT (ErrorWithCause MakeKnownError cause) Emitter val
     default makeKnown
-        :: ( MonadError (ErrorWithCause err cause) m
-           , KnownBuiltinType val a
-           )
-        => (Text -> m ()) -> Maybe cause -> a -> m val
+        :: KnownBuiltinType val a
+        => Maybe cause -> a -> ExceptT (ErrorWithCause MakeKnownError cause) Emitter 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
+    makeKnown _ x = pure . fromConstant . someValue $! x
     {-# INLINE makeKnown #-}
 
     -- | Convert a PLC val to the corresponding Haskell value.
@@ -239,13 +255,25 @@ class uni ~ UniOf val => KnownTypeIn uni val a where
 -- | Haskell types known to exist on the PLC side. See 'KnownTypeIn'.
 type KnownType val a = (KnownTypeAst (UniOf val) a, KnownTypeIn (UniOf val) val a)
 
+makeKnownRun
+    :: KnownTypeIn uni val a
+    => Maybe cause -> a -> (Either (ErrorWithCause MakeKnownError cause) val, DList Text)
+makeKnownRun mayCause = runEmitter . runExceptT . makeKnown mayCause
+{-# INLINE makeKnownRun #-}
+
+-- | Same as 'makeKnown', but allows for neither emitting nor storing the cause of a failure.
+makeKnownOrFail :: KnownTypeIn uni val a => a -> EvaluationResult val
+makeKnownOrFail = reoption . fst . makeKnownRun Nothing
+{-# INLINE makeKnownOrFail #-}
+
 -- | Same as 'readKnown', but the cause of a potential failure is the provided term itself.
 readKnownSelf
     :: ( KnownType val a
        , AsUnliftingError err, AsEvaluationFailure err
        )
     => val -> Either (ErrorWithCause err val) a
 readKnownSelf val = either throwReadKnownErrorWithCause pure $ readKnown (Just val) val
+{-# INLINE readKnownSelf #-}
 
 -- | For providing a 'KnownTypeIn' instance for a built-in type it's enough for that type to satisfy
 -- 'KnownBuiltinTypeIn', hence the definition.
@@ -258,26 +286,9 @@ instance (forall val. KnownBuiltinTypeIn uni val a => KnownTypeIn uni val a) =>
 -- (according to 'Everywhere') from the universe has a 'KnownTypeIn' instance.
 class uni `Everywhere` ImplementedKnownBuiltinTypeIn uni => TestTypesFromTheUniverseAreAllKnown uni
 
--- | A transformer for fitting a monad not carrying the cause of a failure into 'makeKnown'.
-newtype NoCauseT (val :: GHC.Type) m a = NoCauseT
-    { unNoCauseT :: m a
-    } deriving newtype (Functor, Applicative, Monad)
-
-instance (MonadError err m, AsEvaluationFailure err) =>
-            MonadError (ErrorWithCause err val) (NoCauseT val m) where
-    throwError _ = NoCauseT $ throwError evaluationFailure
-    NoCauseT a `catchError` h =
-        NoCauseT $ a `catchError` \err ->
-            unNoCauseT . h $ ErrorWithCause err Nothing
-
--- | Same as 'makeKnown', but allows for neither emitting nor storing the cause of a failure.
--- For example the monad can be simply 'EvaluationResult'.
-makeKnownOrFail :: (KnownType val a, MonadError err m, AsEvaluationFailure err) => a -> m val
-makeKnownOrFail = unNoCauseT . makeKnown (\_ -> pure ()) Nothing
-
 instance KnownTypeIn uni val a => KnownTypeIn uni val (EvaluationResult a) where
-    makeKnown _    mayCause EvaluationFailure     = throwingWithCause _EvaluationFailure () mayCause
-    makeKnown emit mayCause (EvaluationSuccess x) = makeKnown emit mayCause x
+    makeKnown mayCause EvaluationFailure     = throwingWithCause _EvaluationFailure () mayCause
+    makeKnown mayCause (EvaluationSuccess x) = makeKnown mayCause x
     {-# INLINE makeKnown #-}
 
     -- Catching 'EvaluationFailure' here would allow *not* to short-circuit when 'readKnown' fails
@@ -291,22 +302,22 @@ instance KnownTypeIn uni val a => KnownTypeIn uni val (EvaluationResult a) where
     {-# INLINE readKnown #-}
 
 instance KnownTypeIn uni val a => KnownTypeIn uni val (Emitter a) where
-    makeKnown emit mayCause (Emitter k) = k emit >>= makeKnown emit mayCause
+    makeKnown mayCause a = lift a >>= makeKnown mayCause
     {-# INLINE makeKnown #-}
 
     -- TODO: we really should tear 'KnownType' apart into two separate type classes.
     readKnown mayCause _ = throwingWithCause _UnliftingError "Can't unlift an 'Emitter'" mayCause
     {-# INLINE readKnown #-}
 
 instance HasConstantIn uni val => KnownTypeIn uni val (SomeConstant uni rep) where
-    makeKnown _ _ = coerceArg $ pure . fromConstant
+    makeKnown _ = coerceArg $ pure . fromConstant
     {-# INLINE makeKnown #-}
 
     readKnown = coerceVia (\asC mayCause -> fmap SomeConstant . asC mayCause) asConstant
     {-# INLINE readKnown #-}
 
 instance uni ~ UniOf val => KnownTypeIn uni val (Opaque val rep) where
-    makeKnown _ _ = coerceArg pure  -- A faster @pure . Opaque@.
+    makeKnown _ = coerceArg pure  -- A faster @pure . Opaque@.
     {-# INLINE makeKnown #-}
 
     readKnown _ = coerceArg pure  -- A faster @pure . Opaque@.
@@ -316,7 +327,7 @@ instance uni ~ UniOf val => KnownTypeIn uni val (Opaque val rep) where
 
 -- | Coerce the second argument to the result type of the first one. The motivation for this
 -- function is that it's often more annoying to explicitly specify a target type for 'coerce' than
--- to constructor an explicit coercion function, so this combinator can be used in cases like that.
+-- to construct an explicit coercion function, so this combinator can be used in cases like that.
 -- Plus the code reads better, as it becomes clear what and where gets wrapped/unwrapped.
 coerceVia :: Coercible a b => (a -> b) -> a -> b
 coerceVia _ = coerce

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

@@ -619,7 +619,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
     -- Tracing
     toBuiltinMeaning Trace =
         makeBuiltinMeaning
-            (\text a -> a <$ emitM text)
+            (\text a -> a <$ emit text)
             (runCostingFunTwoArguments . paramTrace)
     -- Pairs
     toBuiltinMeaning FstPair =

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

@@ -247,7 +247,7 @@ instance KnownTypeAst DefaultUni Int64 where
 
 -- See Note [Int as Integer].
 instance HasConstantIn DefaultUni term => KnownTypeIn DefaultUni term Int64 where
-    makeKnown emit mayCause = makeKnown emit mayCause . toInteger
+    makeKnown mayCause = makeKnown mayCause . toInteger
     {-# INLINE makeKnown #-}
 
     readKnown mayCause term =
@@ -267,7 +267,7 @@ instance KnownTypeAst DefaultUni Int where
 instance HasConstantIn DefaultUni term => KnownTypeIn DefaultUni term Int where
     -- This could safely just be toInteger, but this way is more explicit and it'll
     -- turn into the same thing anyway.
-    makeKnown emit mayCause = makeKnown emit mayCause . intCastEq @Int @Int64
+    makeKnown mayCause = makeKnown mayCause . intCastEq @Int @Int64
     {-# INLINE makeKnown #-}
 
     readKnown mayCause term = intCastEq @Int64 @Int <$> readKnown mayCause term

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

@@ -67,8 +67,13 @@ evalBuiltinApp
     -> BuiltinRuntime (CkValue uni fun)
     -> CkM uni fun s (CkValue uni fun)
 evalBuiltinApp term runtime@(BuiltinRuntime sch x _) = case sch of
-    RuntimeSchemeResult -> makeKnown emitCkM (Just term) x
-    _                   -> pure $ VBuiltin term runtime
+    RuntimeSchemeResult -> do
+        let (errOrRes, logs) = makeKnownRun (Just term) x
+        emitCkM logs
+        case errOrRes of
+            Left err  -> throwMakeKnownErrorWithCause err
+            Right res -> pure res
+    _ -> pure $ VBuiltin term runtime
 
 ckValueToTerm :: CkValue uni fun -> Term TyName Name uni fun ()
 ckValueToTerm = \case
@@ -108,12 +113,12 @@ instance AsEvaluationFailure CkUserError where
 instance Pretty CkUserError where
     pretty CkEvaluationFailure = "The provided Plutus code called 'error'."
 
-emitCkM :: Text -> CkM uni fun s ()
-emitCkM str = do
+emitCkM :: DList Text -> CkM uni fun s ()
+emitCkM logs = do
     mayLogsRef <- asks ckEnvMayEmitRef
     case mayLogsRef of
         Nothing      -> pure ()
-        Just logsRef -> lift . lift $ modifySTRef logsRef (`DList.snoc` str)
+        Just logsRef -> lift . lift $ modifySTRef logsRef (`DList.append` logs)
 
 type instance UniOf (CkValue uni fun) = uni
 

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

@@ -12,6 +12,7 @@ import Data.Csv qualified as CSV
 import Data.Csv.Builder qualified as CSV
 import Data.DList qualified as DList
 import Data.Fixed
+import Data.Functor
 import Data.STRef (modifySTRef, newSTRef, readSTRef)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
@@ -28,7 +29,7 @@ noEmitter = EmitterMode $ \_ -> pure $ CekEmitterInfo (\_ -> pure ()) (pure memp
 logEmitter :: EmitterMode uni fun
 logEmitter = EmitterMode $ \_ -> do
     logsRef <- newSTRef DList.empty
-    let emitter str = CekM $ modifySTRef logsRef (`DList.snoc` str)
+    let emitter logs = CekM $ modifySTRef logsRef (`DList.append` logs)
     pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef)
 
 -- A wrapper around encoding a record. `cassava` insists on including a trailing newline, which is
@@ -40,11 +41,11 @@ encodeRecord a = T.stripEnd $ T.decodeUtf8 $ BSL.toStrict $ BS.toLazyByteString
 logWithTimeEmitter :: EmitterMode uni fun
 logWithTimeEmitter = EmitterMode $ \_ -> do
     logsRef <- newSTRef DList.empty
-    let emitter str = CekM $ do
+    let emitter logs = CekM $ do
             time <- unsafeIOToST getCurrentTime
             let secs = let MkFixed s = nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds time in s
-            let withTime = encodeRecord (str, secs)
-            modifySTRef logsRef (`DList.snoc` withTime)
+            let withTime = logs <&> \str -> encodeRecord (str, secs)
+            modifySTRef logsRef (`DList.append` withTime)
     pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef)
 
 instance CSV.ToField ExCPU where
@@ -57,8 +58,8 @@ instance CSV.ToField ExMemory where
 logWithBudgetEmitter :: EmitterMode uni fun
 logWithBudgetEmitter = EmitterMode $ \getBudget -> do
     logsRef <- newSTRef DList.empty
-    let emitter str = CekM $ do
+    let emitter logs = CekM $ do
             ExBudget exCpu exMemory <- getBudget
-            let withBudget = encodeRecord (str, exCpu, exMemory)
-            modifySTRef logsRef (`DList.snoc` withBudget)
+            let withBudget = logs <&> \str -> encodeRecord (str, exCpu, exMemory)
+            modifySTRef logsRef (`DList.append` withBudget)
     pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef)

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

@@ -72,6 +72,7 @@ import Control.Monad.Except
 import Control.Monad.ST
 import Control.Monad.ST.Unsafe
 import Data.Array hiding (index)
+import Data.DList (DList)
 import Data.Hashable (Hashable)
 import Data.Kind qualified as GHC
 import Data.Semigroup (stimes)
@@ -284,7 +285,7 @@ defaultSlippage :: Slippage
 defaultSlippage = 200
 
 -- | The CEK machine is parameterized over an emitter function, similar to 'CekBudgetSpender'.
-type CekEmitter uni fun s = Text -> CekM uni fun s ()
+type CekEmitter uni fun s = DList Text -> CekM uni fun s ()
 
 -- | Runtime emitter info, similar to 'ExBudgetInfo'.
 data CekEmitterInfo uni fun s = CekEmitterInfo {
@@ -555,7 +556,11 @@ evalBuiltinApp
 evalBuiltinApp fun term env runtime@(BuiltinRuntime sch x cost) = case sch of
     RuntimeSchemeResult -> do
         spendBudgetCek (BBuiltinApp fun) cost
-        makeKnown ?cekEmitter (Just term) x
+        let !(errOrRes, logs) = makeKnownRun (Just term) x
+        ?cekEmitter logs
+        case errOrRes of
+            Left err  -> throwMakeKnownErrorWithCause err
+            Right res -> pure res
     _ -> pure $ VBuiltin fun term env runtime
 {-# INLINE evalBuiltinApp #-}
 

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/MakeRead.hs

@@ -35,7 +35,7 @@ readMakeHetero
        )
     => a -> EvaluationResult b
 readMakeHetero x = do
-    xTerm <- makeKnownOrFail @(TPLC.Term TyName Name DefaultUni DefaultFun ()) x
+    xTerm <- makeKnownOrFail @_ @(TPLC.Term TyName Name DefaultUni DefaultFun ()) x
     case extractEvaluationResult <$> typecheckReadKnownCek TPLC.defaultCekParameters xTerm of
         Left err          -> error $ "Type error" ++ displayPlcCondensedErrorClassic err
         Right (Left err)  -> error $ "Evaluation error: " ++ show err