Recommit

IntersectMBO · effectfully · Dec 26, 2021 · Dec 7, 2021 · Dec 7, 2021 · Dec 7, 2021
commit e0da3179a9bd46096b1c69d1f4792f598b756e19
diff --git 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
@@ -483,10 +486,12 @@ class KnownTypeAst uni (a :: k) where
     type ToBinds (a :: k) :: [GADT.Some TyNameRep]
     type ToBinds _ = '[]
 
+    -- See Note [Performance of KnownTypeIn instances]
     -- | The type representing @a@ used on the PLC side.
     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 +526,46 @@ 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.
+
+Similarly, we inline implementations of 'knownTypeAst' 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.
+-}
+
+-- See Note [Performance of KnownTypeIn instances]
+-- | 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
+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 +591,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 +604,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 +651,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 +667,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 +696,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 +725,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 +749,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 +768,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 . unOpaque@.
+    {-# 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
@@ -132,6 +132,7 @@ nonZeroArg :: (Integer -> Integer -> Integer) -> Integer -> Integer -> Evaluatio
 nonZeroArg _ _ 0 = EvaluationFailure
 nonZeroArg f x y = EvaluationSuccess $ f x y
 
+-- We need to inline local functions, so that more efficient Core is generated.
 instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
     type CostingPart uni DefaultFun = BuiltinCostModel
     -- Integers
@@ -271,6 +272,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 +282,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 +295,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
             pure $ case xs of
                 []    -> a
                 _ : _ -> b
+          {-# INLINE choosePlc #-}
     toBuiltinMeaning MkCons =
         makeBuiltinMeaning
             consPlc
@@ -313,6 +317,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 +328,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 +341,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 +351,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
@@ -2,6 +2,7 @@
 
 {-# OPTIONS -fno-warn-missing-pattern-synonym-signatures #-}
 
+{-# LANGUAGE BlockArguments        #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE GADTs                 #-}
@@ -32,11 +33,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
 import Universe as Export
 
 {- Note [PLC types and universes]
@@ -204,15 +205,20 @@ being "internal".
 
 instance KnownTypeAst DefaultUni Int where
     toTypeAst _ = toTypeAst $ Proxy @Integer
+    {-# INLINE toTypeAst #-}
 
 -- See Note [Int as Integer].
+-- See Note [Performance of KnownTypeIn instances]
 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 =
+        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

diff --git a/plutus-core/plutus-core/test/Names/Spec.hs b/plutus-core/plutus-core/test/Names/Spec.hs
@@ -53,7 +53,8 @@ test_mangle = testProperty "equality does not survive mangling" . property $ do
 prop_equalityFor
     :: program ~ Program TyName Name DefaultUni DefaultFun ()
     => (program -> Quote program) -> Property
-prop_equalityFor ren = property $ do
+-- We have some tests that are supposed to fail, hence running up to 1000 tests to make sure they do.
+prop_equalityFor ren = withTests 1000 . property $ do
     prog <- forAllPretty $ runAstGen genProgram
     let progRen = runQuote $ ren prog
     Hedgehog.assert $ progRen == prog && prog == progRen