diff --git a/plutus-core/changelog.d/20231101_201807_bezirg_rewrite_more.md b/plutus-core/changelog.d/20231101_201807_bezirg_rewrite_more.md new file mode 100644 index 00000000000..f6f6d1a6821 --- /dev/null +++ b/plutus-core/changelog.d/20231101_201807_bezirg_rewrite_more.md @@ -0,0 +1,3 @@ +### Added + +- A PIR rewrite rule for optimizing ""(unconstr . constrdata)" diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 845dd58be20..5ca5d9305ed 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -532,6 +532,8 @@ library plutus-ir PlutusIR.Compiler.Lower PlutusIR.Compiler.Recursion PlutusIR.Normalize + PlutusIR.Transform.RewriteRules.Common + PlutusIR.Transform.RewriteRules.UnConstrConstrData build-depends: , algebraic-graphs >=0.7 @@ -607,7 +609,6 @@ test-suite plutus-ir-test build-depends: , base >=4.9 && <5 , containers - , data-default-class , flat ^>=0.6 , hashable , hedgehog diff --git a/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs b/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs index 01328c85e54..65b0c7cf7c6 100644 --- a/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs +++ b/plutus-core/plutus-core/src/PlutusCore/MkPlc.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -52,6 +53,7 @@ module PlutusCore.MkPlc , mkIterTyApp , mkIterTyAppNoAnn , mkIterKindArrow + , mkFreshTermLet ) where import PlutusPrelude @@ -59,6 +61,8 @@ import Prelude hiding (error) import PlutusCore.Builtin import PlutusCore.Core +import PlutusCore.Name +import PlutusCore.Quote import Data.Word import Universe @@ -317,3 +321,16 @@ mkIterKindArrow -> Kind ann -> Kind ann mkIterKindArrow ann kinds target = foldr (KindArrow ann) target kinds + +{- | A helper to create a single, fresh strict binding; It returns the fresh bound `Var`iable and +a function `Term -> Term`, expecting an "in-Term" to form a let-expression. +-} +mkFreshTermLet :: (MonadQuote m, TermLike t tyname Name uni fun, Monoid a) + => Type tyname uni a -- ^ the type of binding + -> t a -- ^ the term bound to the fresh variable + -> m (t a, t a -> t a) -- ^ the fresh Var and a function that takes an "in" term to construct the Let +mkFreshTermLet aT a = do + -- I wish this was less constrained to Name + genName <- freshName "generated" + pure (var mempty genName, termLet mempty (Def (VarDecl mempty genName aT) a)) + diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler.hs index 7e8fa5b1d5b..5b6ff93e759 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler.hs @@ -16,7 +16,7 @@ module PlutusIR.Compiler ( Provenance (..), DatatypeComponent (..), noProvenance, - CompilationOpts, + CompilationOpts (..), coOptimize, coPedantic, coVerbose, @@ -28,6 +28,7 @@ module PlutusIR.Compiler ( coDoSimplifierEvaluateBuiltins, coDoSimplifierStrictifyBindings, coDoSimplifierRewrite, + coDoSimplifierKnownCon, coInlineHints, coProfile, coRelaxedFloatin, diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Provenance.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Provenance.hs index b13b277ce8f..3b553244318 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Provenance.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Provenance.hs @@ -37,6 +37,9 @@ instance Ord a => Semigroup (Provenance a) where MultipleSources ps -> ps other -> S.singleton other +instance Ord a => Monoid (Provenance a) where + mempty = noProvenance + -- workaround, use a smart constructor to replace the older NoProvenance data constructor noProvenance :: Provenance a noProvenance = MultipleSources S.empty diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs index 161b6d5aa07..9054a9ed1c1 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs @@ -104,7 +104,7 @@ makeLenses ''CompilationOpts defaultCompilationOpts :: CompilationOpts a defaultCompilationOpts = CompilationOpts - { _coOptimize = True + { _coOptimize = True -- synonymous with max-simplifier-iterations=0 , _coPedantic = False , _coVerbose = False , _coDebug = False diff --git a/plutus-core/plutus-ir/src/PlutusIR/Subst.hs b/plutus-core/plutus-ir/src/PlutusIR/Subst.hs index a605605bbd5..e842dbf0daa 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Subst.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Subst.hs @@ -129,6 +129,7 @@ funRes f = \case TyFun a dom cod -> TyFun a dom <$> funRes f cod t -> f t +-- TODO: these could be Traversals -- | Get all the term variables in a term. vTerm :: Fold (Term tyname name uni fun ann) name vTerm = termSubtermsDeep . termVars diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs index e69eddbd85f..96cfd3e2a4f 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules.hs @@ -15,14 +15,19 @@ import PlutusCore.Quote import PlutusIR as PIR import PlutusIR.Analysis.VarInfo import PlutusIR.Transform.RewriteRules.CommuteFnWithConst +import PlutusIR.Transform.RewriteRules.UnConstrConstrData import PlutusPrelude import Control.Lens --- | Rewrite a `Term` using the given `RewriteRules` (similar to functions of Term -> Term) --- Normally the rewrite rules are configured at entrypoint time of the compiler. -rewriteWith :: ( Semigroup a, t ~ Term tyname name uni fun a +{- | Rewrite a `Term` using the given `RewriteRules` (similar to functions of Term -> Term) +Normally the rewrite rules are configured at entrypoint time of the compiler. + +It goes without saying that the supplied rewrite rules must be type-preserving. +MAYBE: enforce this with a `through typeCheckTerm`? +-} +rewriteWith :: ( Monoid a, t ~ Term tyname Name uni fun a , HasUniques t , MonadQuote m ) @@ -39,19 +44,19 @@ rewriteWith (RewriteRules rules) t = -- | A bundle of composed `RewriteRules`, to be passed at entrypoint of the compiler. newtype RewriteRules uni fun = RewriteRules { - unRewriteRules :: forall tyname name m a - . (MonadQuote m, Semigroup a) - => VarsInfo tyname name uni a - -> PIR.Term tyname name uni fun a - -> m (PIR.Term tyname name uni fun a) + unRewriteRules :: forall tyname m a + . (MonadQuote m, Monoid a) + => VarsInfo tyname Name uni a + -> PIR.Term tyname Name uni fun a + -> m (PIR.Term tyname Name uni fun a) } -- | The rules for the Default Universe/Builtin. defaultUniRewriteRules :: RewriteRules DefaultUni DefaultFun -defaultUniRewriteRules = RewriteRules $ \ _vinfo -> +defaultUniRewriteRules = RewriteRules $ \ vinfo -> -- The rules are composed from left to right. pure . commuteFnWithConst - -- e.g. >=> a follow-up rewrite rule + >=> unConstrConstrData def vinfo instance Default (RewriteRules DefaultUni DefaultFun) where def = defaultUniRewriteRules diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Common.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Common.hs new file mode 100644 index 00000000000..0694f3be1bc --- /dev/null +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/Common.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} +module PlutusIR.Transform.RewriteRules.Common + ( seqA + , seqP + , mkFreshTermLet -- from MkPlc + , pattern A + , pattern B + , pattern I + ) where + +import PlutusCore.Builtin +import PlutusCore.Quote +import PlutusIR +import PlutusIR.Analysis.Builtins +import PlutusIR.Analysis.VarInfo +import PlutusIR.MkPir +import PlutusIR.Purity + +{- | A wrapper that can be more easily turned into an infix operator. + +e.g. `infixr 5 (***) = seqA binfo vInfo` +-} +seqA :: (MonadQuote m, Monoid a, ToBuiltinMeaning uni fun) + => BuiltinsInfo uni fun + -> VarsInfo tyname Name uni a + -> (Type tyname uni a, Term tyname Name uni fun a) + -> m (Term tyname Name uni fun a) + -> m (Term tyname Name uni fun a) +seqA binfo vinfo (a,aT) y = seqOpt binfo vinfo a aT <*> y + + +{- | Another "infix" wrapper where second operand is a Haskell pure value. + +e.g. `infixr 5 (***) = seqP binfo vInfo` +-} +seqP :: (MonadQuote m, Monoid a, ToBuiltinMeaning uni fun) + => BuiltinsInfo uni fun + -> VarsInfo tyname Name uni a + -> (Type tyname uni a, Term tyname Name uni fun a) + -> Term tyname Name uni fun a + -> m (Term tyname Name uni fun a) +seqP binfo vinfo p y = seqA binfo vinfo p (pure y) + +-- | An optimized version to omit call to `seq` if left operand `isPure`. +seqOpt :: ( MonadQuote m + , Monoid a + , ToBuiltinMeaning uni fun + , t ~ Term tyname Name uni fun a + ) + => BuiltinsInfo uni fun + -> VarsInfo tyname Name uni a + -> Type tyname uni a -- ^ the type of left operand a + -> t -- ^ left operand a + -> m (t -> t) -- ^ how to modify right operand b +seqOpt binfo vinfo aT a | isPure binfo vinfo a = pure id + | otherwise = seqUnOpt aT a + +{- | Takes as input a term `a` with its type `aT`, +and constructs a function that expects another term `b`. +When the returned function is applied to a term, the execution of the applied term +would strictly evaluate the first term `a` only for its effects (i.e. ignoring its result) +while returning the result of the second term `b`. + +The name is intentionally taken from Haskell's `GHC.Prim.seq`. +Currently, the need for this `seq` "combinator" is in `RewriteRules`, +to trying to retain the effects, that would otherwise be lost if that code was instead considered +completely dead. + +Unfortunately, unlike Haskell's `seq`, we need the pass the correct `Type` of `a`, +so as to apply this `seq` combinator. This is usually not a problem because we are generating +code and we should have the type of `a` somewhere available. +-} +seqUnOpt :: (MonadQuote m, Monoid a, t ~ Term tyname Name uni fun a) + => Type tyname uni a -- ^ the type of left operand a + -> t -- ^ left operand a + -> m (t -> t) -- ^ how to modify right operand b +seqUnOpt aT a = snd <$> mkFreshTermLet aT a + +-- Some shorthands for easier pattern-matching when creating rewrite rules +-- TODO: these patterns ignores annotations. Find a better way for easier writing rules that does +-- not ignore annotations e.g. (pattern-PIR-quasiquoters?) +pattern A :: Term tyname name uni fun a -> Term tyname name uni fun a -> Term tyname name uni fun a +pattern A l r <- Apply _ l r +pattern B :: fun -> Term tyname name uni fun a +pattern B b <- Builtin _ b +pattern I :: Term tyname name uni fun a -> Type tyname uni a -> Term tyname name uni fun a +pattern I e t <- TyInst _ e t diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/UnConstrConstrData.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/UnConstrConstrData.hs new file mode 100644 index 00000000000..652ee6e4e66 --- /dev/null +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/UnConstrConstrData.hs @@ -0,0 +1,59 @@ +-- editorconfig-checker-disable-file +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +module PlutusIR.Transform.RewriteRules.UnConstrConstrData + ( unConstrConstrData + ) where + +import PlutusCore.Default +import PlutusCore.Quote +import PlutusIR +import PlutusIR.Analysis.Builtins +import PlutusIR.Analysis.VarInfo +import PlutusIR.Transform.RewriteRules.Common + +{- | This rule rewrites terms of form `BUILTIN(unConstrData(constrData(x,y)))` +, where builtin stands for `FstPair` or `SndPair`, to "x" or "y" respectively. + +This rewrite-rule was originally meant to rewrite `unConstrData(constrData(x,y)) => (x,y)`, +however we do not have a (polymorphic or monomorphic) builtin constructor to create a `BuiltinPair` +"(x,y)". See note [Representable built-in functions over polymorphic built-in types]. + +So we adapted the original rewrite rule to try to achieve a similar goal. +Unfortunately, the adapted rule is less applicable and will most likely never fire +(at least for PIR code generated by plutus-tx). +The reason is that the TH code in plutus-tx does not create such "tight" code, but uses +way more lets that get in the way preventing the rule from firing. + +Possible solutions: Some more aggressive PIR inlining, rewriting the PlutusTx TH code, or +introducing specialised pattern-matching builtins as last resort. +Plutus Tx TH code responsible: + +-} +unConstrConstrData :: (MonadQuote m, t ~ Term tyname Name DefaultUni DefaultFun a, Monoid a) + => BuiltinsInfo DefaultUni DefaultFun + -> VarsInfo tyname Name DefaultUni a + -> t + -> m t +unConstrConstrData binfo vinfo t = case t of + -- This rule might as well have been split into two separate rules, but kept as one + -- so as to reuse most of the matching pattern. + + -- builtin({t1}, {t2}, unConstr(constrData(i, data))) + (A (I (I (B builtin) tyFst) tySnd) + (A (B UnConstrData) (A (A (B ConstrData) arg1) arg2))) -> + case builtin of + -- sndPair({t1}, {t2}, unConstr(constrData(i, data))) = i `seq` data + SndPair -> (tyFst,arg1) `seQ` arg2 + + -- fstPair({t1}, {t2}, unConstr(constrData(i, data))) = let !gen = i in data `seq` gen + FstPair -> do + (genVar, genLetIn) <- mkFreshTermLet tyFst arg1 + genLetIn <$> + (tySnd, arg2) `seQ` genVar + _ -> pure t + _ -> pure t + + where + infixr 5 `seQ` -- 5 so it has more precedence than <$> + seQ = seqP binfo vinfo diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/Tests.hs index 9368ff7bf2b..628a6062cd8 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/Tests.hs @@ -1,21 +1,37 @@ module PlutusIR.Transform.RewriteRules.Tests where import PlutusCore.Quote +import PlutusCore.Test hiding (ppCatch) +import PlutusIR.Compiler qualified as PIR import PlutusIR.Parser import PlutusIR.Test import PlutusIR.Transform.RewriteRules as RewriteRules +import PlutusPrelude -import Data.Default.Class import Test.Tasty -import Test.Tasty.Extras test_RewriteRules :: TestTree test_RewriteRules = runTestNestedIn ["plutus-ir/test/PlutusIR/Transform"] $ testNested "RewriteRules" $ - fmap - (goldenPir (runQuote . RewriteRules.rewriteWith def) pTerm) - [ "equalsInt" -- this tests that the function works on equalInteger - , "divideInt" -- this tests that the function excludes not commutative functions - , "multiplyInt" -- this tests that the function works on multiplyInteger - , "let" -- this tests that it works in the subterms + (fmap + (goldenPirDoc (prettyPlcClassicDebug . runQuote . RewriteRules.rewriteWith def) pTerm) + [ "equalsInt.pir" -- this tests that the function works on equalInteger + , "divideInt.pir" -- this tests that the function excludes not commutative functions + , "multiplyInt.pir" -- this tests that the function works on multiplyInteger + , "let.pir" -- this tests that it works in the subterms + , "unConstrConstrDataFst.pir" + , "unConstrConstrDataSnd.pir" ] + ) + ++ + (fmap + (goldenPirEvalTrace pTermAsProg) + [ "unConstrConstrDataFst.pir.eval" + ] + ) + + where + goldenPirEvalTrace = goldenPirM $ \ast -> ppCatch $ do + -- we need traces to remain for checking the evaluation-order + tplc <- asIfThrown $ compileWithOpts ( set (PIR.ccOpts . PIR.coPreserveLogging) True) ast + runUPlcLogs [void tplc] diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/divideInt b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/divideInt.pir similarity index 100% rename from plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/divideInt rename to plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/divideInt.pir diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/divideInt.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/divideInt.pir.golden similarity index 100% rename from plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/divideInt.golden rename to plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/divideInt.pir.golden diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/equalsInt b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/equalsInt.pir similarity index 100% rename from plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/equalsInt rename to plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/equalsInt.pir diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/equalsInt.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/equalsInt.pir.golden similarity index 100% rename from plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/equalsInt.golden rename to plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/equalsInt.pir.golden diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let.golden deleted file mode 100644 index b5baf093451..00000000000 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let.golden +++ /dev/null @@ -1,8 +0,0 @@ -(let - (nonrec) - (termbind (strict) (vardecl x (con integer)) (error (con integer))) - [ - [ (builtin equalsInteger) (con integer 5) ] - [ [ (builtin addInteger) (con integer 10) ] x ] - ] -) \ No newline at end of file diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let.pir similarity index 100% rename from plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let rename to plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let.pir diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let.pir.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let.pir.golden new file mode 100644 index 00000000000..523f5b1f055 --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/let.pir.golden @@ -0,0 +1,8 @@ +(let + (nonrec) + (termbind (strict) (vardecl x_0 (con integer)) (error (con integer))) + [ + [ (builtin equalsInteger) (con integer 5) ] + [ [ (builtin addInteger) (con integer 10) ] x_0 ] + ] +) \ No newline at end of file diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/multiplyInt b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/multiplyInt.pir similarity index 100% rename from plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/multiplyInt rename to plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/multiplyInt.pir diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/multiplyInt.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/multiplyInt.pir.golden similarity index 100% rename from plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/multiplyInt.golden rename to plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/multiplyInt.pir.golden diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir new file mode 100644 index 00000000000..505c06008c8 --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir @@ -0,0 +1,28 @@ +-- this adds some traces to make sure that the effect order is preserved, +-- also the trace messages should not appear duplicated +(let + (nonrec) + (datatypebind + (datatype + (tyvardecl MyD_1099 (type)) + + MyD_match_1102 + (vardecl MyD_1100 (fun (con integer) MyD_1099)) + (vardecl MyD_1101 (fun (con bytestring) MyD_1099)) + ) + ) + [{ { (builtin fstPair) (con integer) } [ (con list) (con data) ] } + [ + (builtin unConstrData) + [ (builtin constrData) + [{(builtin trace) (con integer)} (con string "BEFORE") (con integer 0)] + [{(builtin trace) [ (con list) (con data) ]} (con string "AFTER") + [ { (builtin mkCons) (con data) } [ (builtin iData) (con integer 1) ] + [ (builtin mkNilData) (con unit ()) ] + ] + ] + ] + ] + ] +) + diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.eval b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.eval new file mode 120000 index 00000000000..306dbe87e82 --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.eval @@ -0,0 +1 @@ +unConstrConstrDataFst.pir \ No newline at end of file diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.eval.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.eval.golden new file mode 100644 index 00000000000..fb2d85b84ca --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.eval.golden @@ -0,0 +1 @@ +[BEFORE, AFTER] \ No newline at end of file diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.golden new file mode 100644 index 00000000000..8213f1b4f00 --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataFst.pir.golden @@ -0,0 +1,41 @@ +(let + (nonrec) + (datatypebind + (datatype + (tyvardecl MyD_1099_0 (type)) + + MyD_match_1102_1 + (vardecl MyD_1100_2 (fun (con integer) MyD_1099_0)) + (vardecl MyD_1101_3 (fun (con bytestring) MyD_1099_0)) + ) + ) + (let + (nonrec) + (termbind + (strict) + (vardecl generated_0 (con integer)) + [ + [ { (builtin trace) (con integer) } (con string "BEFORE") ] + (con integer 0) + ] + ) + (let + (nonrec) + (termbind + (strict) + (vardecl generated_1 [ (con list) (con data) ]) + [ + [ { (builtin trace) [ (con list) (con data) ] } (con string "AFTER") ] + [ + [ + { (builtin mkCons) (con data) } + [ (builtin iData) (con integer 1) ] + ] + [ (builtin mkNilData) (con unit ()) ] + ] + ] + ) + generated_0 + ) + ) +) \ No newline at end of file diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataSnd.pir b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataSnd.pir new file mode 100644 index 00000000000..2d15cd3e92c --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataSnd.pir @@ -0,0 +1,24 @@ +(let + (nonrec) + (datatypebind + (datatype + (tyvardecl MyD_1099 (type)) + + MyD_match_1102 + (vardecl MyD_1100 (fun (con integer) MyD_1099)) + (vardecl MyD_1101 (fun (con bytestring) MyD_1099)) + ) + ) + [{ { (builtin sndPair) (con integer) } [ (con list) (con data) ] } + [ + (builtin unConstrData) + [ (builtin constrData) + (con integer 0) + [ { (builtin mkCons) (con data) } [ (builtin iData) (con integer 1) ] + [ (builtin mkNilData) (con unit ()) ] + ] + ] + ] + ] +) + diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataSnd.pir.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataSnd.pir.golden new file mode 100644 index 00000000000..b667d06151a --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/unConstrConstrDataSnd.pir.golden @@ -0,0 +1,16 @@ +(let + (nonrec) + (datatypebind + (datatype + (tyvardecl MyD_1099_0 (type)) + + MyD_match_1102_1 + (vardecl MyD_1100_2 (fun (con integer) MyD_1099_0)) + (vardecl MyD_1101_3 (fun (con bytestring) MyD_1099_0)) + ) + ) + [ + [ { (builtin mkCons) (con data) } [ (builtin iData) (con integer 1) ] ] + [ (builtin mkNilData) (con unit ()) ] + ] +) \ No newline at end of file diff --git a/plutus-core/testlib/PlutusCore/Test.hs b/plutus-core/testlib/PlutusCore/Test.hs index 4bc5478d5cc..4c21b37f87d 100644 --- a/plutus-core/testlib/PlutusCore/Test.hs +++ b/plutus-core/testlib/PlutusCore/Test.hs @@ -18,6 +18,7 @@ module PlutusCore.Test ( rethrow, runTPlc, runUPlc, + runUPlcLogs, ppCatch, ppCatchReadable, goldenTPlc, @@ -59,6 +60,7 @@ import PlutusCore.Generators.Hedgehog.Utils import PlutusCore qualified as TPLC import PlutusCore.Annotation import PlutusCore.Check.Scoping +import PlutusCore.Compiler qualified as TPLC import PlutusCore.DeBruijn import PlutusCore.Evaluation.Machine.Ck qualified as TPLC import PlutusCore.Evaluation.Machine.ExBudget qualified as TPLC @@ -146,6 +148,13 @@ instance (ToUPlc a uni fun) => ToUPlc (ExceptT SomeException IO a) uni fun where instance ToUPlc (UPLC.Program TPLC.Name uni fun ()) uni fun where toUPlc = pure +instance + ( TPLC.Typecheckable uni fun + ) + => ToUPlc (TPLC.Program TPLC.TyName UPLC.Name uni fun ()) uni fun where + toUPlc = + pure . TPLC.runQuote . flip runReaderT TPLC.defaultCompilationOpts . TPLC.compileProgram + instance ToUPlc (UPLC.Program UPLC.NamedDeBruijn uni fun ()) uni fun where toUPlc p = withExceptT @_ @FreeVariableError toException $ diff --git a/plutus-core/testlib/PlutusIR/Test.hs b/plutus-core/testlib/PlutusIR/Test.hs index 8ef3dbef538..518aed543c3 100644 --- a/plutus-core/testlib/PlutusIR/Test.hs +++ b/plutus-core/testlib/PlutusIR/Test.hs @@ -7,12 +7,13 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module PlutusIR.Test ( - module PlutusIR.Test, - initialSrcSpan, - topSrcSpan, - rethrow, -) where +module PlutusIR.Test + ( module PlutusIR.Test + , initialSrcSpan + , topSrcSpan + , rethrow + , PLC.prettyPlcClassicDebug + ) where import PlutusPrelude import Test.Tasty.Extras @@ -25,7 +26,6 @@ import Control.Monad.Reader as Reader import PlutusCore qualified as PLC import PlutusCore.Builtin qualified as PLC -import PlutusCore.Compiler qualified as PLC import PlutusCore.Pretty import PlutusCore.Pretty qualified as PLC import PlutusCore.Quote (runQuoteT) @@ -76,9 +76,7 @@ instance ) => ToUPlc (PIR.Program PIR.TyName PIR.Name uni fun a) uni fun where - toUPlc t = do - p' <- toTPlc t - pure $ PLC.runQuote $ flip runReaderT PLC.defaultCompilationOpts $ PLC.compileProgram p' + toUPlc = toTPlc >=> toUPlc pTermAsProg :: Parser (PIR.Program PIR.TyName PIR.Name PLC.DefaultUni PLC.DefaultFun PLC.SrcSpan) pTermAsProg = fmap (PIR.Program mempty PLC.latestVersion) pTerm