[Builtins] Monomorphize 'makeKnown'

IntersectMBO · Jan 2, 2022 · 9f5d839 · 9f5d839
1 parent c8c5183
commit 9f5d839
Show file tree

Hide file tree

Showing 7 changed files with 56 additions and 56 deletions.
diff --git a/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs b/plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs
@@ -141,7 +141,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

diff --git a/plutus-core/plutus-core/src/PlutusCore/Constant/Dynamic/Emit.hs b/plutus-core/plutus-core/src/PlutusCore/Constant/Dynamic/Emit.hs
@@ -1,27 +1,20 @@
-{-# LANGUAGE RankNTypes #-}
-
 module PlutusCore.Constant.Dynamic.Emit
     ( Emitter (..)
-    , emitM
+    , runEmitter
+    , emit
     ) where
 
+import Control.Monad.Writer.Strict
+import Data.DList as DList
 import Data.Text (Text)
+import Data.Tuple
 
--- | 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.
 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 -> (DList Text, a)
+runEmitter = swap . runWriter . unEmitter
 
-emitM :: Text -> Emitter ()
-emitM text = Emitter ($ text)
+emit :: Text -> Emitter ()
+emit text = Emitter . tell $ pure text
diff --git a/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs b/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs
@@ -47,8 +47,9 @@ module PlutusCore.Constant.Typed
     , KnownTypeIn (..)
     , KnownType
     , TestTypesFromTheUniverseAreAllKnown
-    , readKnownSelf
+    , makeKnownRun
     , makeKnownOrFail
+    , readKnownSelf
     , SomeConstant (..)
     , SomeConstantPoly (..)
     ) where
@@ -66,6 +67,7 @@ import PlutusCore.MkPlc hiding (error)
 import PlutusCore.Name
 
 import Control.Monad.Except
+import Data.DList (DList)
 import Data.Functor.Const
 import Data.Kind qualified as GHC (Type)
 import Data.Proxy
@@ -588,18 +590,17 @@ class (uni ~ UniOf term, KnownTypeAst uni a) => KnownTypeIn uni term a where
     -- | Convert a Haskell value to the corresponding PLC term.
     -- The inverse of 'readKnown'.
     makeKnown
