diff --git a/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs b/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs index 9c1ee35a6b1..835e69fa81e 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs @@ -2,6 +2,7 @@ -- See the @plutus/plutus-core/docs/Constant application.md@ -- article for how this emerged. +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -42,6 +43,7 @@ module PlutusCore.Constant.Typed , ListToBinds , KnownBuiltinTypeIn , KnownBuiltinType + , readKnownConstant , KnownTypeIn (..) , KnownType , TestTypesFromTheUniverseAreAllKnown @@ -72,6 +74,7 @@ import Data.Some.GADT qualified as GADT import Data.String import Data.Text (Text) import Data.Text qualified as Text +import GHC.Exts (inline, oneShot) import GHC.Ix import GHC.TypeLits import Universe @@ -487,6 +490,7 @@ class KnownTypeAst uni (a :: k) where toTypeAst :: proxy a -> Type TyName uni () default toTypeAst :: KnownBuiltinTypeAst uni a => proxy a -> Type TyName uni () toTypeAst _ = mkTyBuiltin @_ @a () + {-# INLINE toTypeAst #-} -- | Delete all @x@s from a list. type family Delete x xs :: [a] where @@ -521,6 +525,56 @@ instance (HasConstantIn uni term, GShow uni, GEq uni, uni `Contains` a) => -- | A constraint for \"@a@ is a 'KnownType' by means of being included in @UniOf term@\". type KnownBuiltinType term a = KnownBuiltinTypeIn (UniOf term) term a +{- Note [Performance of KnownTypeIn instances] +Even though we don't use 'makeKnown' and 'readKnown' directly over concrete types, it's still +beneficial to inline them, because otherwise GHC compiles each of them to two definitions +(one calling the other) for some reason. So always add an @INLINE@ pragma to all definitions +of 'makeKnown' and 'readKnown' unless you have a specific reason not to. + +Similarly, we inline implementations of 'toTypeAst' just to get tidier Core. + +Some 'readKnown' implementations require inserting a call to 'oneShot'. E.g. if 'oneShot' is not +used in 'readKnownConstant' then 'GHC pulls @gshow uniExp@ out of the 'Nothing' branch, thus +allocating a thunk of type 'String' that is completely redundant whenever there's no error, +which is the majority of cases. And putting 'oneShot' as the outermost call results in +worse Core. + +Any change to an instance of 'KnownTypeIn', even completely trivial, requires looking into the +generated Core, since compilation of these instances is extremely brittle optimization-wise. + +Things to watch out for are unnecessary sharing (for example, a @let@ appearing outside of a @case@ +allocates a thunk and if that thunk is not referenced inside of one of the branches, then it's +wasteful, especially when it's not referenced in the most commonly chosen branch) and type class +methods not being extracted from the dictionary and used directly instead (i.e. if you see +multiple @pure@ and @>>=@ in the code, that's not good). Note that neither @let@ nor @>>=@ are bad +in general, we certainly do need to allocate thunks occasionally, it's just that when it comes to +builtins this is rarely the case as most of the time we want aggressive inlining and specialization +and the "just compute the damn thing" behavior. +-} + +-- | Convert a constant embedded into a PLC term to the corresponding Haskell value. +readKnownConstant + :: forall term a err cause m. + ( MonadError (ErrorWithCause err cause) m, AsUnliftingError err + , KnownBuiltinType term a + ) + => Maybe cause -> term -> m a +-- See Note [Performance of KnownTypeIn instances]. +readKnownConstant mayCause term = asConstant mayCause term >>= oneShot \case + Some (ValueOf uniAct x) -> do + let uniExp = knownUni @_ @(UniOf term) @a + case uniAct `geq` uniExp of + Just Refl -> pure x + Nothing -> do + let err = fromString $ concat + [ "Type mismatch: " + , "expected: " ++ gshow uniExp + , "; actual: " ++ gshow uniAct + ] + throwingWithCause _UnliftingError err mayCause +{-# INLINE readKnownConstant #-} + +-- See Note [Performance of KnownTypeIn instances]. -- We use @default@ for providing instances for built-in types instead of @DerivingVia@, because -- the latter breaks on @m a@ (and for brevity). -- | Haskell types known to exist on the PLC side. @@ -546,6 +600,7 @@ class (uni ~ UniOf term, KnownTypeAst uni a) => KnownTypeIn uni term a where -- 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 #-} -- | Convert a PLC term to the corresponding Haskell value. -- The inverse of 'makeKnown'. @@ -558,18 +613,9 @@ class (uni ~ UniOf term, KnownTypeAst uni a) => KnownTypeIn uni term a where , KnownBuiltinType term a ) => Maybe cause -> term -> m a - readKnown mayCause term = asConstant mayCause term >>= \case - Some (ValueOf uniAct x) -> do - let uniExp = knownUni @_ @uni @a - case uniAct `geq` uniExp of - Just Refl -> pure x - Nothing -> do - let err = fromString $ concat - [ "Type mismatch: " - , "expected: " ++ gshow uniExp - , "; actual: " ++ gshow uniAct - ] - throwingWithCause _UnliftingError err mayCause + -- If 'inline' is not used, proper inlining does not happen for whatever reason. + readKnown = inline readKnownConstant + {-# INLINE readKnown #-} -- | Haskell types known to exist on the PLC side. See 'KnownTypeIn'. type KnownType term = KnownTypeIn (UniOf term) term @@ -614,11 +660,13 @@ instance KnownTypeAst uni a => KnownTypeAst uni (EvaluationResult a) where type ToBinds (EvaluationResult a) = ToBinds a toTypeAst _ = toTypeAst $ Proxy @a + {-# INLINE toTypeAst #-} 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 + {-# INLINE makeKnown #-} -- Catching 'EvaluationFailure' here would allow *not* to short-circuit when 'readKnown' fails -- to read a Haskell value of type @a@. Instead, in the denotation of the builtin function @@ -628,16 +676,21 @@ instance (KnownTypeAst uni a, KnownTypeIn uni term a) => -- We forbid this, because it complicates code and isn't supported by evaluation engines anyway. readKnown mayCause _ = throwingWithCause _UnliftingError "Error catching is not supported" mayCause + {-# INLINE readKnown #-} instance KnownTypeAst uni a => KnownTypeAst uni (Emitter a) where type ToBinds (Emitter a) = ToBinds a toTypeAst _ = toTypeAst $ Proxy @a + {-# INLINE toTypeAst #-} instance KnownTypeIn uni term a => KnownTypeIn uni term (Emitter a) where makeKnown emit mayCause (Emitter k) = k emit >>= makeKnown emit 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 #-} -- | For unlifting from the 'Constant' constructor when the stored value is of a monomorphic -- built-in type @@ -652,11 +705,15 @@ instance (uni ~ uni', KnownTypeAst uni rep) => KnownTypeAst uni (SomeConstant un type ToBinds (SomeConstant _ rep) = ToBinds rep toTypeAst _ = toTypeAst $ Proxy @rep + {-# INLINE toTypeAst #-} instance (HasConstantIn uni term, KnownTypeAst uni rep) => KnownTypeIn uni term (SomeConstant uni rep) where makeKnown _ _ = pure . fromConstant . unSomeConstant + {-# INLINE makeKnown #-} + readKnown mayCause = fmap SomeConstant . asConstant mayCause + {-# INLINE readKnown #-} -- | For unlifting from the 'Constant' constructor when the stored value is of a polymorphic -- built-in type. @@ -677,12 +734,16 @@ instance (uni `Contains` f, uni ~ uni', All (KnownTypeAst uni) reps) => (Proxy @(All (KnownTypeAst uni) reps)) (\(_ :: Proxy (rep ': _reps')) rs -> toTypeAst (Proxy @rep) : rs) [] + {-# INLINE toTypeAst #-} 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 + {-# INLINE makeKnown #-} + readKnown mayCause = fmap SomeConstantPoly . asConstant mayCause + {-# INLINE readKnown #-} toTyNameAst :: forall text uniq. (KnownSymbol text, KnownNat uniq) @@ -697,11 +758,13 @@ instance (var ~ 'TyNameRep text uniq, KnownSymbol text, KnownNat uniq) => type ToBinds (TyVarRep var) = '[ 'GADT.Some var ] toTypeAst _ = TyVar () . toTyNameAst $ Proxy @('TyNameRep text uniq) + {-# INLINE toTypeAst #-} instance (KnownTypeAst uni fun, KnownTypeAst uni arg) => KnownTypeAst uni (TyAppRep fun arg) where type ToBinds (TyAppRep fun arg) = Merge (ToBinds fun) (ToBinds arg) toTypeAst _ = TyApp () (toTypeAst $ Proxy @fun) (toTypeAst $ Proxy @arg) + {-# INLINE toTypeAst #-} instance ( var ~ 'TyNameRep @kind text uniq, KnownSymbol text, KnownNat uniq @@ -714,16 +777,25 @@ instance (toTyNameAst $ Proxy @('TyNameRep text uniq)) (runSingKind $ knownKind @kind) (toTypeAst $ Proxy @a) + {-# INLINE toTypeAst #-} instance KnownTypeAst uni rep => KnownTypeAst uni (Opaque term rep) where type ToBinds (Opaque _ rep) = ToBinds rep toTypeAst _ = toTypeAst $ Proxy @rep + {-# INLINE toTypeAst #-} + +coerceArg :: Coercible a b => (a -> r) -> b -> r +coerceArg = coerce +{-# INLINE coerceArg #-} instance (term ~ term', uni ~ UniOf term, KnownTypeAst uni rep) => KnownTypeIn uni term (Opaque term' rep) where - makeKnown _ _ = pure . unOpaque - readKnown _ = pure . Opaque + makeKnown _ _ = coerceArg pure -- A faster @pure . Opaque@. + {-# INLINE makeKnown #-} + + readKnown _ = coerceArg pure -- A faster @pure . Opaque@. + {-# INLINE readKnown #-} -- Custom type errors to guide the programmer adding a new built-in function. -- We cover a lot of cases here, but some are missing, for example we do not attempt to detect diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 04e1d102db9..fb7ca5f6453 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -271,6 +271,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where fstPlc (SomeConstantPoly (Some (ValueOf uniPairAB xy))) = do DefaultUniPair uniA _ <- pure uniPairAB pure . fromConstant . someValueOf uniA $ fst xy + {-# INLINE fstPlc #-} toBuiltinMeaning SndPair = makeBuiltinMeaning sndPlc @@ -280,6 +281,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where sndPlc (SomeConstantPoly (Some (ValueOf uniPairAB xy))) = do DefaultUniPair _ uniB <- pure uniPairAB pure . fromConstant . someValueOf uniB $ snd xy + {-# INLINE sndPlc #-} -- Lists toBuiltinMeaning ChooseList = makeBuiltinMeaning @@ -292,6 +294,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where pure $ case xs of [] -> a _ : _ -> b + {-# INLINE choosePlc #-} toBuiltinMeaning MkCons = makeBuiltinMeaning consPlc @@ -313,6 +316,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where -- https://github.com/input-output-hk/plutus/pull/3035 Just Refl <- pure $ uniA `geq` uniA' pure . fromConstant . someValueOf uniListA $ x : xs + {-# INLINE consPlc #-} toBuiltinMeaning HeadList = makeBuiltinMeaning headPlc @@ -323,6 +327,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where DefaultUniList uniA <- pure uniListA x : _ <- pure xs pure . fromConstant $ someValueOf uniA x + {-# INLINE headPlc #-} toBuiltinMeaning TailList = makeBuiltinMeaning tailPlc @@ -335,6 +340,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where DefaultUniList _ <- pure uniListA _ : xs' <- pure xs pure . fromConstant $ someValueOf uniListA xs' + {-# INLINE tailPlc #-} toBuiltinMeaning NullList = makeBuiltinMeaning nullPlc @@ -344,6 +350,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where nullPlc (SomeConstantPoly (Some (ValueOf uniListA xs))) = do DefaultUniList _ <- pure uniListA pure $ null xs + {-# INLINE nullPlc #-} -- Data toBuiltinMeaning ChooseData = diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs index da71e4eb8ce..b59507fb347 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs @@ -2,6 +2,7 @@ {-# OPTIONS -fno-warn-missing-pattern-synonym-signatures #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -18,6 +19,11 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- effectfully: to the best of my experimentation, -O2 here improves performance, however by +-- inspecting GHC Core I was only able to see a difference in how the 'KnownTypeIn' instance for +-- 'Int' is compiled (one more call is inlined with -O2). This needs to be investigated. +{-# OPTIONS_GHC -O2 #-} + module PlutusCore.Default.Universe ( DefaultUni (..) , pattern DefaultUniList @@ -32,11 +38,11 @@ import PlutusCore.Evaluation.Result import PlutusCore.Parsable import Control.Applicative -import Control.Monad import Data.ByteString qualified as BS import Data.Foldable import Data.Proxy import Data.Text qualified as Text +import GHC.Exts (inline, oneShot) import Universe as Export {- Note [PLC types and universes] @@ -208,11 +214,17 @@ 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 - readKnown mayCause term = do - i :: Integer <- readKnown mayCause term - unless (fromIntegral (minBound :: Int) <= i && i <= fromIntegral (maxBound :: Int)) $ - throwingWithCause _EvaluationFailure () mayCause - pure $ fromIntegral i + {-# INLINE makeKnown #-} + + readKnown mayCause term = + -- See Note [Performance of KnownTypeIn instances]. + -- Funnily, we don't need 'inline' here, unlike in the default implementation of 'readKnown' + -- (go figure why). + inline readKnownConstant mayCause term >>= oneShot \(i :: Integer) -> + if fromIntegral (minBound :: Int) <= i && i <= fromIntegral (maxBound :: Int) + then pure $ fromIntegral i + else throwingWithCause _EvaluationFailure () mayCause + {-# INLINE readKnown #-} {- Note [Stable encoding of tags] 'encodeUni' and 'decodeUni' are used for serialisation and deserialisation of types from the