From 381172295c0b0a8f17450b8377ee5905f03d294b Mon Sep 17 00:00:00 2001 From: Ana Pantilie <45069775+ana-pantilie@users.noreply.github.com> Date: Mon, 25 Mar 2024 09:16:04 +0200 Subject: [PATCH] Add simple force-delay tests + clean-up (#5849) Signed-off-by: Ana Pantilie --- .../plutus-core/src/PlutusCore/Name/Unique.hs | 9 ++--- .../src/PlutusCore/Name/UniqueMap.hs | 36 ++++++++----------- .../src/PlutusCore/Name/UniqueSet.hs | 3 +- .../src/PlutusIR/Transform/Inline/Utils.hs | 2 +- .../src/PlutusIR/Transform/LetFloatOut.hs | 2 +- .../UntypedPlutusCore/Transform/ForceDelay.hs | 9 +++-- .../test/Transform/Simplify.hs | 14 ++++++++ .../Transform/forceDelayNoApps.uplc.golden | 1 + .../forceDelayNoAppsLayered.uplc.golden | 1 + 9 files changed, 43 insertions(+), 34 deletions(-) create mode 100644 plutus-core/untyped-plutus-core/test/Transform/forceDelayNoApps.uplc.golden create mode 100644 plutus-core/untyped-plutus-core/test/Transform/forceDelayNoAppsLayered.uplc.golden diff --git a/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs b/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs index 383073ae2c9..fc2bcc5809d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs @@ -6,17 +6,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{- | Defines the 'Name' type used for identifiers in Plutus Core together with a technique - to minimise the cost of 'Name' comparisons. - - A 'Name' is a piece of text used to identify a variable inside the Plutus Core languages. +{- | A 'Name' is a datatype used to identify a variable inside the Plutus Core languages. Name comparisons are a fundamental part of the domain logic, and comparing 'Text' directly is inefficient. As a solution to this problem, we provide the 'Unique' type which is an integer associated to the 'Name', unique to each instantiation of the type. We can, therefore, compare the integers instead, which is obviously much more cost-effective. - We distinguish between the names of term variables and type variables by defining wrappers - over 'Name': 'TermName' and 'TyName'. Since the code we usually write is polymorphic in the + We distinguish between the names of term variables and type variables by defining the + 'TyName' wrapper over 'Name'. Since the code we usually write is polymorphic in the name type, we want to be able to define a class of names which have an associated 'Unique'. This class is 'HasUnique', see the definition below. -} diff --git a/plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs b/plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs index d1d72256fc6..9dcfc43a918 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs @@ -6,20 +6,18 @@ module PlutusCore.Name.UniqueMap ( UniqueMap (..), -insertByUnique, -insertByName, -singletonByName, -insertNamed, -insertByNameIndex, -fromFoldable, -fromUniques, -fromNames, -lookupUnique, -lookupName, -restrictKeys, -foldr, -lookupNameIndex, -isEmpty, + insertByUnique, + insertByName, + singletonByName, + insertNamed, + insertByNameIndex, + fromFoldable, + fromUniques, + fromNames, + lookupUnique, + lookupName, + restrictKeys, + lookupNameIndex, ) where import Control.Lens (view) @@ -38,7 +36,8 @@ import Prelude hiding (foldr) newtype UniqueMap unique a = UniqueMap { unUniqueMap :: IM.IntMap a } - deriving newtype (Show, Eq, Semigroup, Monoid, Functor) + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid, Functor, Foldable) -- | Insert a value @a@ by a @unique@. insertByUnique :: @@ -106,9 +105,6 @@ restrictKeys :: UniqueMap unique v -> UniqueSet unique -> UniqueMap unique v restrictKeys (UniqueMap m) (UniqueSet s) = UniqueMap $ IM.restrictKeys m s -foldr :: (a -> b -> b) -> b -> UniqueMap unique a -> b -foldr f unit (UniqueMap m) = IM.foldr f unit m - {- | Look up a value by the index of the unique of a name. Unlike 'lookupUnique' and 'lookupName', this function does not provide any static guarantees, so you can for example look up a type-level name in a map from term-level uniques. @@ -119,7 +115,3 @@ lookupNameIndex :: UniqueMap unique2 a -> Maybe a lookupNameIndex = lookupUnique . coerce . view unique - -{-# INLINE isEmpty #-} -isEmpty :: UniqueMap unique a -> Bool -isEmpty (UniqueMap m) = IM.null m diff --git a/plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs b/plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs index febcef347b5..5a32787e0ea 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs @@ -34,7 +34,8 @@ import PlutusCore.Name.Unique (HasUnique (..), Unique (Unique)) newtype UniqueSet unique = UniqueSet { unUniqueSet :: IS.IntSet } - deriving newtype (Show, Eq, Semigroup, Monoid) + deriving stock (Show, Eq) + deriving newtype (Semigroup, Monoid) -- | Insert a @unique@. insertByUnique :: diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs index 4cbe93aa376..45720564ff2 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs @@ -158,7 +158,7 @@ lookupType tn s = UMap.lookupName tn $ s ^. typeSubst . unTypeSubst -- | Check if the type substitution is empty. isTypeSubstEmpty :: InlinerState tyname name uni fun ann -> Bool -isTypeSubstEmpty (InlinerState _ (TypeSubst tyEnv) _) = UMap.isEmpty tyEnv +isTypeSubstEmpty (InlinerState _ (TypeSubst tyEnv) _) = null tyEnv -- | Insert the unprocessed type variable into the type substitution. extendType diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs index 4b10d047356..74f42fff6bc 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs @@ -434,7 +434,7 @@ floatTerm binfo t = -- HELPERS maxPos :: PLC.UniqueMap k Pos -> Pos -maxPos = UMap.foldr max topPos +maxPos = foldr max topPos withDepth :: (r ~ MarkCtx tyname name uni fun a2, MonadReader r m) => (Depth -> Depth) -> m a -> m a diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs index 4c5ac9d17e2..a59a7b6cec2 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs @@ -1,4 +1,6 @@ -{- | The 'ForceDelay' optimisation pushes 'Force' inside its direct 'Apply' subterms, +{- Note [Cancelling interleaved Force-Delay pairs] + + The 'ForceDelay' optimisation pushes 'Force' inside its direct 'Apply' subterms, removing any 'Delay' at the top of the body of the underlying lambda abstraction. For example, @force [(\x -> delay b) a]@ is transformed into @[(\x -> b) a]@. We also consider the case where the 'Force' is applied directly to the 'Delay' as @@ -138,7 +140,6 @@ import UntypedPlutusCore.Core import Control.Lens (transformOf) import Control.Monad (guard) import Data.Foldable (foldl') -import Data.Maybe (fromMaybe) {- | Traverses the term, for each node applying the optimisation detailed above. For implementation details see 'optimisationProcedure'. @@ -153,7 +154,9 @@ processTerm :: Term name uni fun a -> Term name uni fun a processTerm = \case Force _ (Delay _ t) -> t original@(Force _ subTerm) -> - fromMaybe original (optimisationProcedure subTerm) + case optimisationProcedure subTerm of + Just result -> result + Nothing -> original t -> t {- | Converts the subterm of a 'Force' into specialised types for representing diff --git a/plutus-core/untyped-plutus-core/test/Transform/Simplify.hs b/plutus-core/untyped-plutus-core/test/Transform/Simplify.hs index 74dd244b76d..bfab39219da 100644 --- a/plutus-core/untyped-plutus-core/test/Transform/Simplify.hs +++ b/plutus-core/untyped-plutus-core/test/Transform/Simplify.hs @@ -227,6 +227,18 @@ multiApp = runQuote $ do app = mkIterAppNoAnn lam [mkConstant @Integer () 1, mkConstant @Integer () 2, mkConstant @Integer () 3] pure app +forceDelayNoApps :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceDelayNoApps = runQuote $ do + let one = mkConstant @Integer () 1 + term = Force () $ Delay () $ Force () $ Delay () $ Force () $ Delay () one + pure term + +forceDelayNoAppsLayered :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceDelayNoAppsLayered = runQuote $ do + let one = mkConstant @Integer () 1 + term = Force () $ Force () $ Force () $ Delay () $ Delay () $ Delay () one + pure term + -- | The UPLC term in this test should come from the following TPLC term after erasing its types: -- > (/\(p :: *) -> \(x : p) -> /\(q :: *) -> \(y : q) -> /\(r :: *) -> \(z : r) -> z) Int 1 Int 2 Int 3 -- This case is simple in the sense that each type abstraction is followed by a single term abstraction. @@ -442,6 +454,8 @@ test_simplify = , goldenVsSimplified "inlineImpure3" inlineImpure3 , goldenVsSimplified "inlineImpure4" inlineImpure4 , goldenVsSimplified "multiApp" multiApp + , goldenVsSimplified "forceDelayNoApps" forceDelayNoApps + , goldenVsSimplified "forceDelayNoAppsLayered" forceDelayNoAppsLayered , goldenVsSimplified "forceDelaySimple" forceDelaySimple , goldenVsSimplified "forceDelayMultiApply" forceDelayMultiApply , goldenVsSimplified "forceDelayMultiForce" forceDelayMultiForce diff --git a/plutus-core/untyped-plutus-core/test/Transform/forceDelayNoApps.uplc.golden b/plutus-core/untyped-plutus-core/test/Transform/forceDelayNoApps.uplc.golden new file mode 100644 index 00000000000..56a6051ca2b --- /dev/null +++ b/plutus-core/untyped-plutus-core/test/Transform/forceDelayNoApps.uplc.golden @@ -0,0 +1 @@ +1 \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Transform/forceDelayNoAppsLayered.uplc.golden b/plutus-core/untyped-plutus-core/test/Transform/forceDelayNoAppsLayered.uplc.golden new file mode 100644 index 00000000000..56a6051ca2b --- /dev/null +++ b/plutus-core/untyped-plutus-core/test/Transform/forceDelayNoAppsLayered.uplc.golden @@ -0,0 +1 @@ +1 \ No newline at end of file