-        :: ( MonadError (ErrorWithCause err cause) m, AsEvaluationFailure err
+        :: ( AsEvaluationFailure err
            )
-        => (Text -> m ()) -> Maybe cause -> a -> m term
+        => Maybe cause -> a -> ExceptT (ErrorWithCause err cause) Emitter term
     default makeKnown
-        :: ( MonadError (ErrorWithCause err cause) m
-           , KnownBuiltinType term a
+        :: ( KnownBuiltinType term a
            )
-        => (Text -> m ()) -> Maybe cause -> a -> m term
+        => Maybe cause -> a -> ExceptT (ErrorWithCause err cause) Emitter term
     -- 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 term to the corresponding Haskell value.
@@ -620,6 +621,19 @@ class (uni ~ UniOf term, KnownTypeAst uni a) => KnownTypeIn uni term a where
 -- | Haskell types known to exist on the PLC side. See 'KnownTypeIn'.
 type KnownType term = KnownTypeIn (UniOf term) term
 
+makeKnownRun
+    :: (KnownType term a, AsEvaluationFailure err)
+    => Maybe cause -> a -> (DList Text, Either (ErrorWithCause err cause) term)
+makeKnownRun mayCause = runEmitter . runExceptT . makeKnown mayCause
+{-# INLINE makeKnownRun #-}
+
+-- | 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 term a => a -> EvaluationResult term
+makeKnownOrFail =
+    either (\_ -> EvaluationFailure) EvaluationSuccess . snd . makeKnownRun @_ @_ @() Nothing
+{-# INLINE makeKnownOrFail #-}
+
 -- | Same as 'readKnown', but the cause of a potential failure is the provided term itself.
 readKnownSelf
     :: ( KnownType term a
@@ -639,23 +653,6 @@ instance (forall term. KnownBuiltinTypeIn uni term a => KnownTypeIn uni term 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 (term :: GHC.Type) m a = NoCauseT
-    { unNoCauseT :: m a
-    } deriving newtype (Functor, Applicative, Monad)
-
-instance (MonadError err m, AsEvaluationFailure err) =>
-            MonadError (ErrorWithCause err term) (NoCauseT term 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 term a, MonadError err m, AsEvaluationFailure err) => a -> m term
-makeKnownOrFail = unNoCauseT . makeKnown (\_ -> pure ()) Nothing
-
 instance KnownTypeAst uni a => KnownTypeAst uni (EvaluationResult a) where
     type ToBinds (EvaluationResult a) = ToBinds a
 
@@ -664,8 +661,8 @@ instance KnownTypeAst uni a => KnownTypeAst uni (EvaluationResult a) where
 
 instance (KnownTypeAst uni a, KnownTypeIn uni term a) =>
             KnownTypeIn uni term (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
@@ -685,7 +682,7 @@ instance KnownTypeAst uni a => KnownTypeAst uni (Emitter a) where
     {-# INLINE toTypeAst #-}
 
 instance KnownTypeIn uni term a => KnownTypeIn uni term (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.
@@ -709,7 +706,7 @@ instance (uni ~ uni', KnownTypeAst uni rep) => KnownTypeAst uni (SomeConstant un
 
 instance (HasConstantIn uni term, KnownTypeAst uni rep) =>
             KnownTypeIn uni term (SomeConstant uni rep) where
-    makeKnown _ _ = pure . fromConstant . unSomeConstant
+    makeKnown _ = pure . fromConstant . unSomeConstant
     {-# INLINE makeKnown #-}
 
     readKnown mayCause = fmap SomeConstant . asConstant mayCause
@@ -739,7 +736,7 @@ instance (uni `Contains` f, uni ~ uni', All (KnownTypeAst uni) reps) =>
 instance ( uni `Contains` f, uni ~ uni', All (KnownTypeAst uni) reps
          , HasConstantIn uni term
          ) => KnownTypeIn uni term (SomeConstantPoly uni f reps) where
-    makeKnown _ _ = pure . fromConstant . unSomeConstantPoly
+    makeKnown _ = pure . fromConstant . unSomeConstantPoly
     {-# INLINE makeKnown #-}
 
     readKnown mayCause = fmap SomeConstantPoly . asConstant mayCause
@@ -791,7 +788,7 @@ coerceArg = coerce
 
 instance (term ~ term', uni ~ UniOf term, KnownTypeAst uni rep) =>
             KnownTypeIn uni term (Opaque term' 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@.

diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs
@@ -259,7 +259,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 =

diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs
@@ -213,7 +213,7 @@ instance KnownTypeAst DefaultUni Int where
 
 -- See Note [Int as Integer].
 instance HasConstantIn DefaultUni term => KnownTypeIn DefaultUni term Int where
-    makeKnown emit mayCause = makeKnown emit mayCause . toInteger
+    makeKnown mayCause = makeKnown mayCause . toInteger
     {-# INLINE makeKnown #-}
 
     readKnown mayCause term =

diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs
@@ -68,7 +68,12 @@ evalBuiltinApp
     -> BuiltinRuntime (CkValue uni fun)
     -> CkM uni fun s (CkValue uni fun)
 evalBuiltinApp term runtime@(BuiltinRuntime sch x _) = case sch of
-    TypeSchemeResult _ -> makeKnown emitCkM (Just term) x
+    TypeSchemeResult _ -> do
+        let (logs, errOrRes) = makeKnownRun (Just term) x
+        emitCkM logs
+        case errOrRes of
+            Left err  -> throwError err
+            Right res -> pure res
     _                  -> pure $ VBuiltin term runtime
 
 ckValueToTerm :: CkValue uni fun -> Term TyName Name uni fun ()
@@ -109,12 +114,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
 

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
@@ -71,6 +71,7 @@ import Control.Monad.Except
 import Control.Monad.ST
 import Control.Monad.ST.Unsafe
 import Data.Array
+import Data.Foldable
 import Data.Hashable (Hashable)
 import Data.Kind qualified as GHC
 import Data.Proxy
@@ -542,7 +543,11 @@ evalBuiltinApp
 evalBuiltinApp fun term env runtime@(BuiltinRuntime sch x cost) = case sch of
     TypeSchemeResult _ -> do
         spendBudgetCek (BBuiltinApp fun) cost
-        makeKnown ?cekEmitter (Just term) x
+        let (logs, errOrRes) = makeKnownRun (Just term) x
+        traverse_ ?cekEmitter logs
+        case errOrRes of
+            Left err  -> throwError err
+            Right res -> pure res
     _ -> pure $ VBuiltin fun term env runtime
 {-# INLINE evalBuiltinApp #-}