From 0fa0547b5c361f0813a5baa623a11fb7414cb02f Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Wed, 15 Jul 2026 20:46:51 -0500 Subject: [PATCH 1/4] feat: add costed builtin pattern matching --- .../cost-model/data/cekMachineCostsA.json | 6 +- .../cost-model/data/cekMachineCostsB.json | 6 +- .../cost-model/data/cekMachineCostsC.json | 6 +- .../cost-model/data/cekMachineCostsD.json | 6 +- .../cost-model/data/cekMachineCostsE.json | 6 +- plutus-core/plutus-core/src/PlutusCore.hs | 1 + .../src/PlutusCore/Builtin/Case.hs | 125 ++++- .../plutus-core/src/PlutusCore/Compiler.hs | 12 +- .../src/PlutusCore/Compiler/Erase.hs | 4 +- .../src/PlutusCore/Compiler/Types.hs | 5 +- .../src/PlutusCore/Default/Universe.hs | 521 ++++++++++++++++++ .../Evaluation/Machine/ExBudgetingDefaults.hs | 67 ++- .../Evaluation/Machine/MachineParameters.hs | 15 +- .../Machine/MachineParameters/Default.hs | 11 +- .../plutus-core/src/PlutusCore/Version.hs | 10 +- .../src/UntypedPlutusCore.hs | 15 +- .../UntypedPlutusCore/Analysis/Builtins.hs | 2 +- .../UntypedPlutusCore/Analysis/Definitions.hs | 6 +- .../src/UntypedPlutusCore/Analysis/Usages.hs | 2 +- .../src/UntypedPlutusCore/AstSize.hs | 9 +- .../src/UntypedPlutusCore/Check/Scope.hs | 10 +- .../src/UntypedPlutusCore/Check/Uniques.hs | 4 +- .../src/UntypedPlutusCore/Contexts.hs | 16 +- .../src/UntypedPlutusCore/Core.hs | 6 +- .../src/UntypedPlutusCore/Core/Instance/Eq.hs | 58 +- .../UntypedPlutusCore/Core/Instance/Flat.hs | 104 +++- .../Core/Instance/Pretty/Classic.hs | 23 +- .../Core/Instance/Pretty/Default.hs | 8 +- .../Core/Instance/Pretty/Plc.hs | 12 +- .../Core/Instance/Pretty/Readable.hs | 24 +- .../Core/Instance/Scoping.hs | 28 +- .../src/UntypedPlutusCore/Core/Plated.hs | 25 +- .../src/UntypedPlutusCore/Core/Type.hs | 123 +++-- .../src/UntypedPlutusCore/Core/Zip.hs | 20 +- .../src/UntypedPlutusCore/DeBruijn.hs | 22 +- .../Evaluation/Machine/Cek.hs | 53 +- .../Evaluation/Machine/Cek/CekMachineCosts.hs | 23 + .../Evaluation/Machine/Cek/EmitterMode.hs | 10 +- .../Evaluation/Machine/Cek/ExBudgetMode.hs | 18 +- .../Evaluation/Machine/Cek/Internal.hs | 453 +++++++++------ .../Evaluation/Machine/CommonAPI.hs | 72 +-- .../Evaluation/Machine/SteppableCek.hs | 53 +- .../Machine/SteppableCek/DebugDriver.hs | 41 +- .../Machine/SteppableCek/Internal.hs | 295 ++++++---- .../src/UntypedPlutusCore/Mark.hs | 6 +- .../src/UntypedPlutusCore/MkUPlc.hs | 8 +- .../src/UntypedPlutusCore/Optimize.hs | 56 +- .../src/UntypedPlutusCore/Parser.hs | 90 ++- .../src/UntypedPlutusCore/Purity.hs | 53 +- .../src/UntypedPlutusCore/Rename.hs | 4 +- .../src/UntypedPlutusCore/Rename/Internal.hs | 10 +- .../src/UntypedPlutusCore/Subst.hs | 65 +-- .../Transform/ApplyToCase.hs | 51 +- .../UntypedPlutusCore/Transform/CaseOfCase.hs | 35 +- .../UntypedPlutusCore/Transform/CaseReduce.hs | 35 +- .../Transform/Certify/Hints.hs | 1 + .../Transform/Certify/Trace.hs | 14 +- .../src/UntypedPlutusCore/Transform/Cse.hs | 115 ++-- .../Transform/EvaluateBuiltins.hs | 21 +- .../UntypedPlutusCore/Transform/FloatDelay.hs | 26 +- .../Transform/ForceCaseDelay.hs | 8 +- .../UntypedPlutusCore/Transform/ForceDelay.hs | 28 +- .../src/UntypedPlutusCore/Transform/Inline.hs | 166 +++--- .../Transform/LetFloatOut.hs | 12 +- .../UntypedPlutusCore/Transform/Optimizer.hs | 40 +- .../Transform/PolyBuiltin.hs | 18 +- .../src/PlutusLedgerApi/Common/Eval.hs | 35 +- .../Common/SerialisedScript.hs | 44 +- .../src/PlutusLedgerApi/MachineParameters.hs | 9 +- .../PlutusLedgerApi/V1/EvaluationContext.hs | 9 +- .../PlutusLedgerApi/V2/EvaluationContext.hs | 9 +- .../PlutusLedgerApi/V3/EvaluationContext.hs | 9 +- plutus-tx/src/PlutusTx/Code.hs | 40 +- plutus-tx/src/PlutusTx/Eval.hs | 6 +- plutus-tx/src/PlutusTx/Lift.hs | 103 +++- 75 files changed, 2499 insertions(+), 963 deletions(-) diff --git a/plutus-core/cost-model/data/cekMachineCostsA.json b/plutus-core/cost-model/data/cekMachineCostsA.json index 27f4cd01140..a229e541577 100644 --- a/plutus-core/cost-model/data/cekMachineCostsA.json +++ b/plutus-core/cost-model/data/cekMachineCostsA.json @@ -8,5 +8,9 @@ "cekApplyCost": { "exBudgetCPU": 23000, "exBudgetMemory": 100 }, "cekBuiltinCost": { "exBudgetCPU": 23000, "exBudgetMemory": 100 }, "cekConstrCost": { "exBudgetCPU": 23000, "exBudgetMemory": 100 }, - "cekCaseCost": { "exBudgetCPU": 23000, "exBudgetMemory": 100 } + "cekCaseCost": { "exBudgetCPU": 23000, "exBudgetMemory": 100 }, + "cekMatchCost": { "exBudgetCPU": 210000, "exBudgetMemory": 100 }, + "cekPatternCost": { "exBudgetCPU": 2500, "exBudgetMemory": 100 }, + "cekPatternStructuralCost": { "exBudgetCPU": 27500, "exBudgetMemory": 60 }, + "cekPatternFailureCost": { "exBudgetCPU": 32500, "exBudgetMemory": 100 } } diff --git a/plutus-core/cost-model/data/cekMachineCostsB.json b/plutus-core/cost-model/data/cekMachineCostsB.json index 428b872b202..06defc18ba4 100644 --- a/plutus-core/cost-model/data/cekMachineCostsB.json +++ b/plutus-core/cost-model/data/cekMachineCostsB.json @@ -8,5 +8,9 @@ "cekApplyCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, "cekBuiltinCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, "cekConstrCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, - "cekCaseCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 } + "cekCaseCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, + "cekMatchCost": { "exBudgetCPU": 210000, "exBudgetMemory": 100 }, + "cekPatternCost": { "exBudgetCPU": 2500, "exBudgetMemory": 100 }, + "cekPatternStructuralCost": { "exBudgetCPU": 27500, "exBudgetMemory": 60 }, + "cekPatternFailureCost": { "exBudgetCPU": 32500, "exBudgetMemory": 100 } } diff --git a/plutus-core/cost-model/data/cekMachineCostsC.json b/plutus-core/cost-model/data/cekMachineCostsC.json index 428b872b202..06defc18ba4 100644 --- a/plutus-core/cost-model/data/cekMachineCostsC.json +++ b/plutus-core/cost-model/data/cekMachineCostsC.json @@ -8,5 +8,9 @@ "cekApplyCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, "cekBuiltinCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, "cekConstrCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, - "cekCaseCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 } + "cekCaseCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, + "cekMatchCost": { "exBudgetCPU": 210000, "exBudgetMemory": 100 }, + "cekPatternCost": { "exBudgetCPU": 2500, "exBudgetMemory": 100 }, + "cekPatternStructuralCost": { "exBudgetCPU": 27500, "exBudgetMemory": 60 }, + "cekPatternFailureCost": { "exBudgetCPU": 32500, "exBudgetMemory": 100 } } diff --git a/plutus-core/cost-model/data/cekMachineCostsD.json b/plutus-core/cost-model/data/cekMachineCostsD.json index 428b872b202..06defc18ba4 100644 --- a/plutus-core/cost-model/data/cekMachineCostsD.json +++ b/plutus-core/cost-model/data/cekMachineCostsD.json @@ -8,5 +8,9 @@ "cekApplyCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, "cekBuiltinCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, "cekConstrCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, - "cekCaseCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 } + "cekCaseCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, + "cekMatchCost": { "exBudgetCPU": 210000, "exBudgetMemory": 100 }, + "cekPatternCost": { "exBudgetCPU": 2500, "exBudgetMemory": 100 }, + "cekPatternStructuralCost": { "exBudgetCPU": 27500, "exBudgetMemory": 60 }, + "cekPatternFailureCost": { "exBudgetCPU": 32500, "exBudgetMemory": 100 } } diff --git a/plutus-core/cost-model/data/cekMachineCostsE.json b/plutus-core/cost-model/data/cekMachineCostsE.json index 428b872b202..06defc18ba4 100644 --- a/plutus-core/cost-model/data/cekMachineCostsE.json +++ b/plutus-core/cost-model/data/cekMachineCostsE.json @@ -8,5 +8,9 @@ "cekApplyCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, "cekBuiltinCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, "cekConstrCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, - "cekCaseCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 } + "cekCaseCost": { "exBudgetCPU": 16000, "exBudgetMemory": 100 }, + "cekMatchCost": { "exBudgetCPU": 210000, "exBudgetMemory": 100 }, + "cekPatternCost": { "exBudgetCPU": 2500, "exBudgetMemory": 100 }, + "cekPatternStructuralCost": { "exBudgetCPU": 27500, "exBudgetMemory": 60 }, + "cekPatternFailureCost": { "exBudgetCPU": 32500, "exBudgetMemory": 100 } } diff --git a/plutus-core/plutus-core/src/PlutusCore.hs b/plutus-core/plutus-core/src/PlutusCore.hs index a1a0ddf5677..a537f303b32 100644 --- a/plutus-core/plutus-core/src/PlutusCore.hs +++ b/plutus-core/plutus-core/src/PlutusCore.hs @@ -36,6 +36,7 @@ module PlutusCore , HasTermLevel , HasTypeAndTermLevel , DefaultUni (..) + , DefaultBuiltinPattern (..) , pattern DefaultUniList , pattern DefaultUniPair , pattern DefaultUniArray diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Case.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Case.hs index 4a08a89212f..2b0e6f34f83 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Case.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Case.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} @@ -8,13 +9,13 @@ module PlutusCore.Builtin.Case where import PlutusCore.Builtin.KnownType (HeadSpine (..)) import PlutusCore.Core.Type (Type, UniOf) import PlutusCore.Name.Unique (TyName) +import PlutusPrelude import Control.DeepSeq (NFData (..), rwhnf) -import Data.Default.Class (Default (..)) +import Control.Monad.ST (ST) import Data.Text (Text) import Data.Vector (Vector) import NoThunks.Class -import Text.PrettyBy (display) import Universe class AnnotateCaseBuiltin uni where @@ -38,6 +39,79 @@ class CaseBuiltin uni where -> Vector term -> HeadSpine Text term (Some (ValueOf uni)) + {-# MINIMAL caseBuiltin #-} + +{-| A non-negative amount of pattern-matcher work. The constructors distinguish bounded work with +materially different execution costs without storing a measure in the pattern AST. + +'PatternWork' covers cheap root/scalar work, bytestring words, and reached captures. +'PatternStructuralWork' covers one reached child/field edge, including child dispatch and its +bounded exact-arity probe. +'PatternFailureWork' covers abandoning a failed alternative and probing the next one; the matcher +spends it after a mismatch is known but before performing that transition and probe. -} +data PatternWork + = PatternWork !Word64 + | PatternStructuralWork + | PatternFailureWork + +{-| The fixed effect used by universe-specific pattern matchers. It is a Reader over 'ST': the CEK +supplies its budget action once when running the matcher, while matcher code calls +'spendPatternWork' directly from its monadic context. Keeping the monad fixed lets GHC erase the +Reader and 'ST' newtypes and optimize sequencing without a per-step unknown-'Monad' dictionary. -} +newtype PatternMatchM s a = PatternMatchM + { runPatternMatchM :: (PatternWork -> ST s ()) -> ST s a + } + +instance Functor (PatternMatchM s) where + fmap f (PatternMatchM action) = PatternMatchM $ \spend -> fmap f (action spend) + {-# INLINE fmap #-} + +instance Applicative (PatternMatchM s) where + pure value = PatternMatchM $ \_ -> pure value + {-# INLINE pure #-} + PatternMatchM fun <*> PatternMatchM arg = + PatternMatchM $ \spend -> fun spend <*> arg spend + {-# INLINE (<*>) #-} + +instance Monad (PatternMatchM s) where + PatternMatchM action >>= next = + PatternMatchM $ \spend -> action spend >>= \value -> runPatternMatchM (next value) spend + {-# INLINE (>>=) #-} + +spendPatternWork :: PatternWork -> PatternMatchM s () +spendPatternWork work = PatternMatchM $ \spend -> spend work +{-# INLINE spendPatternWork #-} + +class MatchBuiltin uni pat where + {-| Given a built-in constant and an ordered vector of pattern/handler alternatives, choose the + first matching handler while paying incrementally through 'spendPatternWork'. The CEK supplies + the concrete budget action when it runs the resulting 'PatternMatchM'. + + Spending is a strict sequencing boundary: the matcher must call 'spendPatternWork' before the + work charged to it. In particular, no pattern or value traversal, field advance, native + comparison, capture allocation or materialization, or pending-work resume may happen before its + corresponding spend. Any input-sized native operation must be preceded by a charge that bounds + the complete operation from information already available in the pattern. + + Work between spends must be a documented bounded quantum. Exact lists, for example, must be + streamed alongside their child patterns with a spend before each reached field edge; the final + edge can include the bounded exact-arity probe. They must not be traversed with 'length'. Early + mismatch stops without paying for unreachable pattern work. Each reached capture is charged + before it is retained. That charge covers both its later strict 'Spine' materialization and its + implicit application to the selected handler, even when a subsequent mismatch abandons the + capture. Other charges cover only the immediately following bounded operation. + + Alternative ordering and selection belong to the universe matcher, not the CEK machine. A + successful matcher returns the selected handler and captures directly in head-spine form and + handler-application order. 'HeadError' represents an unsupported matcher or exhaustion of the + alternatives. The 'PatternMatchM' context is a trusted costing boundary. -} + matchBuiltin + :: Some (ValueOf uni) + -> Vector (pat, term) + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf uni))) + matchBuiltin _ _ = + pure $ HeadError "built-in patterns are not supported by this universe" + -- See Note [DO NOT newtype-wrap functions]. {-| A @data@ version of 'CaseBuiltin'. we parameterize the evaluator by a 'CaserBuiltin' so that the caller can choose whether to use the 'caseBuiltin' method or the always failing caser (the @@ -49,6 +123,17 @@ data CaserBuiltin uni = CaserBuiltin ) } +{-| A data version of 'MatchBuiltin'. It is separate from 'CaserBuiltin' so that adding a pattern +language to UPLC does not parameterize the typed CK machine or change legacy built-in casing APIs. -} +data MatcherBuiltin uni pat = MatcherBuiltin + { unMatchBuiltin + :: !( forall s term + . Some (ValueOf uni) + -> Vector (pat, term) + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf uni))) + ) + } + instance NFData (CaserBuiltin uni) where rnf = rwhnf @@ -57,11 +142,39 @@ deriving via instance NoThunks (CaserBuiltin uni) +instance NFData (MatcherBuiltin uni pat) where + rnf = rwhnf + +deriving via + OnlyCheckWhnfNamed "PlutusCore.Builtin.Case.MatcherBuiltin" (MatcherBuiltin uni pat) + instance + NoThunks (MatcherBuiltin uni pat) + +availableCaserBuiltin :: CaseBuiltin uni => CaserBuiltin uni +availableCaserBuiltin = CaserBuiltin caseBuiltin + +availableMatcherBuiltin + :: MatchBuiltin uni pat => MatcherBuiltin uni pat +availableMatcherBuiltin = MatcherBuiltin matchBuiltin + instance CaseBuiltin uni => Default (CaserBuiltin uni) where - def = CaserBuiltin caseBuiltin + def = availableCaserBuiltin + +instance MatchBuiltin uni pat => Default (MatcherBuiltin uni pat) where + def = availableMatcherBuiltin unavailableCaserBuiltin :: Int -> CaserBuiltin uni unavailableCaserBuiltin ver = - CaserBuiltin $ \_ _ -> - HeadError $ - "'case' on values of built-in types is not supported in protocol version " <> display ver + CaserBuiltin + ( \_ _ -> + HeadError $ + "'case' on values of built-in types is not supported in protocol version " <> display ver + ) + +unavailableMatcherBuiltin :: Int -> MatcherBuiltin uni pat +unavailableMatcherBuiltin ver = + MatcherBuiltin + ( \_ _ -> + pure . HeadError $ + "patterns on values of built-in types are not supported in protocol version " <> display ver + ) diff --git a/plutus-core/plutus-core/src/PlutusCore/Compiler.hs b/plutus-core/plutus-core/src/PlutusCore/Compiler.hs index cc07a347c7c..4c268297b86 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Compiler.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Compiler.hs @@ -19,11 +19,11 @@ import Control.Monad.Reader (MonadReader) -- | Compile a PLC term to UPLC, and optimize it. compileTerm - :: ( Compiling m uni fun name a + :: ( Compiling m uni fun pat name a , MonadReader (CompilationOpts name fun a) m ) => Term tyname name uni fun a - -> m (UPLC.Term name uni fun a) + -> m (UPLC.Term name uni fun pat a) compileTerm t = do optimizeOpts <- view coOptimizeOpts builtinSemanticsVariant <- view coBuiltinSemanticsVariant @@ -33,21 +33,21 @@ compileTerm t = do -- | Compile a PLC program to UPLC, and optimize it. compileProgram - :: ( Compiling m uni fun name a + :: ( Compiling m uni fun pat name a , MonadReader (CompilationOpts name fun a) m ) => Program tyname name uni fun a - -> m (UPLC.Program name uni fun a) + -> m (UPLC.Program name uni fun pat a) compileProgram (Program a v t) = UPLC.Program a v <$> compileTerm t {-| Compile a PLC program to UPLC, and optimize it. This includes the compilation trace in the result. -} compileProgramWithTrace - :: ( Compiling m uni fun name a + :: ( Compiling m uni fun pat name a , MonadReader (CompilationOpts name fun a) m ) => Program tyname name uni fun a - -> m (UPLC.Program name uni fun a, UPLC.OptimizerTrace name uni fun a) + -> m (UPLC.Program name uni fun pat a, UPLC.OptimizerTrace name uni fun pat a) compileProgramWithTrace (Program a v t) = do optimizeOpts <- view coOptimizeOpts builtinSemanticsVariant <- view coBuiltinSemanticsVariant diff --git a/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs b/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs index e85df12d098..2dd935dd6a1 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs @@ -13,7 +13,7 @@ mess up its debruijn indexing and thus break scope-checking. eraseTerm :: HasUnique name TermUnique => Term tyname name uni fun ann - -> UPLC.Term name uni fun ann + -> UPLC.Term name uni fun pat ann eraseTerm (Var ann name) = UPLC.Var ann name eraseTerm (TyAbs ann _ _ body) = UPLC.Delay ann (eraseTerm body) eraseTerm (LamAbs ann name _ body) = UPLC.LamAbs ann name (eraseTerm body) @@ -30,5 +30,5 @@ eraseTerm (Case ann _ arg cs) = UPLC.Case ann (eraseTerm arg) (fromList $ fmap e eraseProgram :: HasUnique name TermUnique => Program tyname name uni fun ann - -> UPLC.Program name uni fun ann + -> UPLC.Program name uni fun pat ann eraseProgram (Program a v t) = UPLC.Program a v $ eraseTerm t diff --git a/plutus-core/plutus-core/src/PlutusCore/Compiler/Types.hs b/plutus-core/plutus-core/src/PlutusCore/Compiler/Types.hs index 6bbfdc07166..519b614efb4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Compiler/Types.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Compiler/Types.hs @@ -8,15 +8,18 @@ import PlutusCore.Name.Unique import Data.Hashable -type Compiling m uni fun name a = +type Compiling m uni fun pat name a = ( ToBuiltinMeaning uni fun , MonadQuote m , CaseBuiltin uni , GEq uni , Closed uni , Everywhere uni Eq + , Eq pat + , Typeable pat , HasUnique name TermUnique , Ord name , Typeable name , Hashable fun + , Hashable pat ) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs index f2f941110d8..a70dc8b169a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs @@ -11,6 +11,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} @@ -20,6 +21,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -35,6 +37,7 @@ -- | The universe used by default and its instances. module PlutusCore.Default.Universe ( DefaultUni (..) + , DefaultBuiltinPattern (..) , pattern DefaultUniList , pattern DefaultUniArray , pattern DefaultUniPair @@ -51,6 +54,7 @@ import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing import PlutusCore.Data (Data) +import PlutusCore.Data qualified as PLC import PlutusCore.Default.Universe.Cardano import PlutusCore.Evaluation.Machine.ExMemoryUsage ( DataNodeCount (..) @@ -60,12 +64,20 @@ import PlutusCore.Evaluation.Machine.ExMemoryUsage , ValueMaxDepth (..) , ValueTotalSize (..) ) +import PlutusCore.Flat (Flat (..)) +import PlutusCore.Flat.Decoder (dBEBits8, decodeListWith) +import PlutusCore.Flat.Encoder (encodeListWith) +import PlutusCore.Flat.Encoder.Strict (sizeListWith) +import PlutusCore.Flat.Types (NumBits) +import PlutusCore.FlatInstances (safeEncodeBits) import PlutusCore.Pretty.Extra (juxtRenderContext) +import PlutusCore.Pretty.Utils (prettyBytes) import PlutusCore.Value (Value) import Control.Monad.Except (throwError) import Data.ByteString (ByteString) import Data.ByteString qualified as B +import Data.Hashable (Hashable (..)) import Data.Int ( Int16 , Int32 @@ -80,6 +92,7 @@ import Data.Vector qualified as Vector import Data.Vector.Strict qualified as Strict (Vector) import Data.Word (Word16, Word32) import GHC.Exts (inline, oneShot) +import Prettyprinter (parens, sep, (<+>)) import Text.PrettyBy.Fixity ( RenderContext , inContextM @@ -148,6 +161,143 @@ pattern DefaultUniArray uniA = pattern DefaultUniPair uniA uniB = DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB +{-| A complete, recursive pattern language for values in 'DefaultUni'. 'Match' is deliberately +built-in-only: UPLC constructors continue to use 'Case'. List-like patterns are exact, pair arity is +represented directly, and the optional payload patterns for @Data.I@ and @Data.B@ make malformed +arities unrepresentable. Pattern matching is incrementally metered as it traverses this raw syntax, +so the AST carries no cached or caller-supplied costing metadata. -} +data DefaultBuiltinPattern + = DefaultPatternWildcard + | DefaultPatternCapture + | DefaultPatternInteger !Int64 + | DefaultPatternByteString !ByteString + | DefaultPatternBool !Bool + | DefaultPatternUnit + | DefaultPatternList !(Vector.Vector DefaultBuiltinPattern) + | DefaultPatternPair !DefaultBuiltinPattern !DefaultBuiltinPattern + | DefaultPatternDataConstr !Word64 !(Vector.Vector DefaultBuiltinPattern) + | DefaultPatternDataMap !(Vector.Vector DefaultBuiltinPattern) + | DefaultPatternDataList !(Vector.Vector DefaultBuiltinPattern) + | DefaultPatternDataI !(Maybe DefaultBuiltinPattern) + | DefaultPatternDataB !(Maybe DefaultBuiltinPattern) + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- 'Vector' deliberately has no blanket 'Hashable' instance in our dependency set, so hash the +-- serial order of structural children explicitly. +instance Hashable DefaultBuiltinPattern where + hashWithSalt salt = \case + DefaultPatternWildcard -> hashWithSalt salt (0 :: Int) + DefaultPatternCapture -> hashWithSalt salt (1 :: Int) + DefaultPatternInteger value -> salt `hashWithSalt` (2 :: Int) `hashWithSalt` value + DefaultPatternByteString value -> salt `hashWithSalt` (3 :: Int) `hashWithSalt` value + DefaultPatternBool value -> salt `hashWithSalt` (4 :: Int) `hashWithSalt` value + DefaultPatternUnit -> hashWithSalt salt (5 :: Int) + DefaultPatternList children -> + hashChildren (hashWithSalt salt (6 :: Int)) children + DefaultPatternPair left right -> + salt `hashWithSalt` (7 :: Int) `hashWithSalt` left `hashWithSalt` right + DefaultPatternDataConstr tag children -> + hashChildren (salt `hashWithSalt` (8 :: Int) `hashWithSalt` tag) children + DefaultPatternDataMap children -> + hashChildren (hashWithSalt salt (9 :: Int)) children + DefaultPatternDataList children -> + hashChildren (hashWithSalt salt (10 :: Int)) children + DefaultPatternDataI child -> salt `hashWithSalt` (11 :: Int) `hashWithSalt` child + DefaultPatternDataB child -> salt `hashWithSalt` (12 :: Int) `hashWithSalt` child + where + hashChildren childSalt children = + Vector.foldl' hashWithSalt (hashWithSalt childSalt $ Vector.length children) children + +instance Pretty DefaultBuiltinPattern where + pretty = \case + DefaultPatternWildcard -> parens "wildcard" + DefaultPatternCapture -> parens "bind" + DefaultPatternInteger i -> parens $ "integer" <+> pretty i + DefaultPatternByteString b -> parens $ "bytestring" <+> prettyBytes b + DefaultPatternBool b -> parens $ "bool" <+> pretty b + DefaultPatternUnit -> parens "unit" + DefaultPatternList children -> prettyChildren "list" children + DefaultPatternPair left right -> + parens . sep $ ["pair", pretty left, pretty right] + DefaultPatternDataConstr i children -> + parens . sep $ "data-constr" : pretty i : prettyPatternChildren children + DefaultPatternDataMap children -> prettyChildren "data-map" children + DefaultPatternDataList children -> prettyChildren "data-list" children + DefaultPatternDataI child -> prettyOptionalChild "data-i" child + DefaultPatternDataB child -> prettyOptionalChild "data-b" child + where + prettyPatternChildren = fmap pretty . Vector.toList + prettyChildren name children = parens . sep $ name : prettyPatternChildren children + prettyOptionalChild name = parens . sep . (name :) . maybe [] (pure . pretty) + +defaultBuiltinPatternTagWidth :: NumBits +defaultBuiltinPatternTagWidth = 4 + +instance Flat DefaultBuiltinPattern where + encode = \case + DefaultPatternWildcard -> tag 0 + DefaultPatternCapture -> tag 1 + DefaultPatternInteger i -> tag 2 <> encode i + DefaultPatternByteString b -> tag 3 <> encode b + DefaultPatternBool b -> tag 4 <> encode b + DefaultPatternUnit -> tag 5 + DefaultPatternList children -> tag 6 <> encodeChildren children + DefaultPatternPair left right -> tag 7 <> encode left <> encode right + DefaultPatternDataConstr i children -> tag 8 <> encode i <> encodeChildren children + DefaultPatternDataMap children -> tag 9 <> encodeChildren children + DefaultPatternDataList children -> tag 10 <> encodeChildren children + DefaultPatternDataI child -> tag 11 <> encodeOptionalChild child + DefaultPatternDataB child -> tag 12 <> encodeOptionalChild child + where + tag = safeEncodeBits defaultBuiltinPatternTagWidth + encodeChildren = encodeListWith encode . Vector.toList + encodeOptionalChild = encodeListWith encode . maybe [] pure + + decode = + dBEBits8 defaultBuiltinPatternTagWidth >>= \case + 0 -> pure DefaultPatternWildcard + 1 -> pure DefaultPatternCapture + 2 -> DefaultPatternInteger <$> decode + 3 -> DefaultPatternByteString <$> decode + 4 -> DefaultPatternBool <$> decode + 5 -> pure DefaultPatternUnit + 6 -> DefaultPatternList <$> decodeChildren + 7 -> DefaultPatternPair <$> decode <*> decode + 8 -> DefaultPatternDataConstr <$> decode <*> decodeChildren + 9 -> DefaultPatternDataMap <$> decodeChildren + 10 -> DefaultPatternDataList <$> decodeChildren + 11 -> DefaultPatternDataI <$> decodeOptionalChild + 12 -> DefaultPatternDataB <$> decodeOptionalChild + tag -> fail $ "Unknown default built-in pattern tag: " ++ show tag + where + decodeChildren = Vector.fromList <$> decodeListWith decode + decodeOptionalChild = + decodeListWith decode >>= \case + [] -> pure Nothing + [child] -> pure $ Just child + _ -> fail "Default Data.I/Data.B pattern takes at most one child" + + size pat sz = + let sz' = defaultBuiltinPatternTagWidth + sz + in case pat of + DefaultPatternWildcard -> sz' + DefaultPatternCapture -> sz' + DefaultPatternInteger i -> size i sz' + DefaultPatternByteString b -> size b sz' + DefaultPatternBool b -> size b sz' + DefaultPatternUnit -> sz' + DefaultPatternList children -> sizeChildren children sz' + DefaultPatternPair left right -> size left $ size right sz' + DefaultPatternDataConstr i children -> size i $ sizeChildren children sz' + DefaultPatternDataMap children -> sizeChildren children sz' + DefaultPatternDataList children -> sizeChildren children sz' + DefaultPatternDataI child -> sizeOptionalChild child sz' + DefaultPatternDataB child -> sizeOptionalChild child sz' + where + sizeChildren = sizeListWith size . Vector.toList + sizeOptionalChild = sizeListWith size . maybe [] pure + defaultUniSize :: forall k (a :: k). DefaultUni (Esc a) -> Int defaultUniSize = \case DefaultUniApply uniF uniA -> defaultUniSize uniF + defaultUniSize uniA + 1 @@ -887,6 +1037,12 @@ outOfBoundsErr x branches = , display $ Vector.length branches ] +byteStringPatternWords :: ByteString -> Int +byteStringPatternWords bs = + let (wholeWords, trailingBytes) = B.length bs `quotRem` 8 + in max 1 $ wholeWords + if trailingBytes == 0 then 0 else 1 +{-# INLINE byteStringPatternWords #-} + instance AnnotateCaseBuiltin DefaultUni where annotateCaseBuiltin ty branches = case ty of TyBuiltin _ (SomeTypeIn DefaultUniUnit) -> @@ -946,6 +1102,371 @@ instance CaseBuiltin DefaultUni where !len = Vector.length branches {-# INLINE caseBuiltin #-} +{-| Pending success work for one depth-first alternative. Every constructor stores the same +fallback cursor, and the terminal constructor additionally stores the successful handler. This is +an explicit work stack, not a chain of functional continuations: a mismatch abandons it in constant +time, while success resumes one frame at a time. Deferred field contents and traversal beyond the +paid exact-arity probe stay lazy until the next structural spend. The cursor is deliberately the +first field of both pending-work constructors, keeping its hot projection at a uniform payload +position. -} +data DefaultPatternWorkStack term where + DefaultPatternWorkDone + :: term + -> {-# UNPACK #-} !(Vector.Vector (DefaultBuiltinPattern, term)) + -> DefaultPatternWorkStack term + DefaultPatternValueWork + :: !(Vector.Vector (DefaultBuiltinPattern, term)) + -> !DefaultBuiltinPattern + -> Some (ValueOf DefaultUni) + -> !(DefaultPatternWorkStack term) + -> DefaultPatternWorkStack term + DefaultPatternFieldsWork + :: !(Vector.Vector (DefaultBuiltinPattern, term)) + -> !(Vector.Vector DefaultBuiltinPattern) + -> !(DefaultUni (Esc a)) + -> [a] + -> !(DefaultPatternWorkStack term) + -> DefaultPatternWorkStack term + +{-| Return the fallback cursor stored on the immediate continuation. Every frame belonging to an +alternative stores the same cursor, so a mismatch never has to walk the work stack. -} +defaultPatternWorkAlternatives + :: DefaultPatternWorkStack term + -> Vector.Vector (DefaultBuiltinPattern, term) +defaultPatternWorkAlternatives (DefaultPatternWorkDone _ alternatives) = alternatives +defaultPatternWorkAlternatives (DefaultPatternValueWork alternatives _ _ _) = alternatives +defaultPatternWorkAlternatives (DefaultPatternFieldsWork alternatives _ _ _ _) = alternatives +{-# INLINE defaultPatternWorkAlternatives #-} + +{-| Reached captures in reverse encounter order. Each strict cons is charged before construction. +On success, the strict tail-recursive materializer consumes the list directly into a 'Spine' in +handler-application order. -} +type DefaultReverseCaptures = [Some (ValueOf DefaultUni)] + +spendDefaultPatternWork + :: Word64 + -> PatternMatchM s () +spendDefaultPatternWork work = spendPatternWork (PatternWork work) +{-# INLINE spendDefaultPatternWork #-} + +spendDefaultStructuralWork + :: PatternMatchM s () +spendDefaultStructuralWork = spendPatternWork PatternStructuralWork +{-# INLINE spendDefaultStructuralWork #-} + +spendDefaultFailureWork + :: PatternMatchM s () +spendDefaultFailureWork = spendPatternWork PatternFailureWork +{-# INLINE spendDefaultFailureWork #-} + +{-| Select the first matching alternative. The alternative loop lives beside the universe-specific +matcher so the CEK invokes matching once, just as it invokes builtin casing once. + +Each alternative probe is charged before deconstructing the vector cursor or forcing the selected +pattern/handler pair. Pattern traversal then charges its own work directly as it proceeds. -} +matchDefaultAlternatives + :: forall s term + . Some (ValueOf DefaultUni) + -> Vector.Vector (DefaultBuiltinPattern, term) + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) +matchDefaultAlternatives rootValue alternatives = + PatternMatchM $ \spend -> runPatternMatchM (attemptSpend >> goPaidAlternative alternatives) spend + where + -- Reusing these actions reruns their spending effects; it does not prepay work. + attemptSpend = spendDefaultPatternWork 1 + structuralSpend = spendDefaultStructuralWork + failureSpend = spendDefaultFailureWork + + goPaidAlternative + :: Vector.Vector (DefaultBuiltinPattern, term) + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) + goPaidAlternative remainingAlternatives = case Vector.uncons remainingAlternatives of + Nothing -> pure $ HeadError "none of the match alternatives matched" + Just ((pat, handler), laterAlternatives) -> + -- The alternative-attempt or preceding failure charge covers dispatching this root + -- node below. Recursive nodes and field steps charge themselves before inspection. + matchPaidValue + pat + rootValue + (DefaultPatternWorkDone handler laterAlternatives) + [] + + nextAlternative + :: DefaultPatternWorkStack term + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) + nextAlternative workStack = do + -- The pattern work that discovered the mismatch was covered by its root, nested-node, or + -- field charge. This separate charge covers abandoning that result and probing/dispatching + -- the next alternative. + failureSpend + goPaidAlternative $ defaultPatternWorkAlternatives workStack + + finish + :: term + -> DefaultReverseCaptures + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) + finish handler [] = pure $ HeadOnly handler + finish handler (finalCapture : previousCaptures) = + let materialize + :: Spine (Some (ValueOf DefaultUni)) + -> DefaultReverseCaptures + -> Spine (Some (ValueOf DefaultUni)) + materialize !acc [] = acc + materialize !acc (capture : previous) = + materialize (SpineCons capture acc) previous + !captureSpine = materialize (SpineLast finalCapture) previousCaptures + in pure $ HeadSpine handler captureSpine + + resumeWork + :: DefaultPatternWorkStack term + -> DefaultReverseCaptures + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) + resumeWork workStack captures = case workStack of + DefaultPatternWorkDone handler _ -> finish handler captures + DefaultPatternValueWork _ next nextValue rest -> do + -- Charge before forcing the deferred package. In particular, a pair's right-hand + -- payload stays lazy until its own structural step has been paid for. + structuralSpend + matchPaidValue + next + nextValue + rest + captures + DefaultPatternFieldsWork _ patterns elemUni fields rest -> + matchFields + patterns + elemUni + fields + rest + captures + + matchValue + :: DefaultBuiltinPattern + -> Some (ValueOf DefaultUni) + -> DefaultPatternWorkStack term + -> DefaultReverseCaptures + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) + matchValue + patternToMatch + currentValue + rest + captures = do + structuralSpend + matchPaidValue + patternToMatch + currentValue + rest + captures + + matchPaidValue + :: DefaultBuiltinPattern + -> Some (ValueOf DefaultUni) + -> DefaultPatternWorkStack term + -> DefaultReverseCaptures + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) + matchPaidValue + patternToMatch + currentValueOf@(Some (ValueOf currentUni currentValue)) + rest + captures = + case patternToMatch of + DefaultPatternWildcard -> + resumeWork rest captures + DefaultPatternCapture -> do + -- One unit pays for the later strict Spine cell, and one for its implicit handler + -- application. The charge remains spent if later work abandons this alternative. + spendDefaultPatternWork 2 + let !captures' = currentValueOf : captures + resumeWork rest captures' + DefaultPatternInteger expected -> case currentUni of + DefaultUniInteger + | currentValue == toInteger expected -> + resumeWork rest captures + _ -> nextAlternative rest + DefaultPatternByteString expected -> case currentUni of + DefaultUniByteString + | B.length currentValue /= B.length expected -> + nextAlternative rest + | otherwise -> + -- Length is strict bytestring metadata. Pay for the entire native comparison + -- before equality is allowed to inspect the payload. + spendDefaultPatternWork + (fromIntegral $ byteStringPatternWords expected) + >>= \() -> + if currentValue == expected + then resumeWork rest captures + else nextAlternative rest + _ -> nextAlternative rest + DefaultPatternBool expected -> case currentUni of + DefaultUniBool + | currentValue == expected -> + resumeWork rest captures + _ -> nextAlternative rest + DefaultPatternUnit -> case currentUni of + DefaultUniUnit -> resumeWork rest captures + _ -> nextAlternative rest + DefaultPatternList children -> case currentUni of + DefaultUniList elemUni -> + matchFields + children + elemUni + currentValue + rest + captures + _ -> nextAlternative rest + DefaultPatternPair leftPattern rightPattern -> case currentUni of + DefaultUniPair leftUni rightUni -> case currentValue of + (left, right) -> + matchValue + leftPattern + (someValueOf leftUni left) + ( DefaultPatternValueWork + (defaultPatternWorkAlternatives rest) + rightPattern + (someValueOf rightUni right) + rest + ) + captures + _ -> nextAlternative rest + DefaultPatternDataConstr expectedTag children -> case currentUni of + DefaultUniData -> case currentValue of + PLC.Constr actualTag fields + | actualTag == toInteger expectedTag -> + matchFields + children + DefaultUniData + fields + rest + captures + _ -> nextAlternative rest + _ -> nextAlternative rest + DefaultPatternDataMap children -> case currentUni of + DefaultUniData -> case currentValue of + PLC.Map fields -> + matchFields + children + (DefaultUniPair DefaultUniData DefaultUniData) + fields + rest + captures + _ -> nextAlternative rest + _ -> nextAlternative rest + DefaultPatternDataList children -> case currentUni of + DefaultUniData -> case currentValue of + PLC.List fields -> + matchFields + children + DefaultUniData + fields + rest + captures + _ -> nextAlternative rest + _ -> nextAlternative rest + DefaultPatternDataI child -> case currentUni of + DefaultUniData -> case (child, currentValue) of + (Nothing, PLC.I _) -> resumeWork rest captures + (Just nested, PLC.I integer) -> + matchValue + nested + (someValueOf DefaultUniInteger integer) + rest + captures + _ -> nextAlternative rest + _ -> nextAlternative rest + DefaultPatternDataB child -> case currentUni of + DefaultUniData -> case (child, currentValue) of + (Nothing, PLC.B _) -> resumeWork rest captures + (Just nested, PLC.B bytes) -> + matchValue + nested + (someValueOf DefaultUniByteString bytes) + rest + captures + _ -> nextAlternative rest + _ -> nextAlternative rest + + matchFields + :: forall a + . Vector.Vector DefaultBuiltinPattern + -> DefaultUni (Esc a) + -> [a] + -> DefaultPatternWorkStack term + -> DefaultReverseCaptures + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) + -- This is the general field loop for every container shape. For non-empty patterns, the + -- field list remains lazy until the structural spend succeeds. The empty-pattern arity + -- probe is covered by the already-paid parent dispatch. + matchFields + patterns + elemUni + currentFields + rest + currentCaptures = + if Vector.null patterns + then case currentFields of + [] -> resumeWork rest currentCaptures + _ -> nextAlternative rest + else do + structuralSpend + case (Vector.uncons patterns, currentFields) of + (Nothing, _) -> nextAlternative rest + (_, []) -> nextAlternative rest + (Just (currentPattern, remainingPatterns), field : remainingFields) + | Vector.null remainingPatterns -> case remainingFields of + [] -> + -- The field-edge spend covers this final child dispatch. Entering the paid + -- matcher directly avoids dispatching nested final children twice. + matchPaidValue + currentPattern + (someValueOf elemUni field) + rest + currentCaptures + _ -> nextAlternative rest + | otherwise -> case remainingFields of + [] -> nextAlternative rest + _ -> case currentPattern of + DefaultPatternWildcard -> + matchFields + remainingPatterns + elemUni + remainingFields + rest + currentCaptures + DefaultPatternCapture -> do + spendDefaultPatternWork 2 + let !capture = someValueOf elemUni field + !captures' = capture : currentCaptures + matchFields + remainingPatterns + elemUni + remainingFields + rest + captures' + nested -> + -- This field-edge spend includes dispatch of the child. A nested match + -- therefore enters the paid matcher directly; any later edge resumes this + -- general field loop through the explicit work stack. + matchPaidValue + nested + (someValueOf elemUni field) + ( DefaultPatternFieldsWork + (defaultPatternWorkAlternatives rest) + remainingPatterns + elemUni + remainingFields + rest + ) + currentCaptures +{-# OPAQUE matchDefaultAlternatives #-} + +instance MatchBuiltin DefaultUni DefaultBuiltinPattern where + matchBuiltin + :: Some (ValueOf DefaultUni) + -> Vector.Vector (DefaultBuiltinPattern, term) + -> PatternMatchM s (HeadSpine Text term (Some (ValueOf DefaultUni))) + matchBuiltin = matchDefaultAlternatives + {-# INLINE matchBuiltin #-} + {- Note [Stable encoding of tags] 'encodeUni' and 'decodeUni' are used for serialisation and deserialisation of types from the universe and we need serialised things to be extremely stable, hence the definitions of 'encodeUni' diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index 39b4755f1db..d8b58c8bb4a 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -186,37 +186,62 @@ We don't want this to get inlined in order for this definition not to appear faster than the used in production. Also see Note [noinline for saving on ticks]. -} defaultCekParametersA - :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + :: Typeable ann + => MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ann) + DefaultBuiltinPattern defaultCekParametersA = - MachineParameters def $ + MachineParameters def def $ noinline mkMachineVariantParameters DefaultFunSemanticsVariantA cekCostModelVariantA -- See Note [No inlining for MachineParameters] defaultCekParametersB - :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + :: Typeable ann + => MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ann) + DefaultBuiltinPattern defaultCekParametersB = - MachineParameters def $ + MachineParameters def def $ noinline mkMachineVariantParameters DefaultFunSemanticsVariantB cekCostModelVariantB -- See Note [No inlining for MachineParameters] defaultCekParametersC - :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + :: Typeable ann + => MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ann) + DefaultBuiltinPattern defaultCekParametersC = - MachineParameters def $ + MachineParameters def def $ noinline mkMachineVariantParameters DefaultFunSemanticsVariantC cekCostModelVariantC -- See Note [No inlining for MachineParameters] defaultCekParametersD - :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + :: Typeable ann + => MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ann) + DefaultBuiltinPattern defaultCekParametersD = - MachineParameters def $ + MachineParameters def def $ noinline mkMachineVariantParameters DefaultFunSemanticsVariantD cekCostModelVariantD -- See Note [No inlining for MachineParameters] defaultCekParametersE - :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + :: Typeable ann + => MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ann) + DefaultBuiltinPattern defaultCekParametersE = - MachineParameters def $ + MachineParameters def def $ noinline mkMachineVariantParameters DefaultFunSemanticsVariantE cekCostModelVariantE {- Note [noinline for saving on ticks] @@ -242,7 +267,11 @@ defaultBuiltinsRuntimeForSemanticsVariant semvar = defaultCekParametersForVariant :: Typeable ann => BuiltinSemanticsVariant DefaultFun - -> MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + -> MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ann) + DefaultBuiltinPattern defaultCekParametersForVariant = \case DefaultFunSemanticsVariantA -> defaultCekParametersA DefaultFunSemanticsVariantB -> defaultCekParametersB @@ -269,7 +298,12 @@ defaultBuiltinsRuntimeForTesting defaultBuiltinsRuntimeForTesting = defaultBuiltinsRuntimeForSemanticsVariant DefaultFunSemanticsVariantE defaultCekParametersForTesting - :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + :: Typeable ann + => MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ann) + DefaultBuiltinPattern defaultCekParametersForTesting = defaultCekParametersE defaultCekMachineCostsForTesting :: CekMachineCosts @@ -430,9 +464,14 @@ unitCostBuiltinCostModel = } unitCekParameters - :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann) + :: Typeable ann + => MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ann) + DefaultBuiltinPattern unitCekParameters = -- See Note [noinline for saving on ticks]. - MachineParameters def $ + MachineParameters def def $ noinline mkMachineVariantParameters def $ CostModel unitCekMachineCosts unitCostBuiltinCostModel diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs index dff7ea16395..04494042a5e 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs @@ -50,11 +50,13 @@ data MachineVariantParameters machineCosts fun val {-| At execution time we need a 'BuiltinsRuntime' object which includes both the cost model for builtins and their denotations. This bundles one of those together with the cost model for evaluator -steps and a 'CaserBuiltin' specifying how casing on values of built-in types works. +steps, a 'CaserBuiltin' specifying how casing on values of built-in types works, and a +'MatcherBuiltin' specifying how universe-specific patterns inspect built-in values. The @val@ type will be 'CekValue' when we're using this with the CEK machine. -} -data MachineParameters machineCosts fun val +data MachineParameters machineCosts fun val pat = MachineParameters { machineCaserBuiltin :: CaserBuiltin (UniOf val) + , machineMatcherBuiltin :: MatcherBuiltin (UniOf val) pat , machineVariantParameters :: MachineVariantParameters machineCosts fun val } deriving stock (Generic) @@ -69,9 +71,12 @@ instance wNoThunks ctx (MachineVariantParameters costs runtime) = allNoThunks [noThunks ctx costs, noThunks ctx runtime] -instance (NoThunks machinecosts, Bounded fun, Enum fun) => NoThunks (MachineParameters machinecosts fun val) where - wNoThunks ctx (MachineParameters caser varPars) = - allNoThunks [noThunks ctx caser, noThunks ctx varPars] +instance + (NoThunks machinecosts, Bounded fun, Enum fun) + => NoThunks (MachineParameters machinecosts fun val pat) + where + wNoThunks ctx (MachineParameters caser matcher varPars) = + allNoThunks [noThunks ctx caser, noThunks ctx matcher, noThunks ctx varPars] {- Note [The CostingPart constraint in mkMachineVariantParameters] Discharging the @CostingPart uni fun ~ builtincosts@ constraint in diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 15986db0818..8287128b274 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -18,13 +18,20 @@ import GHC.Exts (inline) -- | The semantics-variant-dependent part of 'MachineParameters'. type DefaultMachineVariantParameters = - MachineVariantParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) + MachineVariantParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ()) {-| 'MachineParameters' instantiated at CEK-machine-specific types and default builtins. Encompasses everything we need for evaluating a UPLC program with default builtins using the CEK machine. -} type DefaultMachineParameters = - MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ()) + MachineParameters + CekMachineCosts + DefaultFun + (CekValue DefaultUni DefaultFun DefaultBuiltinPattern ()) + DefaultBuiltinPattern {- Note [Inlining meanings of builtins] It's vitally important to inline the 'toBuiltinMeaning' method of a set of built-in functions as diff --git a/plutus-core/plutus-core/src/PlutusCore/Version.hs b/plutus-core/plutus-core/src/PlutusCore/Version.hs index 1dac3fe8e7e..07eceddab21 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Version.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Version.hs @@ -9,6 +9,7 @@ module PlutusCore.Version , versionPatch , plcVersion100 , plcVersion110 + , plcVersion120 , firstVersion , latestVersion , knownVersions @@ -66,7 +67,14 @@ plcVersion100 = Version 1 0 0 plcVersion110 :: Version plcVersion110 = Version 1 1 0 --- | The latest version of Plutus Core supported by this library. +-- | Plutus Core version 1.2.0 +plcVersion120 :: Version +plcVersion120 = Version 1 2 0 + +{-| The latest released version of Plutus Core used by default. + +Version 1.2 is intentionally not the default while patterns are a core-machine experiment and +have no ledger protocol activation. Programs can still opt into it explicitly. -} latestVersion :: Version latestVersion = plcVersion110 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs index bf183d916f5..1eed0383f16 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs @@ -7,6 +7,7 @@ module UntypedPlutusCore , parseScoped , PLC.DefaultUni , PLC.DefaultFun + , PLC.DefaultBuiltinPattern ) where import UntypedPlutusCore.AstSize as Export @@ -19,8 +20,8 @@ import UntypedPlutusCore.Subst as Export import PlutusCore.Default qualified as PLC import PlutusCore.Error (ApplyProgramError (MkApplyProgramError)) -import PlutusPrelude (getAnn) import PlutusCore.Name.Unique as Export +import PlutusPrelude (getAnn) import Control.Monad.Except @@ -28,9 +29,9 @@ import Control.Monad.Except and tries to merge annotations. -} applyProgram :: (MonadError ApplyProgramError m, Semigroup a) - => Program name uni fun a - -> Program name uni fun a - -> m (Program name uni fun a) + => Program name uni fun pat a + -> Program name uni fun pat a + -> m (Program name uni fun pat a) applyProgram (Program a1 v1 t1) (Program a2 v2 t2) | v1 == v2 = pure $ Program (a1 <> a2) v1 (applyTerm t1 t2) @@ -39,7 +40,7 @@ applyProgram (Program _a1 v1 _t1) (Program _a2 v2 _t2) = applyTerm :: Semigroup a - => Term name uni fun a - -> Term name uni fun a - -> Term name uni fun a + => Term name uni fun pat a + -> Term name uni fun pat a + -> Term name uni fun pat a applyTerm t1 t2 = Apply (getAnn t1 <> getAnn t2) t1 t2 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Builtins.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Builtins.hs index d59e3365bfe..ce6c754a43d 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Builtins.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Builtins.hs @@ -60,7 +60,7 @@ constantIsSerializable -> Bool constantIsSerializable bi v = not $ _biUnserializableConstants bi v -termIsSerializable :: BuiltinsInfo uni fun -> Term name uni fun a -> Bool +termIsSerializable :: BuiltinsInfo uni fun -> Term name uni fun pat a -> Bool termIsSerializable binfo = allOf (termSubtermsDeep . _Constant) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs index 277d33b8af9..104482d93c1 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs @@ -26,7 +26,7 @@ termDefs , MonadState (UniqueInfos ann) m , MonadWriter [UniqueError ann] m ) - => Term name uni fun ann + => Term name uni fun pat ann -> m () termDefs tm = do forMOf_ termSubtermsDeep tm handleTerm @@ -37,7 +37,7 @@ handleTerm , MonadState (UniqueInfos ann) m , MonadWriter [UniqueError ann] m ) - => Term name uni fun ann + => Term name uni fun pat ann -> m () handleTerm = \case Var ann n -> @@ -51,6 +51,6 @@ runTermDefs , HasUnique name TermUnique , Monad m ) - => Term name uni fun ann + => Term name uni fun pat ann -> m (UniqueInfos ann, [UniqueError ann]) runTermDefs = runWriterT . flip execStateT mempty . termDefs diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Usages.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Usages.hs index 6288d087294..8c700063880 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Usages.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Usages.hs @@ -28,6 +28,6 @@ allUsed = MSet.toSet termUsages :: PLC.HasUnique name PLC.TermUnique - => Term name uni fun a + => Term name uni fun pat a -> Usages termUsages = multiSetOf (vTerm . PLC.theUnique) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/AstSize.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/AstSize.hs index cf66c2ab65f..8af4f066219 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/AstSize.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/AstSize.hs @@ -11,13 +11,18 @@ import Control.Lens import Data.Foldable -- | Count the number of AST nodes in a term. -termAstSize :: Term name uni fun ann -> AstSize +termAstSize :: Term name uni fun pat ann -> AstSize termAstSize term = fold [ AstSize 1 , term ^. termSubterms . to termAstSize + , case term of + -- A universe-specific pattern is one opaque UPLC AST node. Its internal size is accounted + -- for by its own serialisation and validation rather than by the generic term traversal. + Match _ _ alternatives -> foldMap (const $ AstSize 1) alternatives + _ -> mempty ] -- | Count the number of AST nodes in a program. -programAstSize :: Program name uni fun ann -> AstSize +programAstSize :: Program name uni fun pat ann -> AstSize programAstSize (Program _ _ t) = termAstSize t diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Scope.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Scope.hs index ac6f7e3eeab..d5bd251e15a 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Scope.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Scope.hs @@ -11,6 +11,7 @@ import UntypedPlutusCore.DeBruijn as UPLC import Control.Monad (unless) import Control.Monad.Except (MonadError, throwError) +import Data.Foldable (traverse_) {-| A pass to check that the input term: 1) does not contain free variables and @@ -26,14 +27,14 @@ Inlining this function makes a big difference, since it will usually be called in a context where all the type variables are known. That then means that GHC can optimize go locally in a completely monomorphic setting, which helps a lot. -} checkScope - :: forall m name uni fun a + :: forall m name uni fun pat a . (HasIndex name, MonadError FreeVariableError m) - => UPLC.Term name uni fun a + => UPLC.Term name uni fun pat a -> m () checkScope = go 0 where -- the current level as a reader value - go :: Word -> UPLC.Term name uni fun a -> m () + go :: Word -> UPLC.Term name uni fun pat a -> m () go !lvl = \case Var _ n -> do let i = n ^. index @@ -52,5 +53,8 @@ checkScope = go 0 Apply _ t1 t2 -> go lvl t1 >> go lvl t2 Force _ t -> go lvl t Delay _ t -> go lvl t + Constr _ _ fields -> traverse_ (go lvl) fields + Case _ scrut branches -> go lvl scrut >> traverse_ (go lvl) branches + Match _ scrut alternatives -> go lvl scrut >> traverse_ (go lvl . snd) alternatives _ -> pure () {-# INLINE checkScope #-} diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Uniques.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Uniques.hs index 0ae9680e4b3..4fbe5209cfb 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Uniques.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Check/Uniques.hs @@ -21,7 +21,7 @@ checkProgram , MonadError (UniqueError ann) m ) => (UniqueError ann -> Bool) - -> Program name uni fun ann + -> Program name uni fun pat ann -> m () checkProgram p (Program _ _ t) = checkTerm p t @@ -31,7 +31,7 @@ checkTerm , MonadError (UniqueError ann) m ) => (UniqueError ann -> Bool) - -> Term name uni fun ann + -> Term name uni fun pat ann -> m () checkTerm p t = do (_, errs) <- runTermDefs t diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Contexts.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Contexts.hs index 8ce7b4b8164..60aed9a72ee 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Contexts.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Contexts.hs @@ -8,9 +8,9 @@ import UntypedPlutusCore.Core (Term (..)) import UntypedPlutusCore.Core.Instance.Eq () -- | A context for an iterated term/type application. -data AppCtx name uni fun a - = AppCtxTerm a (Term name uni fun a) (AppCtx name uni fun a) - | AppCtxType a (AppCtx name uni fun a) +data AppCtx name uni fun pat a + = AppCtxTerm a (Term name uni fun pat a) (AppCtx name uni fun pat a) + | AppCtxType a (AppCtx name uni fun pat a) | AppCtxEnd {-| Takes a term and views it as a head plus an 'AppCtx', e.g. @@ -21,7 +21,7 @@ data AppCtx name uni fun a == f (AppCtxType t (AppCtxTerm u (AppCtxTerm v AppCtxEnd))) @ -} -splitAppCtx :: Term nam uni fun a -> (Term nam uni fun a, AppCtx nam uni fun a) +splitAppCtx :: Term nam uni fun pat a -> (Term nam uni fun pat a, AppCtx nam uni fun pat a) splitAppCtx = go AppCtxEnd where go appCtx = \case @@ -31,9 +31,9 @@ splitAppCtx = go AppCtxEnd -- | Fills in the hole in an 'AppCtx', the inverse of 'splitAppCtx'. fillAppCtx - :: Term name uni fun ann - -> AppCtx name uni fun ann - -> Term name uni fun ann + :: Term name uni fun pat ann + -> AppCtx name uni fun pat ann + -> Term name uni fun pat ann fillAppCtx term = \case AppCtxEnd -> term AppCtxTerm ann arg ctx -> fillAppCtx (Apply ann term arg) ctx @@ -42,7 +42,7 @@ fillAppCtx term = \case data Saturation = Oversaturated | Undersaturated | Saturated -- | Do the given arguments saturate the given arity? -saturates :: AppCtx name uni fun a -> Arity -> Maybe Saturation +saturates :: AppCtx name uni fun pat a -> Arity -> Maybe Saturation -- Exactly right saturates AppCtxEnd [] = Just Saturated -- Parameters left - undersaturated diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core.hs index 2dd5a923cf7..b6886371fea 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core.hs @@ -13,13 +13,15 @@ import UntypedPlutusCore.Core.Type as Export import Data.Bifunctor -- | Strips off lambda binders. -splitParams :: Term name uni fun a -> ([(name, a)], Term name uni fun a) +splitParams :: Term name uni fun pat a -> ([(name, a)], Term name uni fun pat a) splitParams = \case LamAbs a n t -> first ((n, a) :) (splitParams t) t -> ([], t) -- | Strip off arguments -splitApplication :: Term name uni fun a -> (Term name uni fun a, [(a, Term name uni fun a)]) +splitApplication + :: Term name uni fun pat a + -> (Term name uni fun pat a, [(a, Term name uni fun pat a)]) splitApplication = go [] where go acc = \case diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs index cd8d610c84f..70573ab3391 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Eq.hs @@ -22,18 +22,19 @@ import Data.Hashable import Data.Vector qualified as V instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) - => Eq (Term Name uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq pat, Eq ann) + => Eq (Term Name uni fun pat ann) where term1 == term2 = runEqRename $ eqTermM term1 term2 -type HashableTermConstraints uni fun ann = +type HashableTermConstraints uni fun pat ann = ( GEq uni , Closed uni , uni `Everywhere` Eq , uni `Everywhere` Hashable , Hashable ann , Hashable fun + , Hashable pat ) -- This instance is the only logical one, and exists also in the package `vector-instances`. @@ -41,7 +42,7 @@ type HashableTermConstraints uni fun ann = instance Hashable a => Hashable (V.Vector a) where hashWithSalt s = hashWithSalt s . toList -instance HashableTermConstraints uni fun ann => Hashable (Term Name uni fun ann) +instance HashableTermConstraints uni fun pat ann => Hashable (Term Name uni fun pat ann) -- Simple Structural Equality of a `Term NamedDeBruijn`. This implies three things: -- a) We ignore the name part of the nameddebruijn @@ -49,37 +50,51 @@ instance HashableTermConstraints uni fun ann => Hashable (Term Name uni fun ann) -- c) We do not do equality ""modulo annotations". -- If a user wants to ignore annotations he must prior do `void <$> term`, to throw away any annotations. deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) - => Eq (Term NamedDeBruijn uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq pat, Eq ann) + => Eq (Term NamedDeBruijn uni fun pat ann) -instance HashableTermConstraints uni fun ann => Hashable (Term NamedDeBruijn uni fun ann) +instance + HashableTermConstraints uni fun pat ann + => Hashable (Term NamedDeBruijn uni fun pat ann) deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) - => Eq (Term FakeNamedDeBruijn uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq pat, Eq ann) + => Eq (Term FakeNamedDeBruijn uni fun pat ann) -instance HashableTermConstraints uni fun ann => Hashable (Term FakeNamedDeBruijn uni fun ann) +instance + HashableTermConstraints uni fun pat ann + => Hashable (Term FakeNamedDeBruijn uni fun pat ann) deriving stock instance - (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann) - => Eq (Term DeBruijn uni fun ann) + (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq pat, Eq ann) + => Eq (Term DeBruijn uni fun pat ann) -instance HashableTermConstraints uni fun ann => Hashable (Term DeBruijn uni fun ann) +instance HashableTermConstraints uni fun pat ann => Hashable (Term DeBruijn uni fun pat ann) deriving stock instance ( GEq uni , Closed uni , uni `Everywhere` Eq , Eq fun + , Eq pat , Eq ann - , Eq (Term name uni fun ann) + , Eq (Term name uni fun pat ann) ) - => Eq (Program name uni fun ann) + => Eq (Program name uni fun pat ann) -- | Check equality of two 'Term's. eqTermM - :: (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq ann, HasUnique name TermUnique) - => Term name uni fun ann -> Term name uni fun ann -> EqRename (Renaming TermUnique) + :: ( GEq uni + , Closed uni + , uni `Everywhere` Eq + , Eq fun + , Eq pat + , Eq ann + , HasUnique name TermUnique + ) + => Term name uni fun pat ann + -> Term name uni fun pat ann + -> EqRename (Renaming TermUnique) eqTermM (Constant ann1 con1) (Constant ann2 con2) = do eqM ann1 ann2 eqM con1 con2 @@ -115,6 +130,14 @@ eqTermM (Case ann1 a1 cs1) (Case ann2 a2 cs2) = do case zipExact (toList cs1) (toList cs2) of Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2 Nothing -> empty +eqTermM (Match ann1 a1 alternatives1) (Match ann2 a2 alternatives2) = do + eqM ann1 ann2 + eqTermM a1 a2 + case zipExact (toList alternatives1) (toList alternatives2) of + Just pairs -> for_ pairs $ \((pat1, handler1), (pat2, handler2)) -> do + eqM pat1 pat2 + eqTermM handler1 handler2 + Nothing -> empty eqTermM Constant {} _ = empty eqTermM Builtin {} _ = empty eqTermM Var {} _ = empty @@ -125,3 +148,4 @@ eqTermM Force {} _ = empty eqTermM Error {} _ = empty eqTermM Constr {} _ = empty eqTermM Case {} _ = empty +eqTermM Match {} _ = empty diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs index 6d109c660f7..113dba8ef0c 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Flat.hs @@ -65,7 +65,7 @@ tags and their used/available encoding possibilities. \| Data type | Function | Bit Width | Total | Used | Remaining | \|------------------|-------------------|-----------|-------|------|-----------| \| default builtins | encodeBuiltin | 7 | 128 | 54 | 74 | -\| Terms | encodeTerm | 4 | 16 | 10 | 6 | +\| Terms | encodeTerm | 4 | 16 | 11 | 5 | For format stability we are manually assigning the tag values to the constructors (and we do not use a generic algorithm that may change this order). @@ -103,15 +103,16 @@ decodeTermTag :: Get Word8 decodeTermTag = dBEBits8 termTagWidth encodeTerm - :: forall name uni fun ann + :: forall name uni fun pat ann . ( Closed uni , uni `Everywhere` Flat + , Flat pat , Flat fun , Flat ann , Flat name , Flat (Binder name) ) - => Term name uni fun ann + => Term name uni fun pat ann -> Encoding encodeTerm = \case Var ann n -> encodeTermTag 0 <> encode ann <> encode n @@ -124,11 +125,19 @@ encodeTerm = \case Builtin ann bn -> encodeTermTag 7 <> encode ann <> encode bn Constr ann i es -> encodeTermTag 8 <> encode ann <> encode i <> encodeListWith encodeTerm es Case ann arg cs -> encodeTermTag 9 <> encode ann <> encodeTerm arg <> encodeListWith encodeTerm (V.toList cs) + Match ann arg alternatives -> + encodeTermTag 10 + <> encode ann + <> encodeTerm arg + <> encodeListWith encodeAlternative (V.toList alternatives) + where + encodeAlternative (pat, handler) = encode pat <> encodeTerm handler decodeTerm - :: forall name uni fun ann + :: forall name uni fun pat ann . ( Closed uni , uni `Everywhere` Flat + , Flat pat , Flat fun , Flat ann , Flat name @@ -138,8 +147,9 @@ decodeTerm -> (Some (ValueOf uni) -> Maybe String) -> (fun -> Maybe String) -> (Int -> Maybe String) - -> Get (Term name uni fun ann) -decodeTerm version constantPred builtinPred constrPred = go + -> (pat -> Maybe String) + -> Get (Term name uni fun pat ann) +decodeTerm version constantPred builtinPred constrPred patternPred = go where go = handleTerm =<< decodeTermTag handleTerm 0 = Var <$> decode <*> decode @@ -149,7 +159,7 @@ decodeTerm version constantPred builtinPred constrPred = go handleTerm 4 = do ann <- decode val <- decode - let c :: Term name uni fun ann + let c :: Term name uni fun pat ann c = Constant ann val case constantPred val of Nothing -> pure c @@ -159,7 +169,7 @@ decodeTerm version constantPred builtinPred constrPred = go handleTerm 7 = do ann <- decode fun <- decode - let t :: Term name uni fun ann + let t :: Term name uni fun pat ann t = Builtin ann fun case builtinPred fun of Nothing -> pure t @@ -183,18 +193,32 @@ decodeTerm version constantPred builtinPred constrPred = go fail $ "'case' is not allowed before version 1.1.0, this program has version: " ++ (show $ pretty version) Case <$> decode <*> go <*> (V.fromList <$> decodeListWith go) + handleTerm 10 = do + unless (version >= PLC.plcVersion120) $ + fail $ + "'match' is not allowed before version 1.2.0, this program has version: " ++ (show $ pretty version) + Match <$> decode <*> go <*> (V.fromList <$> decodeListWith decodeAlternative) + where + decodeAlternative = do + pat <- decode + case patternPred pat of + Nothing -> do + handler <- go + pure (pat, handler) + Just err -> fail err handleTerm t = fail $ "Unknown term constructor tag: " ++ show t sizeTerm - :: forall name uni fun ann + :: forall name uni fun pat ann . ( Closed uni , uni `Everywhere` Flat + , Flat pat , Flat fun , Flat ann , Flat name , Flat (Binder name) ) - => Term name uni fun ann + => Term name uni fun pat ann -> NumBits -> NumBits sizeTerm tm sz = @@ -212,28 +236,34 @@ sizeTerm tm sz = Builtin ann bn -> size ann $ size bn sz' Constr ann i es -> size ann $ size i $ sizeListWith sizeTerm es sz' Case ann arg cs -> size ann $ sizeTerm arg $ sizeListWith sizeTerm (V.toList cs) sz' + Match ann arg alternatives -> + size ann $ sizeTerm arg $ sizeListWith sizeAlternative (V.toList alternatives) sz' + where + sizeAlternative (pat, handler) = size pat . sizeTerm handler {-| An encoder for programs. It is not easy to use this correctly with @flat@. The simplest thing is to go via the instance for 'UnrestrictedProgram', which uses this -} encodeProgram - :: forall name uni fun ann + :: forall name uni fun pat ann . ( Closed uni , uni `Everywhere` Flat + , Flat pat , Flat fun , Flat ann , Flat name , Flat (Binder name) ) - => Program name uni fun ann + => Program name uni fun pat ann -> Encoding encodeProgram (Program ann v t) = encode ann <> encode v <> encodeTerm t decodeProgram - :: forall name uni fun ann + :: forall name uni fun pat ann . ( Closed uni , uni `Everywhere` Flat + , Flat pat , Flat fun , Flat ann , Flat name @@ -242,22 +272,24 @@ decodeProgram => (Some (ValueOf uni) -> Maybe String) -> (fun -> Maybe String) -> (Int -> Maybe String) - -> Get (Program name uni fun ann) -decodeProgram constantPred builtinPred constrPred = do + -> (Version -> pat -> Maybe String) + -> Get (Program name uni fun pat ann) +decodeProgram constantPred builtinPred constrPred patternPred = do ann <- decode v <- decode - Program ann v <$> decodeTerm v constantPred builtinPred constrPred + Program ann v <$> decodeTerm v constantPred builtinPred constrPred (patternPred v) sizeProgram - :: forall name uni fun ann + :: forall name uni fun pat ann . ( Closed uni , uni `Everywhere` Flat + , Flat pat , Flat fun , Flat ann , Flat name , Flat (Binder name) ) - => Program name uni fun ann + => Program name uni fun pat ann -> NumBits -> NumBits sizeProgram (Program ann v t) sz = size ann $ size v $ sizeTerm t sz @@ -266,41 +298,53 @@ sizeProgram (Program ann v t) sz = size ann $ size v $ sizeTerm t sz on the set of allowable builtins or term constructs. It is generally safe to use this newtype for serializing, but it should only be used for deserializing in tests. -} -newtype UnrestrictedProgram name uni fun ann = UnrestrictedProgram {unUnrestrictedProgram :: Program name uni fun ann} +newtype UnrestrictedProgram name uni fun pat ann = UnrestrictedProgram + { unUnrestrictedProgram :: Program name uni fun pat ann + } deriving newtype (Functor) makeWrapped ''UnrestrictedProgram deriving newtype instance - (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (UnrestrictedProgram name uni fun ann) + ( Show name + , GShow uni + , Everywhere uni Show + , Show fun + , Show pat + , Show ann + , Closed uni + ) + => Show (UnrestrictedProgram name uni fun pat ann) deriving via - PrettyAny (UnrestrictedProgram name uni fun ann) + PrettyAny (UnrestrictedProgram name uni fun pat ann) instance - DefaultPrettyPlcStrategy (UnrestrictedProgram name uni fun ann) - => PrettyBy PrettyConfigPlc (UnrestrictedProgram name uni fun ann) + DefaultPrettyPlcStrategy (UnrestrictedProgram name uni fun pat ann) + => PrettyBy PrettyConfigPlc (UnrestrictedProgram name uni fun pat ann) deriving newtype instance - (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) - => PrettyBy (PrettyConfigClassic PrettyConfigName) (UnrestrictedProgram name uni fun ann) + (PrettyClassic name, PrettyUni uni, Pretty pat, Pretty fun, Pretty ann) + => PrettyBy (PrettyConfigClassic PrettyConfigName) (UnrestrictedProgram name uni fun pat ann) deriving newtype instance - (PrettyReadable name, PrettyUni uni, Pretty fun) - => PrettyBy (PrettyConfigReadable PrettyConfigName) (UnrestrictedProgram name uni fun ann) + (PrettyReadable name, PrettyUni uni, Pretty pat, Pretty fun) + => PrettyBy (PrettyConfigReadable PrettyConfigName) (UnrestrictedProgram name uni fun pat ann) -- This instance does _not_ check for allowable builtins instance ( Closed uni , uni `Everywhere` Flat + , Flat pat , Flat fun , Flat ann , Flat name , Flat (Binder name) ) - => Flat (UnrestrictedProgram name uni fun ann) + => Flat (UnrestrictedProgram name uni fun pat ann) where encode (UnrestrictedProgram p) = encodeProgram p - decode = UnrestrictedProgram <$> decodeProgram (const Nothing) (const Nothing) (const Nothing) + decode = + UnrestrictedProgram + <$> decodeProgram (const Nothing) (const Nothing) (const Nothing) (const $ const Nothing) size (UnrestrictedProgram p) = sizeProgram p diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs index 404cb34206d..a61c7779938 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs @@ -20,8 +20,13 @@ import Prettyprinter.Custom import Universe (Some (..), SomeTypeIn (SomeTypeIn), ValueOf (..)) instance - (PrettyClassicBy configName name, PrettyUni uni, Pretty fun, Pretty ann) - => PrettyBy (PrettyConfigClassic configName) (Term name uni fun ann) + ( PrettyClassicBy configName name + , PrettyUni uni + , Pretty fun + , Pretty pat + , Pretty ann + ) + => PrettyBy (PrettyConfigClassic configName) (Term name uni fun pat ann) where prettyBy config = \case Var ann n -> @@ -81,13 +86,23 @@ instance ann (prettyBy config arg : fmap (prettyBy config) (toList cs)) ) + Match ann arg alternatives -> + sexp + "match" + ( consAnnIf + config + ann + (prettyBy config arg : fmap prettyAlternative (toList alternatives)) + ) where + prettyAlternative (pat, handler) = + sexp "pattern" [pretty pat, prettyBy config handler] prettyTypeOf :: Some (ValueOf uni) -> Doc dann prettyTypeOf (Some (ValueOf uni _)) = prettyBy juxtRenderContext $ SomeTypeIn uni instance - (PrettyClassicBy configName (Term name uni fun ann), Pretty ann) - => PrettyBy (PrettyConfigClassic configName) (Program name uni fun ann) + (PrettyClassicBy configName (Term name uni fun pat ann), Pretty ann) + => PrettyBy (PrettyConfigClassic configName) (Program name uni fun pat ann) where prettyBy config (Program ann version term) = sexp "program" (consAnnIf config ann [pretty version, prettyBy config term]) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs index 1b5622ce3d4..4c12d04c3db 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs @@ -16,13 +16,13 @@ import UntypedPlutusCore.Core.Instance.Pretty.Classic () import UntypedPlutusCore.Core.Type instance - (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) - => Pretty (Term name uni fun ann) + (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty pat, Pretty ann) + => Pretty (Term name uni fun pat ann) where pretty = prettyClassic instance - (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) - => Pretty (Program name uni fun ann) + (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty pat, Pretty ann) + => Pretty (Program name uni fun pat ann) where pretty = prettyClassic diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs index 5dff993236d..c8adab5874d 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Plc.hs @@ -14,12 +14,12 @@ import UntypedPlutusCore.Core.Type import PlutusCore.Pretty.Plc deriving via - PrettyAny (Term name uni fun ann) + PrettyAny (Term name uni fun pat ann) instance - DefaultPrettyPlcStrategy (Term name uni fun ann) - => PrettyBy PrettyConfigPlc (Term name uni fun ann) + DefaultPrettyPlcStrategy (Term name uni fun pat ann) + => PrettyBy PrettyConfigPlc (Term name uni fun pat ann) deriving via - PrettyAny (Program name uni fun ann) + PrettyAny (Program name uni fun pat ann) instance - DefaultPrettyPlcStrategy (Program name uni fun ann) - => PrettyBy PrettyConfigPlc (Program name uni fun ann) + DefaultPrettyPlcStrategy (Program name uni fun pat ann) + => PrettyBy PrettyConfigPlc (Program name uni fun pat ann) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs index ab4c31e131a..588a515df55 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs @@ -17,7 +17,7 @@ import UntypedPlutusCore.Core.Type import Prettyprinter -- | Split an iterated 'LamAbs' (if any) into a list of variables that it binds and its body. -viewLamAbs :: Term name uni fun ann -> Maybe ([name], Term name uni fun ann) +viewLamAbs :: Term name uni fun pat ann -> Maybe ([name], Term name uni fun pat ann) viewLamAbs term0@LamAbs {} = Just $ go term0 where go (LamAbs _ name body) = first (name :) $ go body @@ -26,8 +26,8 @@ viewLamAbs _ = Nothing -- | Split an iterated 'Apply' (if any) into the head of the application and the spine. viewApp - :: Term name uni fun ann - -> Maybe (Term name uni fun ann, [Term name uni fun ann]) + :: Term name uni fun pat ann + -> Maybe (Term name uni fun pat ann, [Term name uni fun pat ann]) viewApp term0 = go term0 [] where go (Apply _ fun arg) args = go fun $ arg : args @@ -35,8 +35,13 @@ viewApp term0 = go term0 [] go fun args = Just (fun, args) instance - (PrettyReadableBy configName name, PrettyUni uni, Pretty fun, Show configName) - => PrettyBy (PrettyConfigReadable configName) (Term name uni fun a) + ( PrettyReadableBy configName name + , PrettyUni uni + , Pretty fun + , Pretty pat + , Show configName + ) + => PrettyBy (PrettyConfigReadable configName) (Term name uni fun pat a) where prettyBy = inContextM $ \case Constant _ val -> lmap (ConstConfig . _pcrRenderContext) $ prettyM val @@ -54,10 +59,15 @@ instance Constr _ i es -> iterAppDocM $ \_ prettyArg -> ("constr" <+> prettyArg i) :| [prettyArg es] Case _ arg cs -> iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg arg, prettyArg (toList cs)] + Match _ arg alternatives -> iterAppDocM $ \_ prettyArg -> + "match" :| (prettyArg arg : fmap (prettyAlternative prettyArg) (toList alternatives)) + where + prettyAlternative prettyArg (pat, handler) = + parens $ "pattern" <+> pretty pat <+> prettyArg handler instance - PrettyReadableBy configName (Term name uni fun a) - => PrettyBy (PrettyConfigReadable configName) (Program name uni fun a) + PrettyReadableBy configName (Term name uni fun pat a) + => PrettyBy (PrettyConfigReadable configName) (Program name uni fun pat a) where prettyBy = inContextM $ \(Program _ version term) -> iterAppDocM $ \_ prettyArg -> "program" :| [pretty version, prettyArg term] diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs index 668bde9a287..50146db570c 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs @@ -16,14 +16,14 @@ import PlutusCore.Quote import Data.Proxy import Data.Vector qualified as Vector -firstBound :: Term name uni fun ann -> [name] +firstBound :: Term name uni fun pat ann -> [name] firstBound (Apply _ (LamAbs _ name body) _) = name : firstBound body firstBound _ = [] -instance name ~ Name => Reference Name (Term name uni fun) where +instance name ~ Name => Reference Name (Term name uni fun pat) where referenceVia reg name term = Apply NotAName term $ Var (reg name) name -instance name ~ Name => EstablishScoping (Term name uni fun) where +instance name ~ Name => EstablishScoping (Term name uni fun pat) where establishScoping (LamAbs _ nameDup body) = do name <- freshenName nameDup establishScopingBinder (\ann name' _ -> LamAbs ann name') name Proxy body @@ -38,6 +38,20 @@ instance name ~ Name => EstablishScoping (Term name uni fun) where establishScoping (Constant _ con) = pure $ Constant NotAName con establishScoping (Builtin _ bi) = pure $ Builtin NotAName bi establishScoping (Constr _ i es) = Constr NotAName <$> pure i <*> traverse establishScoping es + establishScoping (Match _ a alternatives) = do + alternativesScoped <- for alternatives $ \(pat, handler) -> do + handlerScoped <- establishScoping handler + pure (pat, handlerScoped) + let alternativesScopedPoked = + addTheRest . map (\alternative@(_, handler) -> (alternative, firstBound handler)) $ + Vector.toList alternativesScoped + branchBounds = map (snd . fst) alternativesScopedPoked + referenceInAlternative (((pat, handler), _), others) = + (pat, referenceOutOfScope (map snd others) handler) + aScoped <- establishScoping a + pure . referenceOutOfScope branchBounds $ + Match NotAName aScoped . Vector.fromList $ + map referenceInAlternative alternativesScopedPoked establishScoping (Case _ a es) = do esScoped <- traverse establishScoping es let esScopedPoked = addTheRest . map (\e -> (e, firstBound e)) $ Vector.toList esScoped @@ -51,10 +65,10 @@ instance name ~ Name => EstablishScoping (Term name uni fun) where Case NotAName aScoped . Vector.fromList $ map referenceInBranch esScopedPoked -instance name ~ Name => EstablishScoping (Program name uni fun) where +instance name ~ Name => EstablishScoping (Program name uni fun pat) where establishScoping (Program _ ver term) = Program NotAName ver <$> establishScoping term -instance name ~ Name => CollectScopeInfo (Term name uni fun) where +instance name ~ Name => CollectScopeInfo (Term name uni fun pat) where collectScopeInfo (LamAbs ann name body) = handleSname ann name <> collectScopeInfo body collectScopeInfo (Delay _ body) = collectScopeInfo body collectScopeInfo (Apply _ fun arg) = collectScopeInfo fun <> collectScopeInfo arg @@ -65,6 +79,8 @@ instance name ~ Name => CollectScopeInfo (Term name uni fun) where collectScopeInfo (Builtin _ _) = mempty collectScopeInfo (Constr _ _ es) = foldMap collectScopeInfo es collectScopeInfo (Case _ arg cs) = collectScopeInfo arg <> foldMap collectScopeInfo cs + collectScopeInfo (Match _ arg alternatives) = + collectScopeInfo arg <> foldMap (collectScopeInfo . snd) alternatives -instance name ~ Name => CollectScopeInfo (Program name uni fun) where +instance name ~ Name => CollectScopeInfo (Program name uni fun pat) where collectScopeInfo (Program _ _ term) = collectScopeInfo term diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs index 83a1be8eff7..14e986e6ed9 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs @@ -22,7 +22,7 @@ import Control.Lens import Universe -- | Get all the direct constants of the given 'Term' from 'Constant's. -termConstants :: Traversal' (Term name uni fun ann) (Some (ValueOf uni)) +termConstants :: Traversal' (Term name uni fun pat ann) (Some (ValueOf uni)) termConstants f term0 = case term0 of Constant ann val -> Constant ann <$> f val Var {} -> pure term0 @@ -34,28 +34,31 @@ termConstants f term0 = case term0 of Builtin {} -> pure term0 Constr {} -> pure term0 Case {} -> pure term0 + Match {} -> pure term0 -- | Get all the direct child 'name a's of the given 'Term' from 'LamAbs'es. -termBinds :: Traversal' (Term name uni fun ann) name +termBinds :: Traversal' (Term name uni fun pat ann) name termBinds f = \case LamAbs ann n t -> f n <&> \n' -> LamAbs ann n' t x -> pure x -- | Get all the direct child 'name a's of the given 'Term' from 'Var's. -termVars :: Traversal' (Term name uni fun ann) name +termVars :: Traversal' (Term name uni fun pat ann) name termVars f = \case Var ann n -> Var ann <$> f n x -> pure x -- | Get all the direct child 'Unique's of the given 'Term'. -termUniques :: HasUniques (Term name uni fun ann) => Traversal' (Term name uni fun ann) Unique +termUniques + :: HasUniques (Term name uni fun pat ann) + => Traversal' (Term name uni fun pat ann) Unique termUniques f = \case LamAbs ann n t -> theUnique f n <&> \n' -> LamAbs ann n' t Var ann n -> theUnique f n <&> Var ann x -> pure x -- | Get all the direct child 'Term's of the given 'Term'. -termSubterms :: Traversal' (Term name uni fun ann) (Term name uni fun ann) +termSubterms :: Traversal' (Term name uni fun pat ann) (Term name uni fun pat ann) termSubterms f = \case LamAbs ann n t -> LamAbs ann n <$> f t Apply ann t1 t2 -> Apply ann <$> f t1 <*> f t2 @@ -63,6 +66,8 @@ termSubterms f = \case Force ann t -> Force ann <$> f t Constr ann i args -> Constr ann i <$> traverse f args Case ann arg cs -> Case ann <$> f arg <*> traverse f cs + Match ann arg alternatives -> + Match ann <$> f arg <*> traverse (traverse f) alternatives e@Error {} -> pure e v@Var {} -> pure v c@Constant {} -> pure c @@ -70,17 +75,19 @@ termSubterms f = \case {-# INLINE termSubterms #-} -- | Get all the transitive child 'Constant's of the given 'Term'. -termConstantsDeep :: Fold (Term name uni fun ann) (Some (ValueOf uni)) +termConstantsDeep :: Fold (Term name uni fun pat ann) (Some (ValueOf uni)) termConstantsDeep = termSubtermsDeep . termConstants -- | Get all the transitive child 'Term's of the given 'Term'. -termSubtermsDeep :: Fold (Term name uni fun ann) (Term name uni fun ann) +termSubtermsDeep :: Fold (Term name uni fun pat ann) (Term name uni fun pat ann) termSubtermsDeep = cosmosOf termSubterms -- | Get all the transitive child 'Unique's of the given 'Term'. -termUniquesDeep :: HasUniques (Term name uni fun ann) => Fold (Term name uni fun ann) Unique +termUniquesDeep + :: HasUniques (Term name uni fun pat ann) + => Fold (Term name uni fun pat ann) Unique termUniquesDeep = termSubtermsDeep . termUniques -- | View a term as a constant. -_Constant :: Prism' (Term name uni fun a) (a, PLC.Some (PLC.ValueOf uni)) +_Constant :: Prism' (Term name uni fun pat a) (a, PLC.Some (PLC.ValueOf uni)) _Constant = prism' (uncurry Constant) (\case Constant a v -> Just (a, v); _ -> Nothing) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs index 79b7f81d40b..bf404d44389 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -49,8 +50,8 @@ Additionally, the first 7 (or 3 on 32-bit systems) constructors will get *pointe more efficient access when casing on them. So we ideally want to keep the number of constructors at 7 or fewer. -We've got 8 constructors, *but* the last one is Error, which is only going to be seen at most -once per program, so it's not too big a deal if it doesn't get a tag. +The family has grown beyond the pointer-tag limit. The ordering still keeps the most common +constructors first; 'Match' is intentionally last because it is expected to be comparatively rare. See the GHC Notes "Tagging big families" and "Double switching for big families" in GHC.StgToCmm.Expr for more details. @@ -64,7 +65,9 @@ However in https://github.com/IntersectMBO/plutus/issues/6602 we decided that th speed up processing values of built-in types is to extend 'Case' such that it supports pattern matching on those. -Currently, 'Case' only supports booleans and integers, but we plan to extend it to lists and data. +Legacy built-in casing supports unit, booleans, integers, lists and pairs. The separate 'Match' +node provides ordered, first-match-wins pattern semantics, including structural matching on 'Data'. +Keeping it separate preserves the behavior and cost of every existing 'Case'. See the @CaseBuiltin DefaultUni@ instance for how casing behaves for supported built-in types. -} @@ -85,12 +88,12 @@ serve exactly this purpose. -} -- Making all the fields strict gives us a couple of percent in benchmarks -- See Note [Term constructor ordering and numbers] -data Term name uni fun ann +data Term name uni fun pat ann = Var !ann !name - | LamAbs !ann !name !(Term name uni fun ann) - | Apply !ann !(Term name uni fun ann) !(Term name uni fun ann) - | Force !ann !(Term name uni fun ann) - | Delay !ann !(Term name uni fun ann) + | LamAbs !ann !name !(Term name uni fun pat ann) + | Apply !ann !(Term name uni fun pat ann) !(Term name uni fun pat ann) + | Force !ann !(Term name uni fun pat ann) + | Delay !ann !(Term name uni fun pat ann) | Constant !ann !(Some (ValueOf uni)) | Builtin !ann !fun | -- This is the cutoff at which constructors won't get pointer tags @@ -98,45 +101,87 @@ data Term name uni fun ann Error !ann | -- TODO: worry about overflow, maybe use an Integer -- See Note [Constr tag type] - Constr !ann !Word64 ![Term name uni fun ann] + Constr !ann !Word64 ![Term name uni fun pat ann] | -- See Note [Supported case-expressions]. - Case !ann !(Term name uni fun ann) !(Vector (Term name uni fun ann)) + Case !ann !(Term name uni fun pat ann) !(Vector (Term name uni fun pat ann)) + | {-| Ordered, first-match-wins pattern alternatives. + The pattern type and capture semantics are supplied by the built-in universe. -} + Match + !ann + !(Term name uni fun pat ann) + !(Vector (pat, Term name uni fun pat ann)) deriving stock (Functor, Generic) +type role Term representational representational representational representational representational + deriving stock instance - (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Term name uni fun ann) + ( Show name + , GShow uni + , Everywhere uni Show + , Show fun + , Show pat + , Show ann + , Closed uni + ) + => Show (Term name uni fun pat ann) deriving anyclass instance - (NFData name, NFData fun, NFData ann, Everywhere uni NFData, Closed uni) - => NFData (Term name uni fun ann) + ( NFData name + , NFData fun + , NFData pat + , NFData ann + , Everywhere uni NFData + , Closed uni + ) + => NFData (Term name uni fun pat ann) -- See Note [ExMemoryUsage instances for non-constants]. -instance ExMemoryUsage (Term name uni fun ann) where +instance ExMemoryUsage (Term name uni fun pat ann) where memoryUsage = Prelude.error "Internal error: 'memoryUsage' for UPLC 'Term' is not supposed to be forced" -- | A 'Program' is simply a 'Term' coupled with a 'Version' of the core language. -data Program name uni fun ann = Program +type role + Program + representational + representational + representational + representational + representational + +data Program name uni fun pat ann = Program { _progAnn :: ann , _progVer :: TPLC.Version - , _progTerm :: Term name uni fun ann + , _progTerm :: Term name uni fun pat ann } deriving stock (Functor, Generic) makeLenses ''Program deriving stock instance - (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Program name uni fun ann) + ( Show name + , GShow uni + , Everywhere uni Show + , Show fun + , Show pat + , Show ann + , Closed uni + ) + => Show (Program name uni fun pat ann) deriving anyclass instance - (NFData name, Everywhere uni NFData, NFData fun, NFData ann, Closed uni) - => NFData (Program name uni fun ann) - -type instance TPLC.UniOf (Term name uni fun ann) = uni - -instance TermLike (Term name uni fun) TPLC.TyName name uni fun where + ( NFData name + , Everywhere uni NFData + , NFData fun + , NFData pat + , NFData ann + , Closed uni + ) + => NFData (Program name uni fun pat ann) + +type instance TPLC.UniOf (Term name uni fun pat ann) = uni + +instance TermLike (Term name uni fun pat) TPLC.TyName name uni fun where var = Var tyAbs = \ann _ _ -> Delay ann lamAbs = \ann name _ -> LamAbs ann name @@ -150,14 +195,16 @@ instance TermLike (Term name uni fun) TPLC.TyName name uni fun where constr = \ann _ i es -> Constr ann i es kase = \ann _ arg cs -> Case ann arg (fromList cs) -instance TPLC.HasConstant (Term name uni fun ()) where +instance TPLC.HasConstant (Term name uni fun pat ()) where asConstant (Constant _ val) = pure val asConstant _ = throwError TPLC.notAConstant fromConstant = Constant () -type instance TPLC.HasUniques (Term name uni fun ann) = TPLC.HasUnique name TPLC.TermUnique -type instance TPLC.HasUniques (Program name uni fun ann) = TPLC.HasUniques (Term name uni fun ann) +type instance TPLC.HasUniques (Term name uni fun pat ann) = TPLC.HasUnique name TPLC.TermUnique +type instance + TPLC.HasUniques (Program name uni fun pat ann) = + TPLC.HasUniques (Term name uni fun pat ann) -- | An untyped "variable declaration", i.e. a name for a variable. data UVarDecl name ann = UVarDecl @@ -169,7 +216,7 @@ data UVarDecl name ann = UVarDecl makeLenses ''UVarDecl -- | Return the outermost annotation of a 'Term'. -instance HasAnn (Term name uni fun) where +instance HasAnn (Term name uni fun pat) where getAnn (Constant ann _) = ann getAnn (Builtin ann _) = ann getAnn (Var ann _) = ann @@ -180,6 +227,7 @@ instance HasAnn (Term name uni fun) where getAnn (Error ann) = ann getAnn (Constr ann _ _) = ann getAnn (Case ann _ _) = ann + getAnn (Match ann _ _) = ann modifyAnn f = \case Constant ann c -> Constant (f ann) c Builtin ann b -> Builtin (f ann) b @@ -191,12 +239,13 @@ instance HasAnn (Term name uni fun) where Error ann -> Error (f ann) Constr ann i args -> Constr (f ann) i args Case ann scrut alts -> Case (f ann) scrut alts + Match ann scrut alts -> Match (f ann) scrut alts bindFunM :: Monad m - => (ann -> fun -> m (Term name uni fun' ann)) - -> Term name uni fun ann - -> m (Term name uni fun' ann) + => (ann -> fun -> m (Term name uni fun' pat ann)) + -> Term name uni fun pat ann + -> m (Term name uni fun' pat ann) bindFunM f = go where go (Constant ann val) = pure $ Constant ann val @@ -209,12 +258,14 @@ bindFunM f = go go (Error ann) = pure $ Error ann go (Constr ann i args) = Constr ann i <$> traverse go args go (Case ann arg cs) = Case ann <$> go arg <*> traverse go cs + go (Match ann arg alternatives) = + Match ann <$> go arg <*> traverse (traverse go) alternatives bindFun - :: (ann -> fun -> Term name uni fun' ann) - -> Term name uni fun ann - -> Term name uni fun' ann + :: (ann -> fun -> Term name uni fun' pat ann) + -> Term name uni fun pat ann + -> Term name uni fun' pat ann bindFun f = runIdentity . bindFunM (coerce f) -mapFun :: (ann -> fun -> fun') -> Term name uni fun ann -> Term name uni fun' ann +mapFun :: (ann -> fun -> fun') -> Term name uni fun pat ann -> Term name uni fun' pat ann mapFun f = bindFun $ \ann fun -> Builtin ann (f ann fun) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs index b44c7bb74a9..a33ca3c141e 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs @@ -21,8 +21,8 @@ Throws an error if the input programs are not "equal" modulo annotations. Note that the function is "left-biased", so in case that the 2 input programs contain `Name`s, the output program will contain just the `Name`s of the first input program. -} pzipWith - :: forall p name uni fun ann1 ann2 ann3 m - . (p ~ Program name uni fun, (Eq (Term name uni fun ())), MonadError String m) + :: forall p name uni fun pat ann1 ann2 ann3 m + . (p ~ Program name uni fun pat, (Eq (Term name uni fun pat ())), MonadError String m) => (ann1 -> ann2 -> ann3) -> p ann1 -> p ann2 @@ -39,8 +39,8 @@ Note that the function is "left-biased", so in case that the 2 input terms conta the output term will contain just the `Name`s of the first input term. TODO: this is not an optimal implementation -} tzipWith - :: forall t name uni fun ann1 ann2 ann3 m - . (t ~ Term name uni fun, Eq (t ()), MonadError String m) + :: forall t name uni fun pat ann1 ann2 ann3 m + . (t ~ Term name uni fun pat, Eq (t ()), MonadError String m) => (ann1 -> ann2 -> ann3) -> t ann1 -> t ann2 @@ -66,6 +66,10 @@ tzipWith f term1 term2 = do go (Constr a1 i1 ts1) (Constr a2 _i2 ts2) = Constr (f a1 a2) i1 <$> zipExactWithM go ts1 ts2 go (Case a1 t1 vs1) (Case a2 t2 vs2) = Case (f a1 a2) <$> go t1 t2 <*> (fromList <$> zipExactWithM go (toList vs1) (toList vs2)) + go (Match a1 t1 as1) (Match a2 t2 as2) = + Match (f a1 a2) + <$> go t1 t2 + <*> (fromList <$> zipExactWithM goAlternative (toList as1) (toList as2)) go _ _ = throwError "zip: This should not happen, because we prior established term equality." @@ -74,9 +78,13 @@ tzipWith f term1 term2 = do zipExactWithM _ [] [] = pure [] zipExactWithM _ _ _ = throwError "zipExactWithM: not exact" + goAlternative (pat, handler1) (_, handler2) = do + handler <- go handler1 handler2 + pure (pat, handler) + -- | Zip 2 programs by pairing their annotations pzip - :: (p ~ Program name uni fun, Eq (Term name uni fun ()), MonadError String m) + :: (p ~ Program name uni fun pat, Eq (Term name uni fun pat ()), MonadError String m) => p ann1 -> p ann2 -> m (p (ann1, ann2)) @@ -84,7 +92,7 @@ pzip = pzipWith (,) -- | Zip 2 terms by pairing their annotations tzip - :: (t ~ Term name uni fun, Eq (t ()), MonadError String m) + :: (t ~ Term name uni fun pat, Eq (t ()), MonadError String m) => t ann1 -> t ann2 -> m (t (ann1, ann2)) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs index f31da1012d7..2fe3a38c1ef 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs @@ -45,37 +45,37 @@ This module is just a boring port of the typed version. Will throw an error if a free variable is encountered. -} deBruijnTerm :: MonadError FreeVariableError m - => Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann) + => Term Name uni fun pat ann -> m (Term NamedDeBruijn uni fun pat ann) deBruijnTerm = deBruijnTermWith freeUniqueThrow {-| Convert a 'Term' with 'DeBruijn's into a 'Term' with 'Name's. Will throw an error if a free variable is encountered. -} unDeBruijnTerm :: (MonadQuote m, MonadError FreeVariableError m) - => Term NamedDeBruijn uni fun ann -> m (Term Name uni fun ann) + => Term NamedDeBruijn uni fun pat ann -> m (Term Name uni fun pat ann) unDeBruijnTerm = unDeBruijnTermWith freeIndexThrow -- | Takes a "handler" function to execute when encountering free variables. deBruijnTermWith :: Monad m => (Unique -> ReaderT LevelInfo m Index) - -> Term Name uni fun ann - -> m (Term NamedDeBruijn uni fun ann) + -> Term Name uni fun pat ann + -> m (Term NamedDeBruijn uni fun pat ann) deBruijnTermWith = (runDeBruijnT .) . deBruijnTermWithM -- | Takes a "handler" function to execute when encountering free variables. unDeBruijnTermWith :: MonadQuote m => (Index -> ReaderT LevelInfo m Unique) - -> Term NamedDeBruijn uni fun ann - -> m (Term Name uni fun ann) + -> Term NamedDeBruijn uni fun pat ann + -> m (Term Name uni fun pat ann) unDeBruijnTermWith = (runDeBruijnT .) . unDeBruijnTermWithM deBruijnTermWithM :: MonadReader LevelInfo m => (Unique -> m Index) - -> Term Name uni fun ann - -> m (Term NamedDeBruijn uni fun ann) + -> Term Name uni fun pat ann + -> m (Term NamedDeBruijn uni fun pat ann) deBruijnTermWithM h = go where go = \case @@ -91,6 +91,7 @@ deBruijnTermWithM h = go Force ann t -> Force ann <$> go t Constr ann i es -> Constr ann i <$> traverse go es Case ann arg cs -> Case ann <$> go arg <*> traverse go cs + Match ann arg alternatives -> Match ann <$> go arg <*> traverse (traverse go) alternatives -- boring non-recursive cases Constant ann con -> pure $ Constant ann con Builtin ann bn -> pure $ Builtin ann bn @@ -100,8 +101,8 @@ deBruijnTermWithM h = go unDeBruijnTermWithM :: (MonadReader LevelInfo m, MonadQuote m) => (Index -> m Unique) - -> Term NamedDeBruijn uni fun ann - -> m (Term Name uni fun ann) + -> Term NamedDeBruijn uni fun pat ann + -> m (Term Name uni fun pat ann) unDeBruijnTermWithM h = go where go = \case @@ -119,6 +120,7 @@ unDeBruijnTermWithM h = go Force ann t -> Force ann <$> go t Constr ann i es -> Constr ann i <$> traverse go es Case ann arg cs -> Case ann <$> go arg <*> traverse go cs + Match ann arg alternatives -> Match ann <$> go arg <*> traverse (traverse go) alternatives -- boring non-recursive cases Constant ann con -> pure $ Constant ann con Builtin ann bn -> pure $ Builtin ann bn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs index ae0a28b040e..d3bc3261691 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs @@ -69,6 +69,7 @@ import UntypedPlutusCore.Evaluation.Machine.CommonAPI qualified as Common import PlutusCore.Builtin import PlutusCore.Evaluation.Machine.MachineParameters import PlutusCore.Name.Unique +import PlutusCore.Pretty (Pretty) import Data.Text (Text) @@ -76,48 +77,52 @@ import Data.Text (Text) A wrapper around the internal runCek to debruijn input and undebruijn output. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} runCek - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> Term Name uni fun ann - -> CekReport cost Name uni fun + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> EmitterMode uni fun pat + -> Term Name uni fun pat ann + -> CekReport cost Name uni fun pat runCek = Common.runCek runCekDeBruijn {-| Evaluate a term using the CEK machine with logging disabled and keep track of costing. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} runCekNoEmit - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> Term Name uni fun pat ann + -> (Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()), cost) runCekNoEmit = Common.runCekNoEmit runCekDeBruijn {-| Evaluate a term using the CEK machine with logging enabled. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} evaluateCek - :: ThrowableBuiltins uni fun - => EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => EmitterMode uni fun pat + -> MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> (Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()), [Text]) evaluateCek = Common.evaluateCek runCekDeBruijn {-| Evaluate a term using the CEK machine with logging disabled. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} evaluateCekNoEmit - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()) evaluateCekNoEmit = Common.evaluateCekNoEmit runCekDeBruijn {-| Unlift a value using the CEK machine. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} readKnownCek - :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) a + :: ( ThrowableBuiltins uni fun + , Pretty pat + , Typeable pat + , ReadKnown (Term Name uni fun pat ()) a + ) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> Either (CekEvaluationException Name uni fun pat) a readKnownCek = Common.readKnownCek runCekDeBruijn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs index 51c0ae24b71..3a1cebf9a3d 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs @@ -48,6 +48,25 @@ data CekMachineCostsBase f happen if calling 'Error' caused the budget to be exceeded? -} , cekConstrCost :: f ExBudget , cekCaseCost :: f ExBudget + , cekMatchCost :: f ExBudget + {-^ Fixed cost of entering a 'Match' node. This is separate from 'cekPatternCost' so repeated + shallow matches remain bounded without making wide structural matching more expensive than the + equivalent builtin program. -} + , cekPatternCost :: f ExBudget + {-^ Cost of cheap, incrementally spent Match work: an alternative/root probe, one compared + 64-bit bytestring word, or one unit of reached-capture work. Each reached capture spends two + units before retention: one for its eventual strict spine cell and one for its implicit handler + application. -} + , cekPatternStructuralCost :: f ExBudget + {-^ Cost of one reached Match child/field edge, including dispatch of that child and the bounded + exact-arity probe at the edge. It is separate because direct affordability spending plus + structural traversal is materially more expensive than scalar work. -} + , cekPatternFailureCost :: f ExBudget + {-^ Cost of abandoning a known-failed alternative, advancing, and probing the next ordered + alternative. The work that discovers the mismatch is covered by its preceding base or structural + charge; this cost is spent before the transition and next probe. There is no pattern pre-scan, + cached measure, or refund. Reached captures retain their earlier materialization/application + charge even when later work abandons the alternative. -} } deriving stock (Generic) deriving anyclass (FunctorB, TraversableB, ConstraintsB) @@ -96,6 +115,10 @@ unitCekMachineCosts = , cekBuiltinCost = unitCost , cekConstrCost = unitCost , cekCaseCost = unitCost + , cekMatchCost = unitCost + , cekPatternCost = unitCost + , cekPatternStructuralCost = unitCost + , cekPatternFailureCost = unitCost } where zeroCost = Identity $ ExBudget 0 0 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs index 90e34e8e34a..a8ee6d99499 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs @@ -29,11 +29,11 @@ import PlutusCore.Evaluation.Machine.ExBudget import PlutusCore.Evaluation.Machine.ExMemory -- | No emitter. -noEmitter :: EmitterMode uni fun +noEmitter :: EmitterMode uni fun pat noEmitter = EmitterMode $ \_ -> pure $ CekEmitterInfo (\_ -> pure ()) (pure mempty) -- | Emits log only. -logEmitter :: EmitterMode uni fun +logEmitter :: EmitterMode uni fun pat logEmitter = EmitterMode $ \_ -> do logsRef <- newSTRef DList.empty let emitter logs = CekM $ modifySTRef logsRef (`DList.append` logs) @@ -45,7 +45,7 @@ encodeRecord :: CSV.ToRecord a => a -> T.Text encodeRecord a = T.stripEnd $ T.decodeUtf8 $ BSL.toStrict $ BS.toLazyByteString $ CSV.encodeRecord a -- | Emits log with timestamp. -logWithTimeEmitter :: EmitterMode uni fun +logWithTimeEmitter :: EmitterMode uni fun pat logWithTimeEmitter = EmitterMode $ \_ -> do logsRef <- newSTRef DList.empty let emitter logs = CekM $ do @@ -62,7 +62,7 @@ instance CSV.ToField ExMemory where toField (ExMemory t) = CSV.toField $ unSatInt t -- | Emits log with the budget. -logWithBudgetEmitter :: EmitterMode uni fun +logWithBudgetEmitter :: EmitterMode uni fun pat logWithBudgetEmitter = EmitterMode $ \getBudget -> do logsRef <- newSTRef DList.empty let emitter logs = CekM $ do @@ -84,7 +84,7 @@ When script evaluation fails, this emitter will give call trace of the functions evaluation failure. This is useful for pin-pointing specific area of the codebase that caused failure when debugging a script. When script evaluation passes, every trace message generated by `profile-all` flag will be removed, and this emitter will behave identically to 'logEmitter'. -} -logWithCallTraceEmitter :: EmitterMode uni fun +logWithCallTraceEmitter :: EmitterMode uni fun pat logWithCallTraceEmitter = EmitterMode $ \_ -> do logsRef <- newSTRef DList.empty let diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/ExBudgetMode.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/ExBudgetMode.hs index 1e259897bc5..94fe85663fa 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/ExBudgetMode.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/ExBudgetMode.hs @@ -48,7 +48,7 @@ import Text.PrettyBy (IgnorePrettyConfig (..)) {-| Construct an 'ExBudgetMode' out of a function returning a value of the budgeting state type. The value then gets added to the current state via @(<>)@. -} monoidalBudgeting - :: Monoid cost => (ExBudgetCategory fun -> ExBudget -> cost) -> ExBudgetMode cost uni fun + :: Monoid cost => (ExBudgetCategory fun -> ExBudget -> cost) -> ExBudgetMode cost uni fun pat monoidalBudgeting toCost = ExBudgetMode $ do costRef <- newSTRef mempty budgetRef <- newSTRef mempty @@ -69,7 +69,7 @@ instance Pretty CountingSt where pretty (CountingSt budget) = parens $ "required budget:" <+> pretty budget <> line -- | For calculating the cost of execution. -counting :: ExBudgetMode CountingSt uni fun +counting :: ExBudgetMode CountingSt uni fun pat counting = monoidalBudgeting $ const CountingSt {-| For a detailed report on what costs how much + the same overall budget that 'Counting' gives. @@ -109,7 +109,7 @@ instance (Show fun, Ord fun) => Pretty (TallyingSt fun) where ] -- | For a detailed report on what costs how much + the same overall budget that 'Counting' gives. -tallying :: Hashable fun => ExBudgetMode (TallyingSt fun) uni fun +tallying :: Hashable fun => ExBudgetMode (TallyingSt fun) uni fun pat tallying = monoidalBudgeting $ \key budgetToSpend -> TallyingSt (CekExTally $ singleton key budgetToSpend) budgetToSpend @@ -124,8 +124,8 @@ instance Pretty RestrictingSt where -- | For execution, to avoid overruns. restricting - :: ThrowableBuiltins uni fun - => ExRestrictingBudget -> ExBudgetMode RestrictingSt uni fun + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => ExRestrictingBudget -> ExBudgetMode RestrictingSt uni fun pat restricting (ExRestrictingBudget initB@(ExBudget cpuInit memInit)) = ExBudgetMode $ do -- We keep the counters in a PrimArray. This is better than an STRef since it stores its contents unboxed. -- @@ -172,9 +172,13 @@ restricting (ExRestrictingBudget initB@(ExBudget cpuInit memInit)) = ExBudgetMod pure $ ExBudgetInfo spender final cumulative -- | 'restricting' instantiated at 'largeBudget'. -restrictingLarge :: ThrowableBuiltins uni fun => ExBudgetMode RestrictingSt uni fun +restrictingLarge + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => ExBudgetMode RestrictingSt uni fun pat restrictingLarge = restricting largeBudget -- | 'restricting' instantiated at 'enormousBudget'. -restrictingEnormous :: ThrowableBuiltins uni fun => ExBudgetMode RestrictingSt uni fun +restrictingEnormous + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => ExBudgetMode RestrictingSt uni fun pat restrictingEnormous = restricting enormousBudget 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 index 071744a494c..91187323062 100644 --- 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 @@ -5,6 +5,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} @@ -93,7 +94,7 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts import UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter import Control.Exception qualified as Exception -import Control.Monad (unless, when) +import Control.Monad (when) import Control.Monad.Catch import Control.Monad.Except (MonadError, catchError, throwError, tryError) import Control.Monad.Primitive (PrimMonad (..)) @@ -168,17 +169,17 @@ this can make a surprisingly large difference. {-| The 'Term's that CEK can execute must have DeBruijn binders 'Name' is not necessary but we leave it here for simplicity and debuggability. -} -type NTerm uni fun = Term NamedDeBruijn uni fun +type NTerm uni fun pat = Term NamedDeBruijn uni fun pat -- | The result of evaluating a term with the CEK machine. -data CekResult name uni fun - = CekFailure (CekEvaluationException name uni fun) +data CekResult name uni fun pat + = CekFailure (CekEvaluationException name uni fun pat) | CekSuccessConstant (Some (ValueOf uni)) - | CekSuccessNonConstant (Term name uni fun ()) + | CekSuccessNonConstant (Term name uni fun pat ()) -- | All info produced by a CEK machine run. -data CekReport cost name uni fun = CekReport - { _cekReportResult :: CekResult name uni fun +data CekReport cost name uni fun pat = CekReport + { _cekReportResult :: CekResult name uni fun pat -- ^ The result of evaluation. , _cekReportCost :: cost -- ^ The final @cost@ value. @@ -190,17 +191,17 @@ data CekReport cost name uni fun = CekReport This is useful, because in the ledger API we care whether the result is a constant or not, but in tests, executables etc we don't and so handling an either-error-or-term is more natural. -} cekResultToEither - :: CekResult name uni fun - -> Either (CekEvaluationException name uni fun) (Term name uni fun ()) + :: CekResult name uni fun pat + -> Either (CekEvaluationException name uni fun pat) (Term name uni fun pat ()) cekResultToEither (CekFailure err) = Left err cekResultToEither (CekSuccessConstant val) = Right $ Constant () val cekResultToEither (CekSuccessNonConstant term) = Right term -- | Apply the given function to the 'Term' (if any) stored in the given 'CekResult'. mapTermCekResult - :: (Term name uni fun () -> Term name' uni fun ()) - -> CekResult name uni fun - -> CekResult name' uni fun + :: (Term name uni fun pat () -> Term name' uni fun pat ()) + -> CekResult name uni fun pat + -> CekResult name' uni fun pat mapTermCekResult f (CekFailure err) = CekFailure $ f <$> err mapTermCekResult _ (CekSuccessConstant val) = CekSuccessConstant val mapTermCekResult f (CekSuccessNonConstant term) = CekSuccessNonConstant $ f term @@ -215,6 +216,7 @@ data StepKind | BBuiltin -- Cost of evaluating a Builtin AST node, not the function itself | BConstr | BCase + | BMatch deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) deriving anyclass (NFData, Hashable) @@ -230,9 +232,11 @@ cekStepCost costs = BBuiltin -> cekBuiltinCost costs BConstr -> cekConstrCost costs BCase -> cekCaseCost costs + BMatch -> cekMatchCost costs data ExBudgetCategory fun = BStep StepKind + | BPattern -- Fixed Match entry and incrementally spent pattern work | BBuiltinApp fun -- Cost of evaluating a fully applied builtin function | BStartup deriving stock (Show, Eq, Ord, Generic) @@ -249,48 +253,48 @@ but functions are not printable and hence we provide a dummy instance. -} -- See Note [Show instance for BuiltinRuntime]. -instance Show (BuiltinRuntime (CekValue uni fun ann)) where +instance Show (BuiltinRuntime (CekValue uni fun pat ann)) where show _ = "" {-| A LIFO stack of 'CekValue's, used to record multiple arguments that need to be pushed onto the context in reverse order. Currently used by 'FrameConstr' for collecting the elements of a 'Constr' as it is cheap to prepend new elements in 'ArgStack'. -} -data ArgStack uni fun ann +data ArgStack uni fun pat ann = NilStack - | ConsStack !(CekValue uni fun ann) !(ArgStack uni fun ann) + | ConsStack !(CekValue uni fun pat ann) !(ArgStack uni fun pat ann) {-| A non-empty variant of 'ArgStack', used in 'FrameAwaitFunValueN' to store arguments that will be applied to a term. More efficient than 'ArgStack', since this saves one evaluation cycle by ensuring there is no 'NilStack'. -} -data ArgStackNonEmpty uni fun ann - = LastStackNonEmpty !(CekValue uni fun ann) - | ConsStackNonEmpty !(CekValue uni fun ann) !(ArgStackNonEmpty uni fun ann) +data ArgStackNonEmpty uni fun pat ann + = LastStackNonEmpty !(CekValue uni fun pat ann) + | ConsStackNonEmpty !(CekValue uni fun pat ann) !(ArgStackNonEmpty uni fun pat ann) {-| An alternative version of 'ArgStack' that uses 'ArgNonEmptyStack' when non-empty. Used in 'VConstr'. Once all evaluated elements of 'Constr' is collecting to 'ArgStack' in 'FrameConstr', the collected elements gets reversed and put into 'VConstr' as `EmptyOrMultiStack`. 'VConstr' using `EmptyOrMultiStack` is more efficient than 'ArgStack' when casing, since 'FrameAwaitFunValueN' can be dispatched with a single pattern match. -} -data EmptyOrMultiStack uni fun ann +data EmptyOrMultiStack uni fun pat ann = EmptyStack - | MultiStack !(ArgStackNonEmpty uni fun ann) + | MultiStack !(ArgStackNonEmpty uni fun pat ann) deriving stock instance - (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (ArgStack uni fun ann) + (GShow uni, Everywhere uni Show, Show fun, Show pat, Show ann, Closed uni) + => Show (ArgStack uni fun pat ann) deriving stock instance - (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (EmptyOrMultiStack uni fun ann) + (GShow uni, Everywhere uni Show, Show fun, Show pat, Show ann, Closed uni) + => Show (EmptyOrMultiStack uni fun pat ann) deriving stock instance - (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (ArgStackNonEmpty uni fun ann) + (GShow uni, Everywhere uni Show, Show fun, Show pat, Show ann, Closed uni) + => Show (ArgStackNonEmpty uni fun pat ann) -- 'Values' for the modified CEK machine. -data CekValue uni fun ann +data CekValue uni fun pat ann = -- This bang gave us a 1-2% speed-up at the time of writing. VCon !(Some (ValueOf uni)) - | VDelay !(NTerm uni fun ann) !(CekValEnv uni fun ann) - | VLamAbs !NamedDeBruijn !(NTerm uni fun ann) !(CekValEnv uni fun ann) + | VDelay !(NTerm uni fun pat ann) !(CekValEnv uni fun pat ann) + | VLamAbs !NamedDeBruijn !(NTerm uni fun pat ann) !(CekValEnv uni fun pat ann) | {-| A partial builtin application, accumulating arguments for eventual full application. We don't need a 'CekValEnv' here unlike in the other constructors, because 'VBuiltin' values always store their corresponding 'Term's fully discharged, see the comments at @@ -302,37 +306,37 @@ data CekValue uni fun ann consistently slowing evaluation down by half a percent. Might be noise, might be not, but at least we know that removing this @fun@ is not helpful anyway. See this commit reversing the change: https://github.com/IntersectMBO/plutus/pull/4778/commits/86a3e24ca3c671cc27c6f4344da2bcd14f961706 -} - (NTerm uni fun ()) + (NTerm uni fun pat ()) {-^ This must be lazy. It represents the fully discharged partial application of the builtin function that we're going to run when it's fully saturated. We need the 'Term' to be able to return it in case full saturation is never achieved and a partial application needs to be returned in the result. The laziness is important, because the arguments are discharged values and discharging is expensive, so we don't want to do it unless we really have to. Making this field strict resulted in a 3-4.5% slowdown at the time of writing. -} - !(BuiltinRuntime (CekValue uni fun ann)) + !(BuiltinRuntime (CekValue uni fun pat ann)) {-^ The partial application and its costing function. Check the docs of 'BuiltinRuntime' for details. | A constructor value, including fully computed arguments and the tag. -} - | VConstr {-# UNPACK #-} !Word64 !(EmptyOrMultiStack uni fun ann) + | VConstr {-# UNPACK #-} !Word64 !(EmptyOrMultiStack uni fun pat ann) deriving stock instance - (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (CekValue uni fun ann) + (GShow uni, Everywhere uni Show, Show fun, Show pat, Show ann, Closed uni) + => Show (CekValue uni fun pat ann) -type CekValEnv uni fun ann = Env.RAList (CekValue uni fun ann) +type CekValEnv uni fun pat ann = Env.RAList (CekValue uni fun pat ann) {-| The CEK machine is parameterized over a @spendBudget@ function. This makes the budgeting machinery extensible and allows us to separate budgeting logic from evaluation logic and avoid branching on the union of all possible budgeting state types during evaluation. -} -newtype CekBudgetSpender uni fun s = CekBudgetSpender - { unCekBudgetSpender :: ExBudgetCategory fun -> ExBudget -> CekM uni fun s () +newtype CekBudgetSpender uni fun pat s = CekBudgetSpender + { unCekBudgetSpender :: ExBudgetCategory fun -> ExBudget -> CekM uni fun pat s () } -- General enough to be able to handle a spender having one, two or any number of 'STRef's -- under the hood. -- | Runtime budgeting info. -data ExBudgetInfo cost uni fun s = ExBudgetInfo - { _exBudgetModeSpender :: !(CekBudgetSpender uni fun s) +data ExBudgetInfo cost uni fun pat s = ExBudgetInfo + { _exBudgetModeSpender :: !(CekBudgetSpender uni fun pat s) -- ^ A spending function. , _exBudgetModeGetFinal :: !(ST s cost) -- ^ For accessing the final state. @@ -343,8 +347,8 @@ data ExBudgetInfo cost uni fun s = ExBudgetInfo -- We make a separate data type here just to save the caller of the CEK machine from those pesky -- 'ST'-related details. -- | A budgeting mode to execute the CEK machine in. -newtype ExBudgetMode cost uni fun = ExBudgetMode - { unExBudgetMode :: forall s. ST s (ExBudgetInfo cost uni fun s) +newtype ExBudgetMode cost uni fun pat = ExBudgetMode + { unExBudgetMode :: forall s. ST s (ExBudgetInfo cost uni fun pat s) } {- Note [Cost slippage] @@ -381,10 +385,12 @@ we opted for option 1, which also happens to be simpler to implement. {- Note [Structure of the step counter] The step counter is kept in a 'MutablePrimArray', which is a fast way of storing a bunch of mutable 'Word8's. -This suits our purposes, as we need one counter for every step type, and one for the total number. +This suits our purposes, as we need one counter for every step type and one for the total number. We keep the counters for each step in the first indices, so we can index them simply by using -the 'Enum' instance of 'StepKind', and the total counter in the last index. +the 'Enum' instance of 'StepKind'. The total counter follows those indices. Pattern matching is +charged incrementally through direct affordability spends, so it must not share this +bounded-slippage counter. -} -- So that we don't need to update 'NumberOfStepCounters' manually, which would be extremely @@ -405,7 +411,7 @@ type family CountConstructorsEnum rep where of 'StepKind'. -} type NumberOfStepCounters = CountConstructorsEnum (Rep StepKind) -{-| The total number of counters that we need, one extra for the total counter. +{-| The total number of counters that we need: one extra for the total step counter. See Note [Structure of the step counter] -} type CounterSize = NumberOfStepCounters + 1 @@ -430,17 +436,17 @@ https://github.com/IntersectMBO/plutus/pull/4421#issuecomment-1059186586 -- See Note [DList-based emitting]. -- | The CEK machine is parameterized over an emitter function, similar to 'CekBudgetSpender'. -type CekEmitter uni fun s = DList.DList Text -> CekM uni fun s () +type CekEmitter uni fun pat s = DList.DList Text -> CekM uni fun pat s () -- | Runtime emitter info, similar to 'ExBudgetInfo'. -data CekEmitterInfo uni fun s = CekEmitterInfo - { _cekEmitterInfoEmit :: !(CekEmitter uni fun s) +data CekEmitterInfo uni fun pat s = CekEmitterInfo + { _cekEmitterInfoEmit :: !(CekEmitter uni fun pat s) , _cekEmitterInfoGetFinal :: !(ST s [Text]) } -- | An emitting mode to execute the CEK machine in, similar to 'ExBudgetMode'. -newtype EmitterMode uni fun = EmitterMode - { unEmitterMode :: forall s. ST s ExBudget -> ST s (CekEmitterInfo uni fun s) +newtype EmitterMode uni fun pat = EmitterMode + { unEmitterMode :: forall s. ST s ExBudget -> ST s (CekEmitterInfo uni fun pat s) } {- Note [Implicit parameters in the machine] @@ -469,26 +475,30 @@ they don't actually take the context as an argument even at the source level. -} -- | Implicit parameter for the builtin runtime. -type GivenCekRuntime uni fun ann = (?cekRuntime :: BuiltinsRuntime fun (CekValue uni fun ann)) +type GivenCekRuntime uni fun pat ann = + (?cekRuntime :: BuiltinsRuntime fun (CekValue uni fun pat ann)) type GivenCekCaserBuiltin uni = (?cekCaserBuiltin :: CaserBuiltin uni) +type GivenCekMatcherBuiltin uni pat = (?cekMatcherBuiltin :: MatcherBuiltin uni pat) + -- | Implicit parameter for the log emitter reference. -type GivenCekEmitter uni fun s = (?cekEmitter :: CekEmitter uni fun s) +type GivenCekEmitter uni fun pat s = (?cekEmitter :: CekEmitter uni fun pat s) -- | Implicit parameter for budget spender. -type GivenCekSpender uni fun s = (?cekBudgetSpender :: CekBudgetSpender uni fun s) +type GivenCekSpender uni fun pat s = (?cekBudgetSpender :: CekBudgetSpender uni fun pat s) type GivenCekSlippage = (?cekSlippage :: Slippage) type GivenCekStepCounter s = (?cekStepCounter :: StepCounter CounterSize s) type GivenCekCosts = (?cekCosts :: CekMachineCosts) -- | Constraint requiring all of the machine's implicit parameters. -type GivenCekReqs uni fun ann s = - ( GivenCekRuntime uni fun ann +type GivenCekReqs uni fun pat ann s = + ( GivenCekRuntime uni fun pat ann , GivenCekCaserBuiltin uni - , GivenCekEmitter uni fun s - , GivenCekSpender uni fun s + , GivenCekMatcherBuiltin uni pat + , GivenCekEmitter uni fun pat s + , GivenCekSpender uni fun pat s , GivenCekSlippage , GivenCekStepCounter s , GivenCekCosts @@ -497,6 +507,8 @@ type GivenCekReqs uni fun ann s = data CekUserError = -- | 'Case' over a value of a built-in type failed. CekCaseBuiltinError Text + | -- | Built-in matching was unavailable, invalid for the scrutinee, or no pattern matched. + CekPatternMatchError Text | -- | The final overspent (i.e. negative) budget. CekOutOfExError !ExRestrictingBudget | -- | Error has been called or a builtin application has failed @@ -504,17 +516,18 @@ data CekUserError deriving stock (Show, Eq, Generic) deriving anyclass (NFData) -type CekM :: (GHC.Type -> GHC.Type) -> GHC.Type -> GHC.Type -> GHC.Type -> GHC.Type +type CekM + :: (GHC.Type -> GHC.Type) -> GHC.Type -> GHC.Type -> GHC.Type -> GHC.Type -> GHC.Type -- | The monad the CEK machine runs in. -newtype CekM uni fun s a = CekM +newtype CekM uni fun pat s a = CekM { unCekM :: ST s a } deriving newtype (Functor, Applicative, Monad, PrimMonad) -- | The CEK machine-specific 'EvaluationException'. -type CekEvaluationException name uni fun = - EvaluationException (MachineError fun) CekUserError (Term name uni fun ()) +type CekEvaluationException name uni fun pat = + EvaluationException (MachineError fun) CekUserError (Term name uni fun pat ()) instance BuiltinErrorToEvaluationError (MachineError fun) CekUserError where builtinErrorToEvaluationError (BuiltinUnliftingEvaluationError err) = @@ -553,15 +566,15 @@ But in our case this is okay, because: {-| Call 'dischargeCekValue' over the received 'CekVal' and feed the resulting 'Term' to 'throwErrorWithCause' as the cause of the failure. -} throwErrorDischarged - :: ThrowableBuiltins uni fun + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) => EvaluationError (MachineError fun) CekUserError - -> CekValue uni fun ann - -> CekM uni fun s x + -> CekValue uni fun pat ann + -> CekM uni fun pat s x throwErrorDischarged err = throwErrorWithCause err . dischargeResultToTerm . dischargeCekValue instance - ThrowableBuiltins uni fun - => MonadError (CekEvaluationException NamedDeBruijn uni fun) (CekM uni fun s) + (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MonadError (CekEvaluationException NamedDeBruijn uni fun pat) (CekM uni fun pat s) where -- See Note [Throwing exceptions in ST]. throwError = CekM . throwM @@ -569,9 +582,9 @@ instance -- See Note [Catching exceptions in ST]. catchError :: forall a - . CekM uni fun s a - -> (CekEvaluationException NamedDeBruijn uni fun -> CekM uni fun s a) - -> CekM uni fun s a + . CekM uni fun pat s a + -> (CekEvaluationException NamedDeBruijn uni fun pat -> CekM uni fun pat s a) + -> CekM uni fun pat s a a `catchError` h = -- Here in addition to catching 'CekEvaluationException' we also catch common GHC exceptions -- in case one of them somehow gets triggered during script execution (which would be a bug @@ -596,7 +609,7 @@ instance -- Unsafely run a 'CekM' computation in the 'IO' monad by converting the underlying 'ST' to -- it. - unsafeRunCekM :: CekM uni fun s a -> IO a + unsafeRunCekM :: CekM uni fun pat s a -> IO a unsafeRunCekM = unsafeSTToIO . unCekM panicHandler :: forall e. Exception e => Handler IO a @@ -613,6 +626,11 @@ instance Pretty CekUserError where [ "'case' over a value of a built-in type failed with" , pretty err ] + pretty (CekPatternMatchError err) = + vcat + [ "Pattern matching failed with" + , pretty err + ] pretty (CekOutOfExError (ExRestrictingBudget res)) = cat [ "The machine terminated part way through evaluation due to overspending the budget." @@ -623,42 +641,46 @@ instance Pretty CekUserError where pretty CekEvaluationFailure = "The machine terminated because of an error, either from a built-in function or from an explicit use of 'error'." -argNonEmptyStackToList :: ArgStackNonEmpty uni fun ann -> [CekValue uni fun ann] +argNonEmptyStackToList :: ArgStackNonEmpty uni fun pat ann -> [CekValue uni fun pat ann] argNonEmptyStackToList (LastStackNonEmpty val) = [val] argNonEmptyStackToList (ConsStackNonEmpty val stack) = val : argNonEmptyStackToList stack -- | Convert the given 'EmptyOrMultiStack to a list. -argStackToList :: EmptyOrMultiStack uni fun ann -> [CekValue uni fun ann] +argStackToList :: EmptyOrMultiStack uni fun pat ann -> [CekValue uni fun pat ann] argStackToList EmptyStack = [] argStackToList (MultiStack stack) = argNonEmptyStackToList stack -- | The result of 'dischargeCekValue'. -data DischargeResult uni fun +data DischargeResult uni fun pat = DischargeConstant (Some (ValueOf uni)) - | DischargeNonConstant (NTerm uni fun ()) + | DischargeNonConstant (NTerm uni fun pat ()) deriving stock instance - (GShow uni, Everywhere uni Show, Show fun, Closed uni) - => Show (DischargeResult uni fun) + (GShow uni, Everywhere uni Show, Show fun, Show pat, Closed uni) + => Show (DischargeResult uni fun pat) deriving stock instance - (GEq uni, Everywhere uni Eq, Eq fun, Closed uni) - => Eq (DischargeResult uni fun) + (GEq uni, Everywhere uni Eq, Eq fun, Eq pat, Closed uni) + => Eq (DischargeResult uni fun pat) -instance (PrettyUni uni, Pretty fun) => PrettyBy PrettyConfigPlc (DischargeResult uni fun) where +instance + (PrettyUni uni, Pretty fun, Pretty pat) + => PrettyBy PrettyConfigPlc (DischargeResult uni fun pat) + where prettyBy cfg = prettyBy cfg . dischargeResultToTerm -dischargeResultToTerm :: DischargeResult uni fun -> NTerm uni fun () +dischargeResultToTerm :: DischargeResult uni fun pat -> NTerm uni fun pat () dischargeResultToTerm (DischargeConstant val) = Constant () val dischargeResultToTerm (DischargeNonConstant term) = term {-| Convert a 'CekValue' into a 'Term' by replacing all bound variables with the terms they're bound to (which themselves have to be obtained by recursively discharging values). -} -dischargeCekValue :: forall uni fun ann. CekValue uni fun ann -> DischargeResult uni fun +dischargeCekValue + :: forall uni fun pat ann. CekValue uni fun pat ann -> DischargeResult uni fun pat dischargeCekValue (VCon val) = DischargeConstant val dischargeCekValue value0 = DischargeNonConstant $ goValue value0 where - goValue :: CekValue uni fun ann -> NTerm uni fun () + goValue :: CekValue uni fun pat ann -> NTerm uni fun pat () goValue = \case VCon val -> Constant () val VDelay body env -> Delay () $ goValEnv env 0 body @@ -673,12 +695,16 @@ dischargeCekValue value0 = DischargeNonConstant $ goValue value0 -- Instantiate all the free variables of a term by looking them up in an environment. -- Mutually recursive with @goValue@. - goValEnv :: CekValEnv uni fun ann -> Word64 -> NTerm uni fun ann -> NTerm uni fun () + goValEnv + :: CekValEnv uni fun pat ann + -> Word64 + -> NTerm uni fun pat ann + -> NTerm uni fun pat () goValEnv env = go where -- @shift@ is just a counter that measures how many lambda-abstractions we have descended -- into so far. - go :: Word64 -> NTerm uni fun ann -> NTerm uni fun () + go :: Word64 -> NTerm uni fun pat ann -> NTerm uni fun pat () go !shift = \case LamAbs _ name body -> LamAbs () name $ go (shift + 1) body Var _ named@(NamedDeBruijn _ (coerce -> idx)) -> @@ -702,13 +728,18 @@ dischargeCekValue value0 = DischargeNonConstant $ goValue value0 Error _ -> Error () Constr _ ind args -> Constr () ind $ map (go shift) args Case _ scrut alts -> Case () (go shift scrut) $ fmap (go shift) alts + Match _ scrut alternatives -> + Match () (go shift scrut) $ fmap (fmap (go shift)) alternatives -instance (PrettyUni uni, Pretty fun) => PrettyBy PrettyConfigPlc (CekValue uni fun ann) where +instance + (PrettyUni uni, Pretty fun, Pretty pat) + => PrettyBy PrettyConfigPlc (CekValue uni fun pat ann) + where prettyBy cfg = prettyBy cfg . dischargeResultToTerm . dischargeCekValue -type instance UniOf (CekValue uni fun ann) = uni +type instance UniOf (CekValue uni fun pat ann) = uni -instance HasConstant (CekValue uni fun ann) where +instance HasConstant (CekValue uni fun pat ann) where asConstant (VCon val) = pure val asConstant _ = throwError notAConstant {-# INLINE asConstant #-} @@ -721,35 +752,49 @@ The context in which the machine operates. Morally, this is a stack of frames, but we use the "intrusive list" representation so that we can match on context and the top frame in a single, strict pattern match. -} -data Context uni fun ann +data Context uni fun pat ann = -- | @[V _]@ - FrameAwaitArg !(CekValue uni fun ann) !(Context uni fun ann) + FrameAwaitArg !(CekValue uni fun pat ann) !(Context uni fun pat ann) | -- | @[_ N]@ - FrameAwaitFunTerm !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) + FrameAwaitFunTerm + !(CekValEnv uni fun pat ann) + !(NTerm uni fun pat ann) + !(Context uni fun pat ann) | -- | @[_ V]@ - FrameAwaitFunConN !(Spine (Some (ValueOf uni))) !(Context uni fun ann) + FrameAwaitFunConN !(Spine (Some (ValueOf uni))) !(Context uni fun pat ann) | -- | @[_ V1 .. Vn]@ - FrameAwaitFunValueN !(ArgStackNonEmpty uni fun ann) !(Context uni fun ann) + FrameAwaitFunValueN !(ArgStackNonEmpty uni fun pat ann) !(Context uni fun pat ann) | {-| @(force _)@ See Note [Accumulators for terms] -} - FrameForce !(Context uni fun ann) + FrameForce !(Context uni fun pat ann) | -- | @(constr i V0 ... Vj-1 _ Nj ... Nn)@ FrameConstr - !(CekValEnv uni fun ann) + !(CekValEnv uni fun pat ann) {-# UNPACK #-} !Word64 - ![NTerm uni fun ann] - !(ArgStack uni fun ann) - !(Context uni fun ann) + ![NTerm uni fun pat ann] + !(ArgStack uni fun pat ann) + !(Context uni fun pat ann) | -- | @(case _ C0 .. Cn)@ - FrameCases !(CekValEnv uni fun ann) !(V.Vector (NTerm uni fun ann)) !(Context uni fun ann) + FrameCases + !(CekValEnv uni fun pat ann) + !(V.Vector (NTerm uni fun pat ann)) + !(Context uni fun pat ann) + | -- | @(match _ (P0,H0) .. (Pn,Hn))@ + FrameMatches + !(CekValEnv uni fun pat ann) + !(V.Vector (pat, NTerm uni fun pat ann)) + !(Context uni fun pat ann) | NoFrame deriving stock instance - (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Context uni fun ann) + (GShow uni, Everywhere uni Show, Show fun, Show pat, Show ann, Closed uni) + => Show (Context uni fun pat ann) -- See Note [ExMemoryUsage instances for non-constants]. -instance (Closed uni, uni `Everywhere` ExMemoryUsage) => ExMemoryUsage (CekValue uni fun ann) where +instance + (Closed uni, uni `Everywhere` ExMemoryUsage) + => ExMemoryUsage (CekValue uni fun pat ann) + where memoryUsage = \case VCon c -> memoryUsage c VDelay {} -> singletonRose 1 @@ -773,15 +818,18 @@ directly to the head of the application. Which is why 'transferSpine' is a right -} runCekM - :: forall cost uni fun ann - . ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> (forall s. GivenCekReqs uni fun ann s => CekM uni fun s (DischargeResult uni fun)) - -> CekReport cost NamedDeBruijn uni fun + :: forall cost uni fun pat ann + . (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> EmitterMode uni fun pat + -> ( forall s + . GivenCekReqs uni fun pat ann s + => CekM uni fun pat s (DischargeResult uni fun pat) + ) + -> CekReport cost NamedDeBruijn uni fun pat runCekM - (MachineParameters caser (MachineVariantParameters costs runtime)) + (MachineParameters caser matcher (MachineVariantParameters costs runtime)) (ExBudgetMode getExBudgetInfo) (EmitterMode getEmitterMode) a = runST $ do @@ -792,6 +840,7 @@ runCekM ctr <- newCounter (Proxy @CounterSize) let ?cekRuntime = runtime ?cekCaserBuiltin = caser + ?cekMatcherBuiltin = matcher ?cekEmitter = _cekEmitterInfoEmit ?cekBudgetSpender = _exBudgetModeSpender ?cekCosts = costs @@ -807,17 +856,55 @@ runCekM pure $ CekReport res st logs {-# INLINE runCekM #-} +{-| Keep the universe-specific case and match operations and the pattern-spending function behind +a single pointer in the production evaluator's hot recursive group. This value is constructed once +per evaluator invocation, not once per 'Match' node. -} +data CekCaseMatchers uni fun pat s + = CekCaseMatchers + !(CaserBuiltin uni) + !(MatcherBuiltin uni pat) + !(PatternWork -> CekM uni fun pat s ()) + -- See Note [Compilation peculiarities]. -- | The entering point to the CEK machine's engine. enterComputeCek - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValEnv uni fun ann - -> NTerm uni fun ann - -> CekM uni fun s (DischargeResult uni fun) + :: forall uni fun pat ann s + . ( ThrowableBuiltins uni fun + , Pretty pat + , Typeable pat + , GivenCekReqs uni fun pat ann s + ) + => Context uni fun pat ann + -> CekValEnv uni fun pat ann + -> NTerm uni fun pat ann + -> CekM uni fun pat s (DischargeResult uni fun pat) enterComputeCek = computeCek where + -- This is deliberately shared by the whole recursive group. The old implicit parameters stay + -- at the exported boundary for the steppable evaluator, while the production worker captures + -- one packed pointer in place of separate case, match, and pattern-spending references. + !patternCost = runIdentity $ cekPatternCost ?cekCosts + !patternStructuralCost = runIdentity $ cekPatternStructuralCost ?cekCosts + !patternFailureCost = runIdentity $ cekPatternFailureCost ?cekCosts + !spendPattern = \case + PatternWork units -> case units of + 0 -> pure () + 1 -> unCekBudgetSpender ?cekBudgetSpender BPattern patternCost + _ -> + unCekBudgetSpender + ?cekBudgetSpender + BPattern + (stimes (toInteger units) patternCost) + PatternStructuralWork -> + unCekBudgetSpender ?cekBudgetSpender BPattern patternStructuralCost + PatternFailureWork -> + unCekBudgetSpender ?cekBudgetSpender BPattern patternFailureCost + !caseMatchers = + CekCaseMatchers + ?cekCaserBuiltin + ?cekMatcherBuiltin + spendPattern + -- \| The computing part of the CEK machine. -- Either -- 1. adds a frame to the context and calls 'computeCek' ('Force', 'Apply') @@ -825,10 +912,10 @@ enterComputeCek = computeCek -- 3. throws 'EvaluationFailure' ('Error') -- 4. looks up a variable in the environment and calls 'returnCek' ('Var') computeCek - :: Context uni fun ann - -> CekValEnv uni fun ann - -> NTerm uni fun ann - -> CekM uni fun s (DischargeResult uni fun) + :: Context uni fun pat ann + -> CekValEnv uni fun pat ann + -> NTerm uni fun pat ann + -> CekM uni fun pat s (DischargeResult uni fun pat) -- s ; ρ ▻ {L A} ↦ s , {_ A} ; ρ ▻ L computeCek !ctx !env (Var _ varName) = do stepAndMaybeSpend BVar @@ -870,6 +957,10 @@ enterComputeCek = computeCek computeCek !ctx !env (Case _ scrut cs) = do stepAndMaybeSpend BCase computeCek (FrameCases env cs ctx) env scrut + -- s ; ρ ▻ match S (P0,H0) ... (Pn,Hn) ↦ s , match _ (...) ; ρ ▻ S + computeCek !ctx !env (Match _ scrut alternatives) = do + stepAndMaybeSpend BMatch + computeCek (FrameMatches env alternatives ctx) env scrut -- s ; ρ ▻ error ↦ <> A computeCek !_ !_ (Error _) = throwErrorWithCause (OperationalError CekEvaluationFailure) (Error ()) @@ -884,9 +975,9 @@ enterComputeCek = computeCek -- stored in the frame to an argument. -- returnCek - :: Context uni fun ann - -> CekValue uni fun ann - -> CekM uni fun s (DischargeResult uni fun) + :: Context uni fun pat ann + -> CekValue uni fun pat ann + -> CekM uni fun pat s (DischargeResult uni fun pat) --- Instantiate all the free variable of the resulting term in case there are any. -- . ◅ V ↦ [] V returnCek NoFrame val = do @@ -902,16 +993,27 @@ enterComputeCek = computeCek -- add rule for VBuiltin once it's in the specification. returnCek (FrameAwaitArg fun ctx) arg = applyEvaluate ctx fun arg - -- s , [_ V] ◅ lam x (M,ρ) ↦ s ; ρ [ x ↦ V ] ▻ M + -- Apply the constant spine exposed by an implicit builtin Case or Match branch. returnCek (FrameAwaitFunConN args ctx) fun = -- In the future, if we want to revert back to more general -- 'FrameAwaitFunValue (CekValue uni fun ann)', we can use optimization proposed in -- https://github.com/IntersectMBO/plutus/pull/7288. #7288 have almost equivalent -- performance improvement as using 'FrameAwaitFunConN' while keeping more general -- 'FrameAwaitFunValue'. - case args of - SpineLast arg -> applyEvaluate ctx fun (VCon arg) - SpineCons arg rest -> applyEvaluate (FrameAwaitFunConN rest ctx) fun (VCon arg) + case fun of + VLamAbs {} -> applyConstant + VBuiltin {} -> applyConstant + -- The implicit application did not inspect the handler, so recursively discharging a + -- constructor-shaped handler merely to populate the cause would be unbudgeted work. + _ -> do + spendAccumulatedBudget + throwError $ + ErrorWithCause (StructuralError NonFunctionalApplicationMachineError) Nothing + where + applyConstant = + case args of + SpineLast arg -> applyEvaluate ctx fun (VCon arg) + SpineCons arg rest -> applyEvaluate (FrameAwaitFunConN rest ctx) fun (VCon arg) -- s , [_ V1 .. Vn] ◅ lam x (M,ρ) ↦ s , [_ V2 .. Vn]; ρ [ x ↦ V1 ] ▻ M returnCek (FrameAwaitFunValueN args ctx) fun = case args of @@ -943,11 +1045,40 @@ enterComputeCek = computeCek MultiStack rest -> computeCek (FrameAwaitFunValueN rest ctx) env t Nothing -> throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e -- Proceed with caser when expression given is not Constr. - VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of - HeadError err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e - HeadOnly fX -> computeCek ctx env fX - HeadSpine f xs -> computeCek (FrameAwaitFunConN xs ctx) env f + VCon val -> case caseMatchers of + CekCaseMatchers caser _ _ -> case unCaserBuiltin caser val cs of + HeadError err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e + HeadOnly fX -> computeCek ctx env fX + HeadSpine f xs -> computeCek (FrameAwaitFunConN xs ctx) env f _ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e + returnCek (FrameMatches env alternatives ctx) scrutinee = do + -- Pattern work is spent without slippage. Flush ordinary CEK work once so subsequent matcher + -- spends are direct affordability barriers. A reached-capture spend intentionally reserves + -- its later spine materialization and implicit handler application. + spendAccumulatedBudget + case scrutinee of + VCon con -> case caseMatchers of + CekCaseMatchers _ matcher spendMatchPattern -> + ( CekM $ + runPatternMatchM + (unMatchBuiltin matcher con alternatives) + (\work -> unCekM $ spendMatchPattern work) + ) + >>= \case + HeadError err -> + -- Do not attach the scrutinee: rendering the diagnostic could discharge an + -- arbitrarily deep constructor value outside the budgeted pattern walk. + throwError $ ErrorWithCause (OperationalError $ CekPatternMatchError err) Nothing + HeadOnly handler -> computeCek ctx env handler + HeadSpine handler captures -> + computeCek (FrameAwaitFunConN captures ctx) env handler + _ -> + -- Do not attach the scrutinee: rendering the diagnostic could discharge an arbitrarily + -- deep constructor value outside the budgeted pattern walk. + throwError $ + ErrorWithCause + (OperationalError $ CekPatternMatchError "match scrutinee is not a built-in value") + Nothing -- \| @force@ a term and proceed. -- If v is a delay then compute the body of v; @@ -956,9 +1087,9 @@ enterComputeCek = computeCek -- representation depending on whether the application is saturated or not, -- if v is anything else, fail. forceEvaluate - :: Context uni fun ann - -> CekValue uni fun ann - -> CekM uni fun s (DischargeResult uni fun) + :: Context uni fun pat ann + -> CekValue uni fun pat ann + -> CekM uni fun pat s (DischargeResult uni fun pat) forceEvaluate !ctx (VDelay body env) = computeCek ctx env body forceEvaluate !ctx (VBuiltin fun term runtime) = do -- @term@ is fully discharged, and so @term'@ is, hence we can put it in a 'VBuiltin'. @@ -984,10 +1115,10 @@ enterComputeCek = computeCek -- representation depending on whether the application is saturated or not. -- If v is anything else, fail. applyEvaluate - :: Context uni fun ann - -> CekValue uni fun ann -- lhs of application - -> CekValue uni fun ann -- rhs of application - -> CekM uni fun s (DischargeResult uni fun) + :: Context uni fun pat ann + -> CekValue uni fun pat ann -- lhs of application + -> CekValue uni fun pat ann -- rhs of application + -> CekM uni fun pat s (DischargeResult uni fun pat) applyEvaluate !ctx (VLamAbs _ body env) arg = computeCek ctx (Env.cons arg env) body -- Annotating @f@ and @exF@ with bangs gave us some speed-up, but only until we added a bang to @@ -1008,7 +1139,7 @@ enterComputeCek = computeCek throwErrorDischarged (StructuralError NonFunctionalApplicationMachineError) val -- \| Spend the budget that has been accumulated for a number of machine steps. - spendAccumulatedBudget :: CekM uni fun s () + spendAccumulatedBudget :: CekM uni fun pat s () spendAccumulatedBudget = do let ctr = ?cekStepCounter iforCounter_ ctr spend @@ -1019,15 +1150,26 @@ enterComputeCek = computeCek -- Making this a definition of its own causes it to inline better than actually writing it inline, for -- some reason. - -- Skip index 7, that's the total counter! + -- Skip the total-count index and turn every other index back into its 'StepKind'. Fixed Match + -- steps retain the public 'BPattern' category even though they use the regular bounded step + -- counter. Matcher work is spent directly through its supplied spending function. -- See Note [Structure of the step counter] spend !i !w = - unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ - let kind = toEnum i in spendBudget (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) + if i == totalCountIndex + then pure () + else + let kind = toEnum i + in case kind of + BMatch -> + when (w /= 0) $ spendBudget BPattern $ stimes w (cekStepCost ?cekCosts kind) + _ -> spendBudget (BStep kind) $ stimes w (cekStepCost ?cekCosts kind) + where + totalCountIndex = fromIntegral $ natVal $ Proxy @TotalCountIndex {-# INLINE spend #-} - -- \| Accumulate a step, and maybe spend the budget that has accumulated for a number of machine steps, but only if we've exceeded our slippage. - stepAndMaybeSpend :: StepKind -> CekM uni fun s () + -- \| Accumulate a machine step, and maybe spend the budget that has accumulated, but only if + -- we've exceeded our slippage. + stepAndMaybeSpend :: StepKind -> CekM uni fun pat s () stepAndMaybeSpend !kind = do -- See Note [Structure of the step counter] -- This generates let-expressions in GHC Core, however all of them bind unboxed things and @@ -1050,11 +1192,11 @@ enterComputeCek = computeCek -- -- and proceed with the returning phase of the CEK machine. evalBuiltinApp - :: Context uni fun ann + :: Context uni fun pat ann -> fun - -> NTerm uni fun () - -> BuiltinRuntime (CekValue uni fun ann) - -> CekM uni fun s (DischargeResult uni fun) + -> NTerm uni fun pat () + -> BuiltinRuntime (CekValue uni fun pat ann) + -> CekM uni fun pat s (DischargeResult uni fun pat) evalBuiltinApp ctx fun term runtime = case runtime of BuiltinCostedResult budgets0 getFXs -> do let exCat = BBuiltinApp fun @@ -1074,12 +1216,15 @@ enterComputeCek = computeCek _ -> returnCek ctx $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} - spendBudget :: ExBudgetCategory fun -> ExBudget -> CekM uni fun s () + spendBudget :: ExBudgetCategory fun -> ExBudget -> CekM uni fun pat s () spendBudget = unCekBudgetSpender ?cekBudgetSpender {-# INLINE spendBudget #-} -- \| Look up a variable name in the environment. - lookupVarName :: NamedDeBruijn -> CekValEnv uni fun ann -> CekM uni fun s (CekValue uni fun ann) + lookupVarName + :: NamedDeBruijn + -> CekValEnv uni fun pat ann + -> CekM uni fun pat s (CekValue uni fun pat ann) lookupVarName varName@(NamedDeBruijn _ varIx) varEnv = Env.contIndexOne (throwErrorWithCause (StructuralError OpenTermEvaluatedMachineError) $ Var () varName) @@ -1091,12 +1236,12 @@ enterComputeCek = computeCek -- See Note [Compilation peculiarities]. -- | Evaluate a term using the CEK machine and keep track of costing, logging is optional. runCekDeBruijn - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> NTerm uni fun ann - -> CekReport cost NamedDeBruijn uni fun + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> EmitterMode uni fun pat + -> NTerm uni fun pat ann + -> CekReport cost NamedDeBruijn uni fun pat runCekDeBruijn params mode emitMode term = runCekM params mode emitMode $ do unCekBudgetSpender ?cekBudgetSpender BStartup $ runIdentity $ cekStartupCost ?cekCosts diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs index 3d161359d17..3e9cd0892e7 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/CommonAPI.hs @@ -73,12 +73,12 @@ import Control.Monad.State import Data.Text (Text) -- The type of the machine (runner function). -type MachineRunner cost uni fun ann = - MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> NTerm uni fun ann - -> CekReport cost NamedDeBruijn uni fun +type MachineRunner cost uni fun pat ann = + MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> EmitterMode uni fun pat + -> NTerm uni fun pat ann + -> CekReport cost NamedDeBruijn uni fun pat {- Note [CEK runners naming convention] A function whose name ends in @NoEmit@ does not perform logging and so does not return any logs. @@ -95,12 +95,12 @@ allow one to specify an 'ExBudgetMode'. I.e. such functions are only for fully e A wrapper around the internal runCek to debruijn input and undebruijn output. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} runCek - :: MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> Term Name uni fun ann - -> CekReport cost Name uni fun + :: MachineRunner cost uni fun pat ann + -> MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> EmitterMode uni fun pat + -> Term Name uni fun pat ann + -> CekReport cost Name uni fun pat runCek runner params mode emitMode term = -- translating input case runExcept @FreeVariableError $ deBruijnTerm term of @@ -116,7 +116,7 @@ runCek runner params mode emitMode term = -- \*value-term. -- 'Graceful' means that the (a) && (b) undebruijnifications do not throw an error upon a free -- variable encounter: free debruijn indices will be turned to free, consistent uniques - gracefulUnDeBruijn :: Term NamedDeBruijn uni fun () -> Term Name uni fun () + gracefulUnDeBruijn :: Term NamedDeBruijn uni fun pat () -> Term Name uni fun pat () gracefulUnDeBruijn t = runQuote . flip evalStateT mempty @@ -125,11 +125,11 @@ runCek runner params mode emitMode term = {-| Evaluate a term using a machine with logging disabled and keep track of costing. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} runCekNoEmit - :: MachineRunner cost uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) + :: MachineRunner cost uni fun pat ann + -> MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> Term Name uni fun pat ann + -> (Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()), cost) runCekNoEmit runner params mode = -- throw away the logs (\(CekReport res cost _logs) -> (cekResultToEither res, cost)) @@ -138,12 +138,12 @@ runCekNoEmit runner params mode = {-| Evaluate a term using a machine with logging enabled. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} evaluateCek - :: ThrowableBuiltins uni fun - => MachineRunner RestrictingSt uni fun ann - -> EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineRunner RestrictingSt uni fun pat ann + -> EmitterMode uni fun pat + -> MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> (Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()), [Text]) evaluateCek runner emitMode params = -- throw away the cost (\(CekReport res _cost logs) -> (cekResultToEither res, logs)) @@ -152,19 +152,23 @@ evaluateCek runner emitMode params = {-| Evaluate a term using a machine with logging disabled. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} evaluateCekNoEmit - :: ThrowableBuiltins uni fun - => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineRunner RestrictingSt uni fun pat ann + -> MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()) evaluateCekNoEmit runner params = fst . runCekNoEmit runner params restrictingEnormous {-| Unlift a value using a machine. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} readKnownCek - :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineRunner RestrictingSt uni fun ann - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) a + :: ( ThrowableBuiltins uni fun + , Pretty pat + , Typeable pat + , ReadKnown (Term Name uni fun pat ()) a + ) + => MachineRunner RestrictingSt uni fun pat ann + -> MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> Either (CekEvaluationException Name uni fun pat) a readKnownCek runner params = evaluateCekNoEmit runner params >=> readKnownSelf diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs index 616d17f81fa..c6d28dc5b17 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek.hs @@ -61,6 +61,7 @@ import UntypedPlutusCore.Evaluation.Machine.SteppableCek.Internal as S import PlutusCore.Builtin import PlutusCore.Evaluation.Machine.MachineParameters import PlutusCore.Name.Unique +import PlutusCore.Pretty (Pretty) import Data.Text (Text) @@ -68,49 +69,53 @@ import Data.Text (Text) A wrapper around the internal runCek to debruijn input and undebruijn output. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} runCek - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> Term Name uni fun ann - -> CekReport cost Name uni fun + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> EmitterMode uni fun pat + -> Term Name uni fun pat ann + -> CekReport cost Name uni fun pat runCek = Common.runCek S.runCekDeBruijn {-| Evaluate a term using the Steppable CEK machine with logging disabled and keep track of costing. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} runCekNoEmit - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), cost) + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> Term Name uni fun pat ann + -> (Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()), cost) runCekNoEmit = Common.runCekNoEmit S.runCekDeBruijn {-| Evaluate a term using the Steppable CEK machine with logging enabled. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} evaluateCek - :: ThrowableBuiltins uni fun - => EmitterMode uni fun - -> MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> (Either (CekEvaluationException Name uni fun) (Term Name uni fun ()), [Text]) + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => EmitterMode uni fun pat + -> MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> (Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()), [Text]) evaluateCek = Common.evaluateCek S.runCekDeBruijn {-| Evaluate a term using the Steppable CEK machine with logging disabled. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} evaluateCekNoEmit - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> Either (CekEvaluationException Name uni fun pat) (Term Name uni fun pat ()) evaluateCekNoEmit = Common.evaluateCekNoEmit S.runCekDeBruijn {-| Unlift a value using the Steppable CEK machine. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} readKnownCek - :: (ThrowableBuiltins uni fun, ReadKnown (Term Name uni fun ()) a) - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> Term Name uni fun ann - -> Either (CekEvaluationException Name uni fun) a + :: ( ThrowableBuiltins uni fun + , Pretty pat + , Typeable pat + , ReadKnown (Term Name uni fun pat ()) a + ) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> Term Name uni fun pat ann + -> Either (CekEvaluationException Name uni fun pat) a readKnownCek = Common.readKnownCek S.runCekDeBruijn diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/DebugDriver.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/DebugDriver.hs index 3926be86a7c..2b1657cdb34 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/DebugDriver.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/DebugDriver.hs @@ -72,7 +72,7 @@ data Cmd bps deriving stock (Show, Read) -- | The drivers's suspension functor -data DebugF uni fun ann bps a +data DebugF uni fun pat ann bps a = -- | Await for the client (e.g. TUI) to tell what to do next (Cmd). InputF (Cmd bps -> a) | -- | The debug driver wants to log something @@ -81,29 +81,29 @@ data DebugF uni fun ann bps a Yield a state before doing a step, then await for a state to resume after the step. See Note [Stepping the driver]. -} StepF - (CekState uni fun ann) + (CekState uni fun pat ann) -- ^ yield with the current driver's state before running a step - (CekState uni fun ann -> a) + (CekState uni fun pat ann -> a) {-^ resume back with a state after the step interpretation | A generator of CekState to yield to client (e.g. TUI) -} - | UpdateClientF (CekState uni fun ann) a + | UpdateClientF (CekState uni fun pat ann) a deriving stock (Functor) -- | The monad that the driver operates in -type Driving m uni fun ann bps = - ( MonadReader (CekState uni fun ann) m -- the state of the debugger - , MonadFree (DebugF uni fun ann bps) m -- the effects of the driver +type Driving m uni fun pat ann bps = + ( MonadReader (CekState uni fun pat ann) m -- the state of the debugger + , MonadFree (DebugF uni fun pat ann bps) m -- the effects of the driver , Breakpointable ann bps ) -- | Entrypoint of the driver runDriverT - :: forall uni fun ann bps m - . (Breakpointable ann bps, MonadFree (DebugF uni fun ann bps) m) - => NTerm uni fun ann -> m () + :: forall uni fun pat ann bps m + . (Breakpointable ann bps, MonadFree (DebugF uni fun pat ann bps) m) + => NTerm uni fun pat ann -> m () runDriverT = void . runReaderT driver . initState where - initState :: NTerm uni fun ann -> CekState uni fun ann + initState :: NTerm uni fun pat ann -> CekState uni fun pat ann initState = Starting -- | The driver action. The driver repeatedly: @@ -114,7 +114,7 @@ runDriverT = void . runReaderT driver . initState -- 3) informs the client for CEK updates&logs --- -- The driver computation exits when it reaches a CEK `Terminating` state. -driver :: Driving m uni fun ann bps => m () +driver :: Driving m uni fun pat ann bps => m () driver = inputF >>= \case -- Condition immediately satisfied @@ -139,7 +139,7 @@ driver = where -- \| Comparison on states' contexts onCtxLen - :: ( state ~ CekState uni fun ann + :: ( state ~ CekState uni fun pat ann , ctxLen ~ Maybe Word -- `Maybe` because ctx can be missing if terminating ) => (ctxLen -> ctxLen -> a) @@ -150,8 +150,8 @@ driver = -- | Do one or more cek steps until Terminating state is reached or condition on 'CekState' is met. multiStepUntil - :: Driving m uni fun ann bp - => (CekState uni fun ann -> Bool) -> m () + :: Driving m uni fun pat ann bp + => (CekState uni fun pat ann -> Bool) -> m () multiStepUntil cond = do driverLogF "Driver is going to do a single step" newState <- stepF =<< ask @@ -172,11 +172,14 @@ multiStepUntil cond = do -- * boilerplate "suspension actions" -- Being in 'Driving' monad here is too constraining, but it does not matter. -inputF :: Driving m uni fun ann bps => m (Cmd bps) +inputF :: Driving m uni fun pat ann bps => m (Cmd bps) inputF = liftF $ InputF id -driverLogF :: Driving m uni fun ann bps => Text -> m () +driverLogF :: Driving m uni fun pat ann bps => Text -> m () driverLogF text = liftF $ DriverLogF text () -updateClientF :: Driving m uni fun ann bps => CekState uni fun ann -> m () +updateClientF :: Driving m uni fun pat ann bps => CekState uni fun pat ann -> m () updateClientF dState = liftF $ UpdateClientF dState () -stepF :: Driving m uni fun ann bps => CekState uni fun ann -> m (CekState uni fun ann) +stepF + :: Driving m uni fun pat ann bps + => CekState uni fun pat ann + -> m (CekState uni fun pat ann) stepF yieldState = liftF $ StepF yieldState id diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index 27ede1bc1ce..c0ddd4d7547 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -55,13 +56,15 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts import UntypedPlutusCore.Evaluation.Machine.Cek.Internal hiding (Context (..), runCekDeBruijn) import UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter -import Control.Lens hiding (Context) +import Control.Lens hiding (Context, children) import Control.Monad +import Control.Monad.Except (throwError) import Control.Monad.Primitive import Data.Proxy import Data.RandomAccessList.Class qualified as Env import Data.RandomAccessList.SkewBinary qualified as Env import Data.Semigroup (stimes) +import Data.Text (Text) import Data.Vector qualified as V import GHC.TypeNats import Universe @@ -76,17 +79,17 @@ return with the CEK's machine new state (`CekState`), whereas previously these t The interface otherwise remains the same. Moreover, the `Original.runCekDeBruijn` and `Debug.runCekDeBruijn` must behave equivalently. -} -data CekState uni fun ann +data CekState uni fun pat ann = -- loaded a term but not fired the cek yet - Starting (NTerm uni fun ann) + Starting (NTerm uni fun pat ann) | -- the next state is computing - Computing (Context uni fun ann) (CekValEnv uni fun ann) (NTerm uni fun ann) + Computing (Context uni fun pat ann) (CekValEnv uni fun pat ann) (NTerm uni fun pat ann) | -- the next state is returning - Returning (Context uni fun ann) (CekValue uni fun ann) + Returning (Context uni fun pat ann) (CekValue uni fun pat ann) | -- evaluation finished - Terminating (DischargeResult uni fun) + Terminating (DischargeResult uni fun pat) -instance Pretty (CekState uni fun ann) where +instance Pretty (CekState uni fun pat ann) where pretty = \case Starting {} -> "Starting" Computing {} -> "Computing" @@ -94,36 +97,49 @@ instance Pretty (CekState uni fun ann) where Terminating {} -> "Terminating" -- | Similar to 'Cek.Internal.Context', but augmented with an 'ann' -data Context uni fun ann +data Context uni fun pat ann = -- | @[V _]@ - FrameAwaitArg ann !(CekValue uni fun ann) !(Context uni fun ann) + FrameAwaitArg ann !(CekValue uni fun pat ann) !(Context uni fun pat ann) | -- | @[_ N]@ - FrameAwaitFunTerm ann !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) - | FrameAwaitFunConN ann !(Spine (Some (ValueOf uni))) !(Context uni fun ann) - | FrameAwaitFunValueN ann !(ArgStackNonEmpty uni fun ann) !(Context uni fun ann) + FrameAwaitFunTerm + ann + !(CekValEnv uni fun pat ann) + !(NTerm uni fun pat ann) + !(Context uni fun pat ann) + | FrameAwaitFunConN ann !(Spine (Some (ValueOf uni))) !(Context uni fun pat ann) + | FrameAwaitFunValueN ann !(ArgStackNonEmpty uni fun pat ann) !(Context uni fun pat ann) | -- | @(force _)@ - FrameForce ann !(Context uni fun ann) + FrameForce ann !(Context uni fun pat ann) | FrameConstr ann - !(CekValEnv uni fun ann) + !(CekValEnv uni fun pat ann) {-# UNPACK #-} !Word64 - ![NTerm uni fun ann] - !(ArgStack uni fun ann) - !(Context uni fun ann) - | FrameCases ann !(CekValEnv uni fun ann) !(V.Vector (NTerm uni fun ann)) !(Context uni fun ann) + ![NTerm uni fun pat ann] + !(ArgStack uni fun pat ann) + !(Context uni fun pat ann) + | FrameCases + ann + !(CekValEnv uni fun pat ann) + !(V.Vector (NTerm uni fun pat ann)) + !(Context uni fun pat ann) + | FrameMatches + ann + !(CekValEnv uni fun pat ann) + !(V.Vector (pat, NTerm uni fun pat ann)) + !(Context uni fun pat ann) | NoFrame deriving stock instance - (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Context uni fun ann) + (GShow uni, Everywhere uni Show, Show fun, Show pat, Show ann, Closed uni) + => Show (Context uni fun pat ann) computeCek - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValEnv uni fun ann - -> NTerm uni fun ann - -> CekM uni fun s (CekState uni fun ann) + :: forall uni fun pat ann s + . (ThrowableBuiltins uni fun, Pretty pat, Typeable pat, GivenCekReqs uni fun pat ann s) + => Context uni fun pat ann + -> CekValEnv uni fun pat ann + -> NTerm uni fun pat ann + -> CekM uni fun pat s (CekState uni fun pat ann) -- s ; ρ ▻ {L A} ↦ s , {_ A} ; ρ ▻ L computeCek !ctx !env (Var _ varName) = do stepAndMaybeSpend BVar @@ -164,16 +180,19 @@ computeCek !ctx !env (Constr ann i es) = do computeCek !ctx !env (Case ann scrut cs) = do stepAndMaybeSpend BCase pure $ Computing (FrameCases ann env cs ctx) env scrut +computeCek !ctx !env (Match ann scrut alternatives) = do + stepAndMaybeSpend BMatch + pure $ Computing (FrameMatches ann env alternatives ctx) env scrut -- s ; ρ ▻ error A ↦ <> A computeCek !_ !_ (Error _) = throwErrorWithCause (OperationalError CekEvaluationFailure) (Error ()) returnCek - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValue uni fun ann - -> CekM uni fun s (CekState uni fun ann) + :: forall uni fun pat ann s + . (ThrowableBuiltins uni fun, Pretty pat, Typeable pat, GivenCekReqs uni fun pat ann s) + => Context uni fun pat ann + -> CekValue uni fun pat ann + -> CekM uni fun pat s (CekState uni fun pat ann) --- Instantiate all the free variable of the resulting term in case there are any. -- . ◅ V ↦ [] V returnCek NoFrame val = do @@ -190,11 +209,22 @@ returnCek (FrameAwaitFunTerm _funAnn argVarEnv arg ctx) fun = -- add rule for VBuiltin once it's in the specification. returnCek (FrameAwaitArg _ fun ctx) arg = applyEvaluate ctx fun arg --- s , [_ V1 .. Vn] ◅ lam x (M,ρ) ↦ s , [_ V2 .. Vn]; ρ [ x ↦ V1 ] ▻ M +-- Apply the constant spine exposed by an implicit builtin Case or Match branch. returnCek (FrameAwaitFunConN ann args ctx) fun = - case args of - SpineLast arg -> applyEvaluate ctx fun (VCon arg) - SpineCons arg rest -> applyEvaluate (FrameAwaitFunConN ann rest ctx) fun (VCon arg) + case fun of + VLamAbs {} -> applyConstant + VBuiltin {} -> applyConstant + -- The implicit application did not inspect the handler, so recursively discharging a + -- constructor-shaped handler merely to populate the cause would be unbudgeted work. + _ -> do + spendAccumulatedBudget + throwError $ + ErrorWithCause (StructuralError NonFunctionalApplicationMachineError) Nothing + where + applyConstant = + case args of + SpineLast arg -> applyEvaluate ctx fun (VCon arg) + SpineCons arg rest -> applyEvaluate (FrameAwaitFunConN ann rest ctx) fun (VCon arg) -- s , [_ V1 .. Vn] ◅ lam x (M,ρ) ↦ s , [_ V2 .. Vn]; ρ [ x ↦ V1 ] ▻ M returnCek (FrameAwaitFunValueN ann args ctx) fun = case args of @@ -231,6 +261,8 @@ returnCek (FrameCases ann env cs ctx) e = case e of HeadOnly fX -> pure $ Computing ctx env fX HeadSpine f xs -> pure $ Computing (FrameAwaitFunConN ann xs ctx) env f _ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e +returnCek (FrameMatches ann env alternatives ctx) scrutinee = + enterMatchAlternatives ann ctx env alternatives scrutinee {-| @force@ a term and proceed. If v is a delay then compute the body of v; @@ -239,11 +271,11 @@ and either calculate the builtin application or stick a 'Force' on top of its 'T representation depending on whether the application is saturated or not, if v is anything else, fail. -} forceEvaluate - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValue uni fun ann - -> CekM uni fun s (CekState uni fun ann) + :: forall uni fun pat ann s + . (ThrowableBuiltins uni fun, Pretty pat, Typeable pat, GivenCekReqs uni fun pat ann s) + => Context uni fun pat ann + -> CekValue uni fun pat ann + -> CekM uni fun pat s (CekState uni fun pat ann) forceEvaluate !ctx (VDelay body env) = pure $ Computing ctx env body forceEvaluate !ctx (VBuiltin fun term runtime) = do @@ -270,12 +302,12 @@ and either calculate the builtin application or stick a 'Apply' on top of its 'T representation depending on whether the application is saturated or not. If v is anything else, fail. -} applyEvaluate - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValue uni fun ann -- lhs of application - -> CekValue uni fun ann -- rhs of application - -> CekM uni fun s (CekState uni fun ann) + :: forall uni fun pat ann s + . (ThrowableBuiltins uni fun, Pretty pat, Typeable pat, GivenCekReqs uni fun pat ann s) + => Context uni fun pat ann + -> CekValue uni fun pat ann -- lhs of application + -> CekValue uni fun pat ann -- rhs of application + -> CekM uni fun pat s (CekState uni fun pat ann) applyEvaluate !ctx (VLamAbs _ body env) arg = pure $ Computing ctx (Env.cons arg env) body -- Annotating @f@ and @exF@ with bangs gave us some speed-up, but only until we added a bang to @@ -294,14 +326,66 @@ applyEvaluate !ctx (VBuiltin fun term runtime) arg = do applyEvaluate !_ val _ = throwErrorDischarged (StructuralError NonFunctionalApplicationMachineError) val +patternFailure + :: ( ThrowableBuiltins uni fun + , Pretty pat + , Typeable pat + ) + => Text + -> CekM uni fun pat s a +patternFailure err = do + -- Keep the debugger path identical to the production CEK and avoid lazily discharging an + -- arbitrarily deep scrutinee if the operational error is subsequently rendered. + throwError $ ErrorWithCause (OperationalError $ CekPatternMatchError err) Nothing + +enterMatchAlternatives + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat, GivenCekReqs uni fun pat ann s) + => ann + -> Context uni fun pat ann + -> CekValEnv uni fun pat ann + -> V.Vector (pat, NTerm uni fun pat ann) + -> CekValue uni fun pat ann + -> CekM uni fun pat s (CekState uni fun pat ann) +enterMatchAlternatives ann ctx env alternatives scrutinee = do + -- Pattern work is spent without slippage. Flush ordinary CEK work once so subsequent matcher + -- spends are direct affordability barriers. A reached-capture spend intentionally reserves its + -- later spine materialization and implicit handler application. + spendAccumulatedBudget + case scrutinee of + VCon con -> + ( CekM $ + runPatternMatchM + (unMatchBuiltin ?cekMatcherBuiltin con alternatives) + (\work -> unCekM $ spendPattern work) + ) + >>= enterSelected + _ -> patternFailure "match scrutinee is not a built-in value" + where + !patternCost = runIdentity $ cekPatternCost ?cekCosts + !patternStructuralCost = runIdentity $ cekPatternStructuralCost ?cekCosts + !patternFailureCost = runIdentity $ cekPatternFailureCost ?cekCosts + !spendPattern = \case + PatternWork units -> case units of + 0 -> pure () + 1 -> spendBudget BPattern patternCost + _ -> spendBudget BPattern (stimes (toInteger units) patternCost) + PatternStructuralWork -> spendBudget BPattern patternStructuralCost + PatternFailureWork -> spendBudget BPattern patternFailureCost + + enterSelected = \case + HeadError err -> patternFailure err + HeadOnly selectedHandler -> computeCek ctx env selectedHandler + HeadSpine selectedHandler captures -> + computeCek (FrameAwaitFunConN ann captures ctx) env selectedHandler + -- MAYBE: runCekDeBruijn can be shared between original&debug ceks by passing a `enterComputeCek` func. runCekDeBruijn - :: ThrowableBuiltins uni fun - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun - -> NTerm uni fun ann - -> CekReport cost NamedDeBruijn uni fun + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> EmitterMode uni fun pat + -> NTerm uni fun pat ann + -> CekReport cost NamedDeBruijn uni fun pat runCekDeBruijn params mode emitMode term = runCekM params mode emitMode $ do spendBudget BStartup $ runIdentity $ cekStartupCost ?cekCosts @@ -310,15 +394,16 @@ runCekDeBruijn params mode emitMode term = -- See Note [Compilation peculiarities]. -- | The entering point to the CEK machine's engine. enterComputeCek - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann - -> CekValEnv uni fun ann - -> NTerm uni fun ann - -> CekM uni fun s (DischargeResult uni fun) + :: forall uni fun pat ann s + . (ThrowableBuiltins uni fun, Pretty pat, Typeable pat, GivenCekReqs uni fun pat ann s) + => Context uni fun pat ann + -> CekValEnv uni fun pat ann + -> NTerm uni fun pat ann + -> CekM uni fun pat s (DischargeResult uni fun pat) enterComputeCek ctx env term = iterToFinalState $ Computing ctx env term where - iterToFinalState :: CekState uni fun ann -> CekM uni fun s (DischargeResult uni fun) + iterToFinalState + :: CekState uni fun pat ann -> CekM uni fun pat s (DischargeResult uni fun pat) iterToFinalState = cekTrans >=> \case @@ -335,13 +420,13 @@ nilSlippage = 0 -- the type of our state transition function, `s -> m s` , aka `Kleisli m a a` type Trans m state = state -> m state -type CekTrans uni fun ann s = Trans (CekM uni fun s) (CekState uni fun ann) +type CekTrans uni fun pat ann s = Trans (CekM uni fun pat s) (CekState uni fun pat ann) -- | The state transition function of the machine. cekTrans - :: forall uni fun ann s - . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => CekTrans uni fun ann s + :: forall uni fun pat ann s + . (ThrowableBuiltins uni fun, Pretty pat, Typeable pat, GivenCekReqs uni fun pat ann s) + => CekTrans uni fun pat ann s cekTrans = \case Starting term -> pure $ Computing NoFrame Env.empty term Computing ctx env term -> computeCek ctx env term @@ -352,18 +437,20 @@ cekTrans = \case construct a state transition function. Returns the constructed transition function paired with the methods to live access the running budget. -} mkCekTrans - :: forall cost uni fun ann m s + :: forall cost uni fun pat ann m s . ( ThrowableBuiltins uni fun + , Pretty pat + , Typeable pat , PrimMonad m , s ~ PrimState m -- the outer monad that initializes the transition function ) - => MachineParameters CekMachineCosts fun (CekValue uni fun ann) - -> ExBudgetMode cost uni fun - -> EmitterMode uni fun + => MachineParameters CekMachineCosts fun (CekValue uni fun pat ann) pat + -> ExBudgetMode cost uni fun pat + -> EmitterMode uni fun pat -> Slippage - -> m (CekTrans uni fun ann s, ExBudgetInfo cost uni fun s) + -> m (CekTrans uni fun pat ann s, ExBudgetInfo cost uni fun pat s) mkCekTrans - (MachineParameters caser (MachineVariantParameters costs runtime)) + (MachineParameters caser matcher (MachineVariantParameters costs runtime)) (ExBudgetMode getExBudgetInfo) (EmitterMode getEmitterMode) slippage = do @@ -373,6 +460,7 @@ mkCekTrans ctr <- newCounter (Proxy @CounterSize) let ?cekRuntime = runtime ?cekCaserBuiltin = caser + ?cekMatcherBuiltin = matcher ?cekEmitter = _cekEmitterInfoEmit ?cekBudgetSpender = _exBudgetModeSpender ?cekCosts = costs @@ -388,22 +476,22 @@ mkCekTrans ------------ -- | Lift a CEK computation to a primitive.PrimMonad m -liftCek :: (PrimMonad m, PrimState m ~ s) => CekM uni fun s a -> m a +liftCek :: (PrimMonad m, PrimState m ~ s) => CekM uni fun pat s a -> m a liftCek = liftPrim . unCekM -cekStateContext :: Traversal' (CekState uni fun ann) (Context uni fun ann) +cekStateContext :: Traversal' (CekState uni fun pat ann) (Context uni fun pat ann) cekStateContext f = \case Computing k e t -> Computing <$> f k <*> pure e <*> pure t Returning k v -> Returning <$> f k <*> pure v x -> pure x -cekStateAnn :: CekState uni fun ann -> Maybe ann +cekStateAnn :: CekState uni fun pat ann -> Maybe ann cekStateAnn = \case Computing _ _ t -> pure $ getAnn t Returning ctx _ -> contextAnn ctx _ -> empty -contextAnn :: Context uni fun ann -> Maybe ann +contextAnn :: Context uni fun pat ann -> Maybe ann contextAnn = \case FrameAwaitArg ann _ _ -> pure ann FrameAwaitFunTerm ann _ _ _ -> pure ann @@ -412,12 +500,13 @@ contextAnn = \case FrameForce ann _ -> pure ann FrameConstr ann _ _ _ _ _ -> pure ann FrameCases ann _ _ _ -> pure ann + FrameMatches ann _ _ _ -> pure ann NoFrame -> empty -lenContext :: Context uni fun ann -> Word +lenContext :: Context uni fun pat ann -> Word lenContext = go 0 where - go :: Word -> Context uni fun ann -> Word + go :: Word -> Context uni fun pat ann -> Word go !n = \case FrameAwaitArg _ _ k -> go (n + 1) k FrameAwaitFunTerm _ _ _ k -> go (n + 1) k @@ -426,6 +515,7 @@ lenContext = go 0 FrameForce _ k -> go (n + 1) k FrameConstr _ _ _ _ _ k -> go (n + 1) k FrameCases _ _ _ k -> go (n + 1) k + FrameMatches _ _ _ k -> go (n + 1) k NoFrame -> 0 -- * Duplicated functions from Cek.Internal module @@ -446,21 +536,24 @@ cekStepCost costs = BBuiltin -> cekBuiltinCost costs BConstr -> cekConstrCost costs BCase -> cekCaseCost costs + BMatch -> cekMatchCost costs {-| Call 'dischargeCekValue' over the received 'CekVal' and feed the resulting 'Term' to 'throwErrorWithCause' as the cause of the failure. -} throwErrorDischarged - :: ThrowableBuiltins uni fun + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) => EvaluationError (MachineError fun) CekUserError - -> CekValue uni fun ann - -> CekM uni fun s x + -> CekValue uni fun pat ann + -> CekM uni fun pat s x throwErrorDischarged err = throwErrorWithCause err . dischargeResultToTerm . dischargeCekValue -- | Look up a variable name in the environment. lookupVarName - :: forall uni fun ann s - . ThrowableBuiltins uni fun - => NamedDeBruijn -> CekValEnv uni fun ann -> CekM uni fun s (CekValue uni fun ann) + :: forall uni fun pat ann s + . (ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => NamedDeBruijn + -> CekValEnv uni fun pat ann + -> CekM uni fun pat s (CekValue uni fun pat ann) lookupVarName varName@(NamedDeBruijn _ varIx) varEnv = Env.contIndexOne (throwErrorWithCause (StructuralError OpenTermEvaluatedMachineError) $ Var () varName) @@ -476,12 +569,12 @@ lookupVarName varName@(NamedDeBruijn _ varIx) varEnv = and proceed with the returning phase of the CEK machine. -} evalBuiltinApp - :: (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s) - => Context uni fun ann + :: (ThrowableBuiltins uni fun, Pretty pat, Typeable pat, GivenCekReqs uni fun pat ann s) + => Context uni fun pat ann -> fun - -> NTerm uni fun () - -> BuiltinRuntime (CekValue uni fun ann) - -> CekM uni fun s (CekState uni fun ann) + -> NTerm uni fun pat () + -> BuiltinRuntime (CekValue uni fun pat ann) + -> CekM uni fun pat s (CekState uni fun pat ann) evalBuiltinApp ctx fun term runtime = case runtime of BuiltinCostedResult budgets0 getFXs -> do let exCat = BBuiltinApp fun @@ -501,11 +594,15 @@ evalBuiltinApp ctx fun term runtime = case runtime of _ -> returnCek ctx $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} -spendBudget :: GivenCekSpender uni fun s => ExBudgetCategory fun -> ExBudget -> CekM uni fun s () +spendBudget + :: GivenCekSpender uni fun pat s + => ExBudgetCategory fun + -> ExBudget + -> CekM uni fun pat s () spendBudget = unCekBudgetSpender ?cekBudgetSpender -- | Spend the budget that has been accumulated for a number of machine steps. -spendAccumulatedBudget :: GivenCekReqs uni fun ann s => CekM uni fun s () +spendAccumulatedBudget :: GivenCekReqs uni fun pat ann s => CekM uni fun pat s () spendAccumulatedBudget = do let ctr = ?cekStepCounter iforCounter_ ctr spend @@ -513,15 +610,25 @@ spendAccumulatedBudget = do where -- Making this a definition of its own causes it to inline better than actually writing it inline, for -- some reason. - -- Skip index 7, that's the total counter! + -- Fixed Match steps are accumulated like other machine steps but retain the public + -- 'BPattern' category. Matcher work is spent directly through its supplied spending function. -- See Note [Structure of the step counter] {-# INLINE spend #-} spend !i !w = - unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ - let kind = toEnum i in spendBudget (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) - --- | Accumulate a step, and maybe spend the budget that has accumulated for a number of machine steps, but only if we've exceeded our slippage. -stepAndMaybeSpend :: GivenCekReqs uni fun ann s => StepKind -> CekM uni fun s () + if i == totalCountIndex + then pure () + else + let kind = toEnum i + in case kind of + BMatch -> + when (w /= 0) $ spendBudget BPattern $ stimes w (cekStepCost ?cekCosts kind) + _ -> spendBudget (BStep kind) $ stimes w (cekStepCost ?cekCosts kind) + where + totalCountIndex = fromIntegral $ natVal $ Proxy @TotalCountIndex + +{-| Accumulate a non-pattern step, and maybe spend the budget that has accumulated for a number +of machine steps, but only if we've exceeded our slippage. Pattern steps are direct-spent. -} +stepAndMaybeSpend :: GivenCekReqs uni fun pat ann s => StepKind -> CekM uni fun pat s () stepAndMaybeSpend !kind = do -- See Note [Structure of the step counter] -- This generates let-expressions in GHC Core, however all of them bind unboxed things and diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Mark.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Mark.hs index 96623ad7033..677543fe0d2 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Mark.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Mark.hs @@ -13,14 +13,14 @@ import UntypedPlutusCore.Core {-| Marks all the 'Unique's in a term as used, so they will not be generated in future. Useful if you have a term which was not generated in 'Quote'. -} markNonFreshTerm - :: (HasUniques (Term name uni fun ann), MonadQuote m) - => Term name uni fun ann -> m () + :: (HasUniques (Term name uni fun pat ann), MonadQuote m) + => Term name uni fun pat ann -> m () markNonFreshTerm = markNonFreshMax . setOf termUniquesDeep {-| Marks all the 'Unique's in a program as used, so they will not be generated in future. Useful if you have a program which was not generated in 'Quote'. -} markNonFreshProgram :: (HasUnique name TermUnique, MonadQuote m) - => Program name uni fun ann + => Program name uni fun pat ann -> m () markNonFreshProgram (Program _ _ body) = markNonFreshTerm body diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/MkUPlc.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/MkUPlc.hs index 007b76fca31..1a1024fc65e 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/MkUPlc.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/MkUPlc.hs @@ -5,17 +5,17 @@ import PlutusCore.MkPlc (Def (..)) import UntypedPlutusCore.Core.Type -- | A term definition as a variable. -type UTermDef name uni fun ann = Def (UVarDecl name ann) (Term name uni fun ann) +type UTermDef name uni fun pat ann = Def (UVarDecl name ann) (Term name uni fun pat ann) {-| Make a 'Var' referencing the given 'UVarDecl'. The @ann@ is propagated from the 'UVarDecl' to the 'Var'. -} -mkVar :: UVarDecl name ann -> Term name uni fun ann +mkVar :: UVarDecl name ann -> Term name uni fun pat ann mkVar uvd = Var (_uvarDeclAnn uvd) (_uvarDeclName uvd) -- | Lambda abstract a list of names. mkIterLamAbs :: [UVarDecl name ann] - -> Term name uni fun ann - -> Term name uni fun ann + -> Term name uni fun pat ann + -> Term name uni fun pat ann mkIterLamAbs args body = foldr (\(UVarDecl ann name) acc -> LamAbs ann name acc) body args diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Optimize.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Optimize.hs index e7e7284aad3..49ab1539ba7 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Optimize.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Optimize.hs @@ -43,22 +43,22 @@ import Data.Typeable import Data.Vector.Orphans () optimizeProgram - :: forall name uni fun m a - . Compiling m uni fun name a + :: forall name uni fun pat m a + . Compiling m uni fun pat name a => OptimizeOpts name a -> BuiltinSemanticsVariant fun - -> Program name uni fun a - -> m (Program name uni fun a) + -> Program name uni fun pat a + -> m (Program name uni fun pat a) optimizeProgram opts builtinSemanticsVariant (Program a v t) = Program a v <$> optimizeTerm opts builtinSemanticsVariant t optimizeProgramWithTrace - :: forall name uni fun m a - . Compiling m uni fun name a + :: forall name uni fun pat m a + . Compiling m uni fun pat name a => OptimizeOpts name a -> BuiltinSemanticsVariant fun - -> Program name uni fun a - -> m (Program name uni fun a, OptimizerTrace name uni fun a) + -> Program name uni fun pat a + -> m (Program name uni fun pat a, OptimizerTrace name uni fun pat a) optimizeProgramWithTrace opts builtinSemanticsVariant (Program a v t) = do (result, trace) <- runOptimizerT $ @@ -66,22 +66,22 @@ optimizeProgramWithTrace opts builtinSemanticsVariant (Program a v t) = do pure (Program a v result, trace) optimizeTerm - :: forall name uni fun m a - . Compiling m uni fun name a + :: forall name uni fun pat m a + . Compiling m uni fun pat name a => OptimizeOpts name a -> BuiltinSemanticsVariant fun - -> Term name uni fun a - -> m (Term name uni fun a) + -> Term name uni fun pat a + -> m (Term name uni fun pat a) optimizeTerm opts builtinSemanticsVariant term = evalOptimizerT $ termOptimizer opts builtinSemanticsVariant term termOptimizer - :: forall name uni fun m a - . Compiling m uni fun name a + :: forall name uni fun pat m a + . Compiling m uni fun pat name a => OptimizeOpts name a -> BuiltinSemanticsVariant fun - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) termOptimizer opts builtinSemanticsVariant = simplifyNTimes (_ooMaxSimplifierIterations opts) >=> runStage CseStage @@ -91,23 +91,23 @@ termOptimizer opts builtinSemanticsVariant = -- Run the simplifier @n@ times simplifyNTimes :: Int - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) simplifyNTimes n = List.foldl' (>=>) pure $ map simplifyStep [1 .. n] -- Run CSE @n@ times, interleaved with the simplifier. -- See Note [CSE] cseNTimes :: Int - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) cseNTimes n = foldl' (>=>) pure $ concatMap (\i -> [cseStep i, simplifyStep i]) [1 .. n] -- generate simplification step simplifyStep :: Int - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) simplifyStep _ = runStage FloatDelayStage >=> runStage ForceCaseDelayStage @@ -163,16 +163,16 @@ termOptimizer opts builtinSemanticsVariant = PolyBuiltinStage -> if _ooHoistPolyBuiltins opts then polyBuiltinStep else pure caseOfCase' - :: Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + :: Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) caseOfCase' = case eqT @fun @DefaultFun of Just Refl -> caseOfCase Nothing -> pure cseStep :: Int - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) cseStep _ = case (eqT @name @Name, eqT @uni @PLC.DefaultUni) of (Just Refl, Just Refl) -> cse (_ooCseWhichSubterms opts) builtinSemanticsVariant @@ -181,8 +181,8 @@ termOptimizer opts builtinSemanticsVariant = cseTimes = if _ooConservativeOpts opts then 0 else _ooMaxCseIterations opts polyBuiltinStep - :: Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + :: Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) polyBuiltinStep = case (eqT @name @Name, eqT @uni @PLC.DefaultUni) of (Just Refl, Just Refl) -> polyBuiltin builtinSemanticsVariant _ -> pure diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs index fcdd4424a23..215e18ec045 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Parser.hs @@ -20,7 +20,7 @@ import Control.Monad.Except import PlutusCore qualified as PLC import PlutusCore.Annotation import PlutusCore.Error qualified as PLC -import PlutusPrelude ((&&&), getAnn, setAnn, through) +import PlutusPrelude (getAnn, setAnn, through, (&&&)) import Text.Megaparsec hiding (ParseError, State, parse) import Text.Megaparsec.Char (char) import Text.Megaparsec.Char.Lexer qualified as Lex @@ -28,6 +28,7 @@ import UntypedPlutusCore.Check.Uniques (checkProgram) import UntypedPlutusCore.Core.Type qualified as UPLC import UntypedPlutusCore.Rename (Rename (rename)) +import Data.Int (Int64) import Data.Text (Text) import Data.Vector qualified as V import Data.Word (Word64) @@ -38,7 +39,8 @@ import PlutusCore.Version -- Parsers for UPLC terms -- | A parsable UPLC term. -type PTerm = UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan +type PTerm = + UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern SrcSpan conTerm :: SrcSpan -> Parser PTerm conTerm sp = @@ -58,8 +60,8 @@ lamTerm sp = appTerm :: SrcSpan -> Parser PTerm appTerm sp = - setAnn sp <$> - (mkIterApp <$> term <*> (fmap (getAnn &&& id) <$> some term)) + setAnn sp + <$> (mkIterApp <$> term <*> (fmap (getAnn &&& id) <$> some term)) delayTerm :: SrcSpan -> Parser PTerm delayTerm sp = @@ -88,6 +90,55 @@ caseTerm sp = do whenVersion (\v -> v < plcVersion110) $ fail "'case' is not allowed before version 1.1.0" pure res +matchPattern :: Parser PLC.DefaultBuiltinPattern +matchPattern = + leadingWhitespace . inParens . choice . fmap try $ + [ PLC.DefaultPatternWildcard <$ symbol "wildcard" + , PLC.DefaultPatternCapture <$ symbol "bind" + , PLC.DefaultPatternInteger <$> (symbol "integer" *> patternInt64) + , PLC.DefaultPatternByteString <$> (symbol "bytestring" *> conBS) + , PLC.DefaultPatternBool <$> (symbol "bool" *> conBool) + , PLC.DefaultPatternUnit <$ symbol "unit" + , withChildren PLC.DefaultPatternList "list" + , PLC.DefaultPatternPair + <$> (symbol "pair" *> matchPattern) + <*> matchPattern + , do + tag <- symbol "data-constr" *> patternWord64 + PLC.DefaultPatternDataConstr tag . V.fromList <$> many matchPattern + , withChildren PLC.DefaultPatternDataMap "data-map" + , withChildren PLC.DefaultPatternDataList "data-list" + , PLC.DefaultPatternDataI <$> (symbol "data-i" *> optional matchPattern) + , PLC.DefaultPatternDataB <$> (symbol "data-b" *> optional matchPattern) + ] + where + patternInt64 = do + value <- conInteger + let lower = toInteger (minBound :: Int64) + upper = toInteger (maxBound :: Int64) + when (value < lower || value > upper) $ + fail "integer pattern is outside the Int64 range" + pure $ fromInteger value + patternWord64 = do + value <- conInteger + when (value < 0 || value > toInteger (maxBound :: Word64)) $ + fail "data-constr pattern tag is outside the Word64 range" + pure $ fromInteger value + withChildren ctor keyword = do + _ <- symbol keyword + ctor . V.fromList <$> many matchPattern + +matchTerm :: SrcSpan -> Parser PTerm +matchTerm sp = do + scrutinee <- term + alternatives <- V.fromList <$> many patternAlternative + whenVersion (\v -> v < plcVersion120) $ fail "'match' is not allowed before version 1.2.0" + pure $ UPLC.Match sp scrutinee alternatives + where + patternAlternative = leadingWhitespace . trailingWhitespace . inParens $ do + _ <- symbol "pattern" + (,) <$> matchPattern <*> term + -- | Parser for all UPLC terms. term :: Parser PTerm term = @@ -121,12 +172,21 @@ term = , symbol "force" *> forceTerm sp , symbol "error" *> errorTerm sp , symbol "case" *> caseTerm sp + , symbol "match" *> matchTerm sp ] - "term keyword (builtin, lam, constr, con, delay, force, error, case)" + "term keyword (builtin, lam, constr, con, delay, force, error, case, match)" ) -- | Parser for UPLC programs. -program :: Parser (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan) +program + :: Parser + ( UPLC.Program + PLC.Name + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + SrcSpan + ) program = leadingWhitespace go where go = do @@ -148,7 +208,14 @@ explicity, use `parse program `.` -} parseProgram :: (MonadError PLC.ParserErrorBundle m, PLC.MonadQuote m) => Text - -> m (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan) + -> m + ( UPLC.Program + PLC.Name + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + SrcSpan + ) parseProgram = parseGen program {-| Parse and rewrite so that names are globally unique, not just unique within @@ -156,7 +223,14 @@ their scope. -} parseScoped :: (MonadError (PLC.Error uni fun SrcSpan) m, PLC.MonadQuote m) => Text - -> m (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun SrcSpan) + -> m + ( UPLC.Program + PLC.Name + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + SrcSpan + ) -- don't require there to be no free variables at this point, we might be parsing an open term parseScoped = through (modifyError PLC.UniqueCoherencyErrorE . checkProgram (const True)) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Purity.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Purity.hs index a46d18aa4f9..2b239b2fd5f 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Purity.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Purity.hs @@ -49,19 +49,20 @@ instance Pretty WorkFreedom where {-| Either the "next" term to be evaluated, along with its 'Purity' and 'WorkFreedom', or we don't know what comes next. -} -data EvalTerm name uni fun a +data EvalTerm name uni fun pat a = Unknown - | EvalTerm Purity WorkFreedom (Term name uni fun a) + | EvalTerm Purity WorkFreedom (Term name uni fun pat a) instance ( Show name , Everywhere uni Show , Show fun + , Show pat , Show a , GShow uni , Closed uni ) - => Show (EvalTerm name uni fun a) + => Show (EvalTerm name uni fun pat a) where show = \case Unknown -> "" @@ -69,14 +70,14 @@ instance "EvalTerm " <> show purity <> " " <> show work <> " " <> show t instance - PrettyBy config (Term name uni fun a) - => PrettyBy config (EvalTerm name uni fun a) + PrettyBy config (Term name uni fun pat a) + => PrettyBy config (EvalTerm name uni fun pat a) where prettyBy _ Unknown = "" prettyBy config (EvalTerm eff work t) = pretty eff <+> pretty work <> ":" <+> prettyBy config t -instance Eq (Term name uni fun a) => Eq (EvalTerm name uni fun a) where +instance Eq (Term name uni fun pat a) => Eq (EvalTerm name uni fun pat a) where Unknown == Unknown = True (EvalTerm p1 w1 t1) == (EvalTerm p2 w2 t2) = p1 == p2 && w1 == w2 && t1 == t2 _ == _ = False @@ -84,14 +85,14 @@ instance Eq (Term name uni fun a) => Eq (EvalTerm name uni fun a) where -- We use a DList here for efficient and lazy concatenation -- | The order in which terms get evaluated, along with their purities. -newtype EvalOrder name uni fun a = EvalOrder (DList.DList (EvalTerm name uni fun a)) +newtype EvalOrder name uni fun pat a = EvalOrder (DList.DList (EvalTerm name uni fun pat a)) deriving newtype (Semigroup, Monoid) {-| Get the evaluation order as a list of 'EvalTerm's. Either terminates in a single 'Unknown', which means that we got to a point where evaluation continues but we don't know where; or terminates normally, in which case we actually got to the end of the evaluation order for the term. -} -unEvalOrder :: EvalOrder name uni fun a -> [EvalTerm name uni fun a] +unEvalOrder :: EvalOrder name uni fun pat a -> [EvalTerm name uni fun pat a] unEvalOrder (EvalOrder ts) = -- This is where we avoid traversing the whole program beyond the first Unknown, -- since DList is lazy and we convert to a lazy list and then filter it. @@ -100,12 +101,12 @@ unEvalOrder (EvalOrder ts) = takeWhileInclusive :: (a -> Bool) -> [a] -> [a] takeWhileInclusive p = foldr (\x ys -> if p x then x : ys else [x]) [] -evalThis :: EvalTerm name uni fun a -> EvalOrder name uni fun a +evalThis :: EvalTerm name uni fun pat a -> EvalOrder name uni fun pat a evalThis = EvalOrder . DList.singleton instance - PrettyBy config (Term name uni fun a) - => PrettyBy config (EvalOrder name uni fun a) + PrettyBy config (Term name uni fun pat a) + => PrettyBy config (EvalOrder name uni fun pat a) where prettyBy config eo = vsep $ fmap (prettyBy config) (unEvalOrder eo) @@ -119,27 +120,27 @@ This makes some assumptions about the evaluator, in particular about the order i which we evaluate sub-terms, but these match the current evaluator and we are not planning on changing it. -} termEvaluationOrder - :: forall name uni fun a + :: forall name uni fun pat a . ToBuiltinMeaning uni fun => BuiltinSemanticsVariant fun - -> Term name uni fun a - -> EvalOrder name uni fun a + -> Term name uni fun pat a + -> EvalOrder name uni fun pat a termEvaluationOrder builtinSemanticsVariant = goTerm where - goTerm :: Term name uni fun a -> EvalOrder name uni fun a + goTerm :: Term name uni fun pat a -> EvalOrder name uni fun pat a goTerm = \case (splitAppCtx -> (builtin@(Builtin _ann fun), appCtx)) -> appCtxEvalOrder appCtx <> go arity appCtx where arity = builtinArity @uni @fun (Proxy @uni) builtinSemanticsVariant fun - appCtxEvalOrder :: AppCtx name uni fun a -> EvalOrder name uni fun a + appCtxEvalOrder :: AppCtx name uni fun pat a -> EvalOrder name uni fun pat a appCtxEvalOrder = \case AppCtxEnd -> mempty AppCtxTerm _ t rest -> goTerm t <> appCtxEvalOrder rest AppCtxType _ rest -> appCtxEvalOrder rest - go :: [Param] -> AppCtx name uni fun a -> EvalOrder name uni fun a + go :: [Param] -> AppCtx name uni fun pat a -> EvalOrder name uni fun pat a go parameters appContext = case parameters of -- All builtin parameters have been applied, @@ -170,13 +171,13 @@ termEvaluationOrder builtinSemanticsVariant = goTerm AppCtxType _ann remainingAppCtx -> go otherParams remainingAppCtx where - maybeImpureWork :: EvalOrder name uni fun a + maybeImpureWork :: EvalOrder name uni fun pat a maybeImpureWork = evalThis (EvalTerm MaybeImpure MaybeWork reconstructed) - pureWorkFree :: EvalOrder name uni fun a + pureWorkFree :: EvalOrder name uni fun pat a pureWorkFree = evalThis (EvalTerm Pure WorkFree reconstructed) - reconstructed :: Term name uni fun a + reconstructed :: Term name uni fun pat a reconstructed = fillAppCtx builtin appCtx t@(Apply _ fun arg) -> -- first the function @@ -213,6 +214,10 @@ termEvaluationOrder builtinSemanticsVariant = goTerm <> evalThis (EvalTerm Pure MaybeWork t) -- then we go to an unknown scrutinee <> evalThis Unknown + t@(Match _ scrut _) -> + goTerm scrut + <> evalThis (EvalTerm Pure MaybeWork t) + <> evalThis Unknown -- Leaf terms t@Var {} -> evalThis (EvalTerm Pure WorkFree t) @@ -237,7 +242,7 @@ things that can't be returned from the machine (as they'd be ill-scoped). -} isPure :: ToBuiltinMeaning uni fun => BuiltinSemanticsVariant fun - -> Term name uni fun a + -> Term name uni fun pat a -> Bool isPure builtinSemanticsVariant term = -- to work out if the term is pure, we see if we can look through @@ -245,7 +250,7 @@ isPure builtinSemanticsVariant term = -- effectful go (unEvalOrder (termEvaluationOrder builtinSemanticsVariant term)) where - go :: [EvalTerm name uni fun a] -> Bool + go :: [EvalTerm name uni fun pat a] -> Bool go [] = True go (et : rest) = case et of -- Might be an effect here! @@ -262,7 +267,7 @@ evaluating this term should do very a trivial amount of work. -} isWorkFree :: ToBuiltinMeaning uni fun => BuiltinSemanticsVariant fun - -> Term name uni fun a + -> Term name uni fun pat a -> Bool isWorkFree builtinSemanticsVariant term = -- to work out if the term is pure, we see if we can look through @@ -270,7 +275,7 @@ isWorkFree builtinSemanticsVariant term = -- effectful go (unEvalOrder (termEvaluationOrder builtinSemanticsVariant term)) where - go :: [EvalTerm name uni fun a] -> Bool + go :: [EvalTerm name uni fun pat a] -> Bool go [] = True go (et : rest) = case et of -- Might be an effect here! diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename.hs index 568bac957e1..29d3379507d 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename.hs @@ -17,10 +17,10 @@ import PlutusCore.Core (HasUniques) import PlutusCore.Name.Unique import PlutusCore.Rename (Rename (..)) -instance HasUniques (Term name uni fun ann) => Rename (Term name uni fun ann) where +instance HasUniques (Term name uni fun pat ann) => Rename (Term name uni fun pat ann) where -- See Note [Marking]. rename = through markNonFreshTerm >=> runRenameT . renameTermM -instance HasUniques (Program name uni fun ann) => Rename (Program name uni fun ann) where +instance HasUniques (Program name uni fun pat ann) => Rename (Program name uni fun pat ann) where -- See Note [Marking]. rename = through markNonFreshProgram >=> runRenameT . renameProgramM diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs index 8f7096b767d..979bdbe395f 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Rename/Internal.hs @@ -21,8 +21,8 @@ type MonadRename m = (MonadQuote m, MonadReader (Renaming TermUnique) m) -- | Rename a 'Term' in the 'RenameM' monad. renameTermM - :: (MonadRename m, HasUniques (Term name uni fun ann)) - => Term name uni fun ann -> m (Term name uni fun ann) + :: (MonadRename m, HasUniques (Term name uni fun pat ann)) + => Term name uni fun pat ann -> m (Term name uni fun pat ann) renameTermM (LamAbs ann name body) = withFreshenedName name $ \nameFr -> LamAbs ann nameFr <$> renameTermM body renameTermM (Apply ann fun arg) = Apply ann <$> renameTermM fun <*> renameTermM arg @@ -32,11 +32,13 @@ renameTermM (Delay ann term) = Delay ann <$> renameTermM term renameTermM (Force ann term) = Force ann <$> renameTermM term renameTermM (Constr ann i es) = Constr ann i <$> traverse renameTermM es renameTermM (Case ann arg cs) = Case ann <$> renameTermM arg <*> traverse renameTermM cs +renameTermM (Match ann arg alternatives) = + Match ann <$> renameTermM arg <*> traverse (traverse renameTermM) alternatives renameTermM con@Constant {} = pure con renameTermM bi@Builtin {} = pure bi -- | Rename a 'Program' in the 'RenameM' monad. renameProgramM - :: (MonadRename m, HasUniques (Program name uni fun ann)) - => Program name uni fun ann -> m (Program name uni fun ann) + :: (MonadRename m, HasUniques (Program name uni fun pat ann)) + => Program name uni fun pat ann -> m (Program name uni fun pat ann) renameProgramM (Program ann ver term) = Program ann ver <$> renameTermM term diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs index 606ae9021e5..bffc5523570 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Subst.hs @@ -27,44 +27,44 @@ import Universe -- | Applicatively replace a variable using the given function. substVarA :: Applicative f - => (name -> ann -> f (Maybe (Term name uni fun ann))) - -> Term name uni fun ann - -> f (Term name uni fun ann) + => (name -> ann -> f (Maybe (Term name uni fun pat ann))) + -> Term name uni fun pat ann + -> f (Term name uni fun pat ann) substVarA nameF t@(Var a name) = fromMaybe t <$> nameF name a substVarA _ t = pure t -- | Replace a variable using the given function. substVar - :: (name -> ann -> Maybe (Term name uni fun ann)) - -> Term name uni fun ann - -> Term name uni fun ann + :: (name -> ann -> Maybe (Term name uni fun pat ann)) + -> Term name uni fun pat ann + -> Term name uni fun pat ann substVar = purely (substVarA . curry) . uncurry -- | Naively monadically substitute names using the given function (i.e. do not substitute binders). termSubstNamesM :: Monad m - => (name -> ann -> m (Maybe (Term name uni fun ann))) - -> Term name uni fun ann - -> m (Term name uni fun ann) + => (name -> ann -> m (Maybe (Term name uni fun pat ann))) + -> Term name uni fun pat ann + -> m (Term name uni fun pat ann) termSubstNamesM = transformMOf termSubterms . substVarA -- | Naively substitute names using the given function (i.e. do not substitute binders). termSubstNames - :: (name -> ann -> Maybe (Term name uni fun ann)) - -> Term name uni fun ann - -> Term name uni fun ann + :: (name -> ann -> Maybe (Term name uni fun pat ann)) + -> Term name uni fun pat ann + -> Term name uni fun pat ann termSubstNames = purely (termSubstNamesM . curry) . uncurry -- | Completely replace the names with a new name type. termMapNames - :: forall name name' uni fun ann + :: forall name name' uni fun pat ann . (name -> name') - -> Term name uni fun ann - -> Term name' uni fun ann + -> Term name uni fun pat ann + -> Term name' uni fun pat ann termMapNames f = go where -- This is all a bit clunky because of the type-changing, I'm not sure of a nicer way to do it - go :: Term name uni fun ann -> Term name' uni fun ann + go :: Term name uni fun pat ann -> Term name' uni fun pat ann go = \case LamAbs ann name body -> LamAbs ann (f name) (go body) Var ann name -> Var ann (f name) @@ -73,49 +73,50 @@ termMapNames f = go Force ann t -> Force ann (go t) Constr ann i es -> Constr ann i (fmap go es) Case ann arg cs -> Case ann (go arg) (fmap go cs) + Match ann arg alternatives -> Match ann (go arg) (fmap (fmap go) alternatives) Constant ann c -> Constant ann c Builtin ann b -> Builtin ann b Error ann -> Error ann programMapNames - :: forall name name' uni fun ann + :: forall name name' uni fun pat ann . (name -> name') - -> Program name uni fun ann - -> Program name' uni fun ann + -> Program name uni fun pat ann + -> Program name' uni fun pat ann programMapNames f (Program a v term) = Program a v (termMapNames f term) -- TODO: this could be a Traversal -- | Get all the term variables in a term. -vTerm :: Fold (Term name uni fun ann) name +vTerm :: Fold (Term name uni fun pat ann) name vTerm = termSubtermsDeep . termVars -- | Applicatively replace a constant using the given function. substConstantA :: Applicative f - => (ann -> Some (ValueOf uni) -> f (Maybe (Term name uni fun ann))) - -> Term name uni fun ann - -> f (Term name uni fun ann) + => (ann -> Some (ValueOf uni) -> f (Maybe (Term name uni fun pat ann))) + -> Term name uni fun pat ann + -> f (Term name uni fun pat ann) substConstantA valF t@(Constant ann val) = fromMaybe t <$> valF ann val substConstantA _ t = pure t -- | Replace a constant using the given function. substConstant - :: (ann -> Some (ValueOf uni) -> Maybe (Term name uni fun ann)) - -> Term name uni fun ann - -> Term name uni fun ann + :: (ann -> Some (ValueOf uni) -> Maybe (Term name uni fun pat ann)) + -> Term name uni fun pat ann + -> Term name uni fun pat ann substConstant = purely (substConstantA . curry) . uncurry -- | Monadically substitute constants using the given function. termSubstConstantsM :: Monad m - => (ann -> Some (ValueOf uni) -> m (Maybe (Term name uni fun ann))) - -> Term name uni fun ann - -> m (Term name uni fun ann) + => (ann -> Some (ValueOf uni) -> m (Maybe (Term name uni fun pat ann))) + -> Term name uni fun pat ann + -> m (Term name uni fun pat ann) termSubstConstantsM = transformMOf termSubterms . substConstantA -- | Substitute constants using the given function. termSubstConstants - :: (ann -> Some (ValueOf uni) -> Maybe (Term name uni fun ann)) - -> Term name uni fun ann - -> Term name uni fun ann + :: (ann -> Some (ValueOf uni) -> Maybe (Term name uni fun pat ann)) + -> Term name uni fun pat ann + -> Term name uni fun pat ann termSubstConstants = purely (termSubstConstantsM . curry) . uncurry diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ApplyToCase.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ApplyToCase.hs index 1fd8d19b22b..a4edc48f810 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ApplyToCase.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ApplyToCase.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-| @@ -15,8 +16,10 @@ run at the end, but it runs for multiple iterations interleaved with other optimizations, because CSE can both destroy and enable further optimizations. -} module UntypedPlutusCore.Transform.ApplyToCase (applyToCase) where -import Control.Lens (over) +import Control.Lens (mapAccumLOf) +import Data.List (mapAccumL) import Data.Vector qualified as V +import PlutusCore.MkPlc (mkIterApp) import PlutusPrelude (getAnn) import UntypedPlutusCore.Core import UntypedPlutusCore.Transform.Optimizer @@ -31,17 +34,45 @@ minArgs = 3 applyToCase :: Monad m - => Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + => Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) applyToCase term = do let result = processTerm term recordOptimization term ApplyToCaseStage result pure result -processTerm :: Term name uni fun a -> Term name uni fun a -processTerm t = case splitApplication t of - (fun, args) - | length args >= minArgs -> - let ann = getAnn t - in Case ann (Constr ann 0 (processTerm . snd <$> args)) (V.singleton (processTerm fun)) - _ -> over termSubterms processTerm t +processTerm :: Term name uni fun pat a -> Term name uni fun pat a +processTerm = snd . go + where + go term = case splitApplication term of + (fun, args) + | length args >= minArgs -> + let (funHasMatch, fun') = go fun + (argsHaveMatch, args') = mapAccumL processArg False args + hasMatch = funHasMatch || argsHaveMatch + ann = getAnn term + result + | hasMatch = mkIterApp fun' args' + | otherwise = Case ann (Constr ann 0 (snd <$> args')) (V.singleton fun') + in (hasMatch, result) + _ -> + let (childHasMatch, term') = mapAccumLOf termSubterms processChild False term + hasMatch = isMatch term || childHasMatch + in (hasMatch, term') + + processChild found child = + let (childHasMatch, child') = go child + in (found || childHasMatch, child') + + processArg found (ann, arg) = + let (argHasMatch, arg') = go arg + in (found || argHasMatch, (ann, arg')) + + isMatch Match {} = True + isMatch _ = False + +-- A 'Match' can fail while evaluating a function or an intermediate application. Moving every +-- argument into a constructor would evaluate later arguments first, so @go@ does not rewrite an +-- application containing one. Splitting the full application spine before descending preserves +-- the original top-down behaviour of this pass, while propagating the flag avoids repeatedly +-- rescanning subtrees. diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseOfCase.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseOfCase.hs index 5e591852d23..b9feb2db7d8 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseOfCase.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseOfCase.hs @@ -60,13 +60,38 @@ caseOfCase , PLC.Closed uni , uni `PLC.Everywhere` Eq ) - => Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + => Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) caseOfCase term = do - let result = transformOf termSubterms processTerm term + let result = snd $ processTermWithMatch term recordOptimization term CaseOfCaseStage result return result +-- The rewrites below can change when constructor fields and branches are evaluated. A match in +-- one of them can therefore expose a different failure order. Skip only the enclosing rewrite and +-- let the recursive pass continue optimizing independent subterms. Propagating the flag bottom-up +-- avoids a quadratic repeated scan of ordinary Match-free programs. +processTermWithMatch + :: ( fun ~ PLC.DefaultFun + , CaseBuiltin uni + , PLC.GEq uni + , PLC.Closed uni + , uni `PLC.Everywhere` Eq + ) + => Term name uni fun pat a + -> (Bool, Term name uni fun pat a) +processTermWithMatch term = + let (childHasMatch, term') = mapAccumLOf termSubterms processChild False term + hasMatch = isMatch term || childHasMatch + in (hasMatch, if hasMatch then term' else processTerm term') + where + processChild found child = + let (childHasMatch, child') = processTermWithMatch child + in (found || childHasMatch, child') + + isMatch Match {} = True + isMatch _ = False + processTerm :: ( fun ~ PLC.DefaultFun , CaseBuiltin uni @@ -74,8 +99,8 @@ processTerm , PLC.Closed uni , uni `PLC.Everywhere` Eq ) - => Term name uni fun a -> Term name uni fun a -processTerm = \case + => Term name uni fun pat a -> Term name uni fun pat a +processTerm term = case term of Case ann scrut alts | ( ite@(Force a (Builtin _ PLC.IfThenElse)) , [cond, (trueAnn, true@Constr {}), (falseAnn, false@Constr {})] diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs index 9a3a53d75d2..732d0eae07f 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs @@ -7,7 +7,7 @@ module UntypedPlutusCore.Transform.CaseReduce , processTerm ) where -import Control.Lens (transformOf) +import Control.Lens (mapAccumLOf) import Data.Bifunctor (second) import Data.Vector qualified as V import PlutusCore.Builtin (CaseBuiltin (..)) @@ -21,15 +21,34 @@ import UntypedPlutusCore.Transform.Optimizer caseReduce :: (Monad m, CaseBuiltin uni) - => Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + => Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) caseReduce term = do - let result = transformOf termSubterms processTerm term + let result = snd $ processTermWithMatch term recordOptimization term CaseReduceStage result return result -processTerm :: CaseBuiltin uni => Term name uni fun a -> Term name uni fun a -processTerm = \case +processTermWithMatch + :: CaseBuiltin uni + => Term name uni fun pat a + -> (Bool, Term name uni fun pat a) +processTermWithMatch term = + let (childHasMatch, term') = mapAccumLOf termSubterms processChild False term + hasMatch = isMatch term || childHasMatch + in (hasMatch, if hasMatch then term' else processTerm term') + where + processChild found child = + let (childHasMatch, child') = processTermWithMatch child + in (found || childHasMatch, child') + + isMatch Match {} = True + isMatch _ = False + +processTerm + :: CaseBuiltin uni + => Term name uni fun pat a + -> Term name uni fun pat a +processTerm term = case term of -- We could've rewritten those patterns as 'Error' in the 'Nothing' cases, but that would turn a -- structural error into an operational one, which would be unfortunate, so instead we decided -- not to fully optimize such scripts, since they aren't valid anyway. @@ -39,3 +58,7 @@ processTerm = \case Case ann (Constant _ con) cs | Right t <- headSpineToTerm ann (second (Constant ann) (caseBuiltin con cs)) -> t t -> t + +-- A match in a branch can fail after an early argument. The original 'Constr' evaluates all fields +-- before branch selection, so 'processTermWithMatch' skips only the enclosing rewrite while still +-- optimizing independent children in one bottom-up traversal. diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Certify/Hints.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Certify/Hints.hs index 4a8ea27b3bc..f9416d0b8d3 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Certify/Hints.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Certify/Hints.hs @@ -17,6 +17,7 @@ data Inline | InlError | InlConstr [Inline] | InlCase Inline [Inline] + | InlMatch Inline [Inline] | InlExpand Inline | InlDrop Inline deriving stock (Generic) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Certify/Trace.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Certify/Trace.hs index 8539c3e9a51..cc201bd4118 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Certify/Trace.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Certify/Trace.hs @@ -97,26 +97,26 @@ pattern PolyBuiltinStage = Left PolyBuiltin , PolyBuiltinStage #-} -data Optimization name uni fun a +data Optimization name uni fun pat a = Optimization - { beforeAST :: Term name uni fun a + { beforeAST :: Term name uni fun pat a , stage :: OptStage , hints :: Certify.Hints - , afterAST :: Term name uni fun a + , afterAST :: Term name uni fun pat a } -- TODO2: we probably don't want this in memory so after MVP -- we should consider serializing this to disk -newtype OptimizerTrace name uni fun a +newtype OptimizerTrace name uni fun pat a = OptimizerTrace { optimizerTrace - :: [Optimization name uni fun a] + :: [Optimization name uni fun pat a] } -initOptimizerTrace :: OptimizerTrace name uni fun a +initOptimizerTrace :: OptimizerTrace name uni fun pat a initOptimizerTrace = OptimizerTrace [] -allASTs :: OptimizerTrace name uni fun a -> [Term name uni fun a] +allASTs :: OptimizerTrace name uni fun pat a -> [Term name uni fun pat a] allASTs = \case OptimizerTrace [] -> [] OptimizerTrace xs@(x : _) -> diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs index 703361b2a06..39a0822b8b4 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs @@ -65,11 +65,11 @@ We use the following example to explain how the implementation works: The implementation makes several passes on the given term. -In the first pass, we assign a unique ID to each `LamAbs`, `Delay`, and each `Case` branch. +In the first pass, we assign a unique ID to each `LamAbs`, `Delay`, and each `Case` or `Match` branch. Then, we annotate each subterm with a path, consisting of IDs encountered from the root to that subterm (not including itself). The reason to do this is because `LamAbs`, `Delay`, -and `Case` branches represent places where computation stops, i.e., subexpressions are not -immediately evaluated, and may not be evaluated at all. +and `Case` or `Match` branches represent places where computation stops, i.e., subexpressions are +not immediately evaluated, and may not be evaluated at all. In the above example, the ID of `\x` is 0, the ID of `\y` is 1, and the IDs of the three case branches are 2, 3, 4 (the actual numbers don't matter, as long as they are unique). @@ -204,24 +204,24 @@ type Path = [Int] isAncestorOrSelf :: Path -> Path -> Bool isAncestorOrSelf = isSuffixOf -data CseCandidate uni fun ann = CseCandidate +data CseCandidate uni fun pat ann = CseCandidate { ccFreshName :: Name - , ccTerm :: Term Name uni fun () - , ccAnnotatedTerm :: Term Name uni fun (Path, ann) + , ccTerm :: Term Name uni fun pat () + , ccAnnotatedTerm :: Term Name uni fun pat (Path, ann) {-^ `ccTerm` is needed for equality comparison, while `ccAnnotatedTerm` is needed for the actual substitution. They are always the same term barring the annotations. -} } cse :: ( MonadQuote m - , Hashable (Term Name uni fun ()) - , Rename (Term Name uni fun ann) + , Hashable (Term Name uni fun pat ()) + , Rename (Term Name uni fun pat ann) , ToBuiltinMeaning uni fun ) => CseWhichSubterms -> BuiltinSemanticsVariant fun - -> Term Name uni fun ann - -> OptimizerT Name uni fun ann m (Term Name uni fun ann) + -> Term Name uni fun pat ann + -> OptimizerT Name uni fun pat ann m (Term Name uni fun pat ann) cse whichSubterms builtinSemanticsVariant t0 = do t <- rename t0 let annotated = annotate t @@ -240,12 +240,14 @@ cse whichSubterms builtinSemanticsVariant t0 = do return result -- | The first pass. See Note [CSE]. -annotate :: Term name uni fun ann -> Term name uni fun (Path, ann) +annotate :: Term name uni fun pat ann -> Term name uni fun pat (Path, ann) annotate = flip evalState 0 . flip runReaderT [] . go where -- The integer state is the highest ID assigned so far. -- The reader context is the current path. - go :: Term name uni fun ann -> ReaderT Path (State Int) (Term name uni fun (Path, ann)) + go + :: Term name uni fun pat ann + -> ReaderT Path (State Int) (Term name uni fun pat (Path, ann)) go t = do path <- ask case t of @@ -269,6 +271,15 @@ annotate = flip evalState 0 . flip runReaderT [] . go freshId <- (+ 1) <$> lift get lift $ put freshId Delay (path, ann) <$> local (freshId :) (go body) + Match ann scrut alternatives -> + Match (path, ann) + <$> go scrut + <*> ( for alternatives $ \(pat, handler) -> do + freshId <- (+ 1) <$> lift get + lift $ put freshId + handler' <- local (freshId :) (go handler) + pure (pat, handler') + ) Case ann scrut branches -> Case (path, ann) <$> go scrut @@ -281,10 +292,10 @@ annotate = flip evalState 0 . flip runReaderT [] . go {-| The notion of work-free expressions is extended to also include partially applied/forced built-ins. -} isWorkFree' - :: forall name uni fun a + :: forall name uni fun pat a . ToBuiltinMeaning uni fun => BuiltinSemanticsVariant fun - -> Term name uni fun a + -> Term name uni fun pat a -> Bool isWorkFree' builtinSemanticsVariant term = isWorkFree builtinSemanticsVariant term @@ -304,12 +315,12 @@ isWorkFree' builtinSemanticsVariant term = -- | The second pass. See Note [CSE]. countOccs - :: forall name uni fun ann - . (Hashable (Term name uni fun ()), ToBuiltinMeaning uni fun) + :: forall name uni fun pat ann + . (Hashable (Term name uni fun pat ()), ToBuiltinMeaning uni fun) => CseWhichSubterms -> BuiltinSemanticsVariant fun - -> Term name uni fun (Path, ann) - -> HashMap (Term name uni fun ()) [(Path, Term name uni fun (Path, ann), Int)] + -> Term name uni fun pat (Path, ann) + -> HashMap (Term name uni fun pat ()) [(Path, Term name uni fun pat (Path, ann), Int)] {-^ Here, the value of the inner map not only contains the count, but also contains the annotated term, corresponding to the term that is the key of the outer map. The annotated terms need to be recorded since they will be used for substitution. -} @@ -321,9 +332,13 @@ countOccs whichSubterms builtinSemanticsVariant = where addOrSkip , addToMap - :: Term name uni fun (Path, ann) - -> HashMap (Term name uni fun ()) [(Path, Term name uni fun (Path, ann), Int)] - -> HashMap (Term name uni fun ()) [(Path, Term name uni fun (Path, ann), Int)] + :: Term name uni fun pat (Path, ann) + -> HashMap + (Term name uni fun pat ()) + [(Path, Term name uni fun pat (Path, ann), Int)] + -> HashMap + (Term name uni fun pat ()) + [(Path, Term name uni fun pat (Path, ann), Int)] addOrSkip t0 | isWorkFree' builtinSemanticsVariant t0 = id @@ -342,17 +357,17 @@ countOccs whichSubterms builtinSemanticsVariant = -- | Combine a new path with a number of existing (path, count) pairs. combinePaths - :: forall name uni fun ann - . Term name uni fun (Path, ann) + :: forall name uni fun pat ann + . Term name uni fun pat (Path, ann) -> Path - -> [(Path, Term name uni fun (Path, ann), Int)] - -> [(Path, Term name uni fun (Path, ann), Int)] + -> [(Path, Term name uni fun pat (Path, ann), Int)] + -> [(Path, Term name uni fun pat (Path, ann), Int)] combinePaths t path = go 1 where go :: Int - -> [(Path, Term name uni fun (Path, ann), Int)] - -> [(Path, Term name uni fun (Path, ann), Int)] + -> [(Path, Term name uni fun pat (Path, ann), Int)] + -> [(Path, Term name uni fun pat (Path, ann), Int)] -- The new path is not a descendent-or-self of any existing path. go acc [] = [(path, t, acc)] go acc ((path', t', cnt) : paths) @@ -367,27 +382,29 @@ combinePaths t path = go 1 | otherwise = (path', t', cnt) : go acc paths mkCseTerm - :: forall uni fun ann m - . (MonadQuote m, Eq (Term Name uni fun ())) - => [Term Name uni fun (Path, ann)] - -> Term Name uni fun (Path, ann) + :: forall uni fun pat ann m + . (MonadQuote m, Eq (Term Name uni fun pat ())) + => [Term Name uni fun pat (Path, ann)] + -> Term Name uni fun pat (Path, ann) -- ^ The original annotated term - -> m (Term Name uni fun ann) + -> m (Term Name uni fun pat ann) mkCseTerm ts t = do cs <- traverse mkCseCandidate ts pure . fmap snd $ Foldable.foldl' (flip applyCse) t cs applyCse - :: forall uni fun ann - . Eq (Term Name uni fun ()) - => CseCandidate uni fun ann - -> Term Name uni fun (Path, ann) - -> Term Name uni fun (Path, ann) + :: forall uni fun pat ann + . Eq (Term Name uni fun pat ()) + => CseCandidate uni fun pat ann + -> Term Name uni fun pat (Path, ann) + -> Term Name uni fun pat (Path, ann) applyCse candidate = mkLamApp . transformOf termSubterms substCseVarForTerm where candidatePath = fst (getAnn (ccAnnotatedTerm candidate)) - substCseVarForTerm :: Term Name uni fun (Path, ann) -> Term Name uni fun (Path, ann) + substCseVarForTerm + :: Term Name uni fun pat (Path, ann) + -> Term Name uni fun pat (Path, ann) substCseVarForTerm t = if currTerm == ccTerm candidate && candidatePath `isAncestorOrSelf` currPath then Var (getAnn t) (ccFreshName candidate) @@ -396,7 +413,7 @@ applyCse candidate = mkLamApp . transformOf termSubterms substCseVarForTerm currTerm = void t currPath = fst (getAnn t) - mkLamApp :: Term Name uni fun (Path, ann) -> Term Name uni fun (Path, ann) + mkLamApp :: Term Name uni fun pat (Path, ann) -> Term Name uni fun pat (Path, ann) mkLamApp t | currPath == candidatePath = placeCseBinding t | currPath `isAncestorOrSelf` candidatePath = case t of @@ -410,12 +427,17 @@ applyCse candidate = mkLamApp . transformOf termSubterms substCseVarForTerm Error ann -> Error ann Constr ann i ts -> Constr ann i (mkLamApp <$> ts) Case ann scrut branches -> Case ann (mkLamApp scrut) (mkLamApp <$> branches) + Match ann scrut alternatives -> + Match ann (mkLamApp scrut) $ + fmap (\(pat, handler) -> (pat, mkLamApp handler)) alternatives | otherwise = t where currPath = fst (getAnn t) -- See Note [CSE and immediately applied lambdas] - placeCseBinding :: Term Name uni fun (Path, ann) -> Term Name uni fun (Path, ann) + placeCseBinding + :: Term Name uni fun pat (Path, ann) + -> Term Name uni fun pat (Path, ann) placeCseBinding node = case node of -- Immediately applied lambda: if `arg` does not use `cseName`, we'd want to be sure -- to descend into the *body* of the lambda. @@ -443,6 +465,10 @@ applyCse candidate = mkLamApp . transformOf termSubterms substCseVarForTerm -- Descend into the scrutinee, if no branch uses `cseName`. Case ann (placeCseBinding scrut) branches | otherwise -> wrapWithCse node + Match ann scrut alternatives + | not (any (cseName `occursIn`) (snd <$> alternatives)) -> + Match ann (placeCseBinding scrut) alternatives + | otherwise -> wrapWithCse node _ -> wrapWithCse node where cseName = ccFreshName candidate @@ -452,7 +478,7 @@ applyCse candidate = mkLamApp . transformOf termSubterms substCseVarForTerm (LamAbs (getAnn n) cseName n) (ccAnnotatedTerm candidate) -occursIn :: Eq name => name -> Term name uni fun a -> Bool +occursIn :: Eq name => name -> Term name uni fun pat a -> Bool occursIn n = go where go = \case @@ -463,14 +489,15 @@ occursIn n = go Delay _ t -> go t Constr _ _ ts -> any go ts Case _ scrut branches -> go scrut || any go branches + Match _ scrut alternatives -> go scrut || any (go . snd) alternatives _ -> False -- | Generate a fresh variable for the common subexpression. mkCseCandidate - :: forall uni fun ann m + :: forall uni fun pat ann m . MonadQuote m - => Term Name uni fun (Path, ann) - -> m (CseCandidate uni fun ann) + => Term Name uni fun pat (Path, ann) + -> m (CseCandidate uni fun pat ann) mkCseCandidate t = CseCandidate <$> freshName "cse" <*> pure (void t) <*> pure t {- Note [CSE and immediately applied lambdas] diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/EvaluateBuiltins.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/EvaluateBuiltins.hs index ab6e9b66634..b4982b68055 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/EvaluateBuiltins.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/EvaluateBuiltins.hs @@ -18,37 +18,38 @@ import Control.Lens (transformOf, (^.)) import Data.Functor (void) evaluateBuiltinsPass - :: (Monad m, ToBuiltinMeaning uni fun, Typeable name) + :: (Monad m, ToBuiltinMeaning uni fun, Typeable name, Typeable pat) => Bool -- ^ Whether to be conservative and try to retain logging behaviour. -> BuiltinsInfo uni fun -> CostingPart uni fun - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) evaluateBuiltinsPass preserveLogging binfo costModel term = do result <- evaluateBuiltins preserveLogging binfo costModel term recordOptimization term ConstantFoldingStage result return result evaluateBuiltins - :: forall m name uni fun a + :: forall m name uni fun pat a . ( Monad m , ToBuiltinMeaning uni fun , Typeable name + , Typeable pat ) => Bool -- ^ Whether to be conservative and try to retain logging behaviour. -> BuiltinsInfo uni fun -> CostingPart uni fun - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) evaluateBuiltins preserveLogging binfo costModel = pure . transformOf termSubterms processTerm where eval - :: BuiltinRuntime (Term name uni fun ()) - -> AppCtx name uni fun a - -> Maybe (Term name uni fun ()) + :: BuiltinRuntime (Term name uni fun pat ()) + -> AppCtx name uni fun pat a + -> Maybe (Term name uni fun pat ()) eval (BuiltinCostedResult _ getFXs) AppCtxEnd = case getFXs of BuiltinSuccess y -> Just y @@ -60,7 +61,7 @@ evaluateBuiltins preserveLogging binfo costModel = eval runtime ctx eval _ _ = Nothing - processTerm :: Term name uni fun a -> Term name uni fun a + processTerm :: Term name uni fun pat a -> Term name uni fun pat a -- See Note [Context splitting in a recursive pass] processTerm t@(splitAppCtx -> (Builtin x bn, argCtx)) = let runtime = toBuiltinRuntime costModel (toBuiltinMeaning (binfo ^. biSemanticsVariant) bn) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/FloatDelay.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/FloatDelay.hs index bc7765c82c4..defddc8bcc7 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/FloatDelay.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/FloatDelay.hs @@ -77,13 +77,13 @@ import PlutusCore.Builtin.Meaning (ToBuiltinMeaning) floatDelay :: ( PLC.MonadQuote m - , PLC.Rename (Term name uni fun a) + , PLC.Rename (Term name uni fun pat a) , PLC.HasUnique name PLC.TermUnique , ToBuiltinMeaning uni fun ) => BuiltinSemanticsVariant fun - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) floatDelay semvar term = do result <- PLC.rename term >>= \t -> @@ -94,13 +94,13 @@ floatDelay semvar term = do {-| First pass. Returns the names of all variables, at least one occurrence of which is not under `Force`. -} unforcedVars - :: forall name uni fun a + :: forall name uni fun pat a . PLC.HasUnique name PLC.TermUnique - => Term name uni fun a + => Term name uni fun pat a -> PLC.UniqueSet PLC.TermUnique unforcedVars = execWriter . go where - go :: Term name uni fun a -> Writer (PLC.UniqueSet PLC.TermUnique) () + go :: Term name uni fun pat a -> Writer (PLC.UniqueSet PLC.TermUnique) () go = \case Var _ n -> tell (USet.singletonName n) Force _ Var {} -> pure () @@ -109,18 +109,20 @@ unforcedVars = execWriter . go {-| Second pass. Removes `Delay` from eligible arguments, and returns the names of variables whose corresponding arguments are modified. -} simplifyArgs - :: forall name uni fun a + :: forall name uni fun pat a . ( PLC.HasUnique name PLC.TermUnique , ToBuiltinMeaning uni fun ) => BuiltinSemanticsVariant fun -> PLC.UniqueSet PLC.TermUnique -- ^ The set of variables returned by `unforcedVars`. - -> Term name uni fun a - -> (Term name uni fun a, PLC.UniqueMap PLC.TermUnique a) + -> Term name uni fun pat a + -> (Term name uni fun pat a, PLC.UniqueMap PLC.TermUnique a) simplifyArgs semvar blacklist = runWriter . go where - go :: Term name uni fun ann -> Writer (PLC.UniqueMap PLC.TermUnique ann) (Term name uni fun ann) + go + :: Term name uni fun pat ann + -> Writer (PLC.UniqueMap PLC.TermUnique ann) (Term name uni fun pat ann) go = \case Apply appAnn (LamAbs lamAnn n lamBody) (Delay delayAnn arg) | isPure semvar arg @@ -134,8 +136,8 @@ simplifyArgs semvar blacklist = runWriter . go simplifyBodies :: PLC.HasUnique name PLC.TermUnique => PLC.UniqueMap PLC.TermUnique a - -> Term name uni fun a - -> Term name uni fun a + -> Term name uni fun pat a + -> Term name uni fun pat a simplifyBodies whitelist = transformOf termSubterms $ \case var@(Var _ n) | Just ann <- UMap.lookupName n whitelist -> Delay ann var diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceCaseDelay.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceCaseDelay.hs index a9db82bff5e..484a1c29b1d 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceCaseDelay.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceCaseDelay.hs @@ -46,14 +46,14 @@ import Control.Lens forceCaseDelay :: Monad m - => Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + => Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) forceCaseDelay term = do let result = transformOf termSubterms processTerm term recordOptimization term ForceCaseDelayStage result return result -processTerm :: Term name uni fun a -> Term name uni fun a +processTerm :: Term name uni fun pat a -> Term name uni fun pat a processTerm = \case original@(Force _ (Case cAnn scrut branches)) -> let mNewBranches = traverse findDelayUnderLambdas branches @@ -63,7 +63,7 @@ processTerm = \case Nothing -> original other -> other where - findDelayUnderLambdas :: Term name uni fun a -> Maybe (Term name uni fun a) + findDelayUnderLambdas :: Term name uni fun pat a -> Maybe (Term name uni fun pat a) findDelayUnderLambdas = \case LamAbs ann var body -> LamAbs ann var <$> findDelayUnderLambdas body Delay _ term -> Just term 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 8a18e700c66..a5e9749ed2d 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs @@ -170,8 +170,8 @@ import Data.Foldable as Foldable (foldl') forceDelay :: (uni ~ DefaultUni, fun ~ DefaultFun, Monad m) => BuiltinSemanticsVariant fun - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) forceDelay semVar term = do let result = transformOf termSubterms (processTerm semVar) term recordOptimization term ForceDelayStage result @@ -181,7 +181,9 @@ forceDelay semVar term = do the 'Force' down into the underlying lambda abstractions. -} processTerm :: (uni ~ DefaultUni, fun ~ DefaultFun) - => BuiltinSemanticsVariant fun -> Term name uni fun a -> Term name uni fun a + => BuiltinSemanticsVariant fun + -> Term name uni fun pat a + -> Term name uni fun pat a processTerm semVar = \case Force _ (Delay _ t) -> t -- Remove @Delay@s from @ifThenElse@ branches if the latter is @Force@d and the delayed term are @@ -207,7 +209,7 @@ processTerm semVar = \case multiple applications on top of multiple abstractions. Checks whether the lambda will eventually get "exactly reduced" and applies the optimisation. Returns 'Nothing' if the optimisation cannot be applied. -} -optimisationProcedure :: Term name uni fun a -> Maybe (Term name uni fun a) +optimisationProcedure :: Term name uni fun pat a -> Maybe (Term name uni fun pat a) optimisationProcedure term = do asMultiApply <- toMultiApply term innerMultiAbs <- toMultiAbs . appHead $ asMultiApply @@ -220,12 +222,12 @@ optimisationProcedure term = do in pure . fromMultiApply $ optimisedMultiApply _ -> Nothing -data MultiApply name uni fun a = MultiApply - { appHead :: Term name uni fun a - , appSpineRev :: [(a, Term name uni fun a)] +data MultiApply name uni fun pat a = MultiApply + { appHead :: Term name uni fun pat a + , appSpineRev :: [(a, Term name uni fun pat a)] } -toMultiApply :: Term name uni fun a -> Maybe (MultiApply name uni fun a) +toMultiApply :: Term name uni fun pat a -> Maybe (MultiApply name uni fun pat a) toMultiApply term = case term of Apply _ _ _ -> run [] term @@ -236,16 +238,16 @@ toMultiApply term = run acc t = pure $ MultiApply t acc -fromMultiApply :: MultiApply name uni fun a -> Term name uni fun a +fromMultiApply :: MultiApply name uni fun pat a -> Term name uni fun pat a fromMultiApply (MultiApply term ts) = Foldable.foldl' (\acc (ann, arg) -> Apply ann acc arg) term ts -data MultiAbs name uni fun a = MultiAbs +data MultiAbs name uni fun pat a = MultiAbs { absVars :: [(a, name)] - , absRhs :: Term name uni fun a + , absRhs :: Term name uni fun pat a } -toMultiAbs :: Term name uni fun a -> Maybe (MultiAbs name uni fun a) +toMultiAbs :: Term name uni fun pat a -> Maybe (MultiAbs name uni fun pat a) toMultiAbs term = case term of LamAbs _ _ _ -> run [] term @@ -256,6 +258,6 @@ toMultiAbs term = run acc t = pure $ MultiAbs acc t -fromMultiAbs :: MultiAbs name uni fun a -> Term name uni fun a +fromMultiAbs :: MultiAbs name uni fun pat a -> Term name uni fun pat a fromMultiAbs (MultiAbs vars term) = Foldable.foldl' (\acc (ann, name) -> LamAbs ann name acc) term vars diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs index 0857f0d094d..a06d07d8df2 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs @@ -90,29 +90,29 @@ the PIR inliner. -} -- | Substitution range, 'SubstRng' in the paper. -newtype InlineTerm name uni fun a = Done (Dupable (Term name uni fun a)) +newtype InlineTerm name uni fun pat a = Done (Dupable (Term name uni fun pat a)) {-| Term substitution, 'Subst' in the paper. A map of unprocessed variable and its substitution range. -} -newtype TermEnv name uni fun a = TermEnv - {_unTermEnv :: PLC.UniqueMap TermUnique (InlineTerm name uni fun a)} +newtype TermEnv name uni fun pat a = TermEnv + {_unTermEnv :: PLC.UniqueMap TermUnique (InlineTerm name uni fun pat a)} deriving newtype (Semigroup, Monoid) {-| Wrapper of term substitution so that it's similar to the PIR inliner. See Note [Differences from PIR inliner] 1 -} -newtype Subst name uni fun a = Subst {_termEnv :: TermEnv name uni fun a} +newtype Subst name uni fun pat a = Subst {_termEnv :: TermEnv name uni fun pat a} deriving stock (Generic) deriving newtype (Semigroup, Monoid) makeLenses ''TermEnv makeLenses ''Subst -data VarInfo name uni fun ann = VarInfo +data VarInfo name uni fun pat ann = VarInfo { _varBinders :: [(name, ann)] -- ^ Lambda binders in the RHS (definition) of the variable. - , _varRhs :: Term name uni fun ann + , _varRhs :: Term name uni fun pat ann -- ^ The RHS (definition) of the variable. - , _varRhsBody :: InlineTerm name uni fun ann + , _varRhsBody :: InlineTerm name uni fun pat ann {-^ The body of the RHS of the variable (i.e., RHS minus the binders). Using 'InlineTerm' here to ensure the body is renamed when inlined. -} } @@ -120,17 +120,17 @@ data VarInfo name uni fun ann = VarInfo makeLenses ''VarInfo -- | UPLC inliner state -data S name uni fun a = S - { _subst :: Subst name uni fun a - , _vars :: PLC.UniqueMap TermUnique (VarInfo name uni fun a) +data S name uni fun pat a = S + { _subst :: Subst name uni fun pat a + , _vars :: PLC.UniqueMap TermUnique (VarInfo name uni fun pat a) } makeLenses ''S -instance Semigroup (S name uni fun a) where +instance Semigroup (S name uni fun pat a) where S a1 b1 <> S a2 b2 = S (a1 <> a2) (b1 <> b2) -instance Monoid (S name uni fun a) where +instance Monoid (S name uni fun pat a) where mempty = S mempty mempty type ExternalConstraints name uni fun m = @@ -163,15 +163,15 @@ makeLenses ''InlineInfo -- of this module (determined from profiling) -- | The monad the inliner runs in. -type InlineM name uni fun a = - ReaderT (InlineInfo name fun a) (StateT (S name uni fun (Ann a)) Quote) +type InlineM name uni fun pat a = + ReaderT (InlineInfo name fun a) (StateT (S name uni fun pat (Ann a)) Quote) -- | Look up the unprocessed variable in the substitution. lookupTerm :: HasUnique name TermUnique => name - -> S name uni fun a - -> Maybe (InlineTerm name uni fun a) + -> S name uni fun pat a + -> Maybe (InlineTerm name uni fun pat a) lookupTerm n s = UMap.lookupName n $ s ^. subst . termEnv . unTermEnv -- | Insert the unprocessed variable into the substitution. @@ -179,33 +179,33 @@ extendTerm :: HasUnique name TermUnique => name -- ^ The name of the variable. - -> InlineTerm name uni fun a + -> InlineTerm name uni fun pat a -- ^ The substitution range. - -> S name uni fun a + -> S name uni fun pat a -- ^ The substitution. - -> S name uni fun a + -> S name uni fun pat a extendTerm n clos s = s & subst . termEnv . unTermEnv %~ UMap.insertByName n clos lookupVarInfo :: HasUnique name TermUnique => name - -> S name uni fun a - -> Maybe (VarInfo name uni fun a) + -> S name uni fun pat a + -> Maybe (VarInfo name uni fun pat a) lookupVarInfo n s = UMap.lookupName n $ s ^. vars extendVarInfo :: HasUnique name TermUnique => name - -> VarInfo name uni fun a - -> S name uni fun a - -> S name uni fun a + -> VarInfo name uni fun pat a + -> S name uni fun pat a + -> S name uni fun pat a extendVarInfo n info s = s & vars %~ UMap.insertByName n info {-| Inline simple bindings. Relies on global uniqueness, and preserves it. See Note [Inlining and global uniqueness] -} inline - :: forall name uni fun m a + :: forall name uni fun pat m a . ExternalConstraints name uni fun m => AstSize -- ^ unconditional threshold @@ -217,8 +217,8 @@ inline -- ^ preserve logging -> InlineHints name a -> PLC.BuiltinSemanticsVariant fun - -> Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) inline unconditionalGrowth callsiteGrowth @@ -261,8 +261,8 @@ Some examples will help (annotations are omitted): [[(\x . t) a] b] -> Nothing -} extractApps - :: Term name uni fun a - -> Maybe ([(UTermDef name uni fun a, a)], Term name uni fun a) + :: Term name uni fun pat a + -> Maybe ([(UTermDef name uni fun pat a, a)], Term name uni fun pat a) extractApps = go [] where go argStack (Apply aa f arg) = go ((arg, aa) : argStack) f @@ -275,9 +275,9 @@ extractApps = go [] -- | The inverse of 'extractApps'. restoreApps - :: [(Either (Ann a) (UTermDef name uni fun (Ann a)), Ann a)] - -> Term name uni fun (Ann a) - -> Term name uni fun (Ann a) + :: [(Either (Ann a) (UTermDef name uni fun pat (Ann a)), Ann a)] + -> Term name uni fun pat (Ann a) + -> Term name uni fun pat (Ann a) restoreApps defs t = makeLams [] t (reverse defs) where -- `aa` is the annotation on the Apply node, and `al` is the annotation @@ -301,15 +301,15 @@ restoreApps defs t = makeLams [] t (reverse defs) -- | Run the inliner on a `UntypedPlutusCore.Core.Type.Term`. processTerm - :: forall name uni fun a + :: forall name uni fun pat a . InliningConstraints name uni fun - => Term name uni fun (Ann a) - -> InlineM name uni fun a (Term name uni fun (Ann a)) + => Term name uni fun pat (Ann a) + -> InlineM name uni fun pat a (Term name uni fun pat (Ann a)) processTerm = handleTerm where handleTerm - :: Term name uni fun (Ann a) - -> InlineM name uni fun a (Term name uni fun (Ann a)) + :: Term name uni fun pat (Ann a) + -> InlineM name uni fun pat a (Term name uni fun pat (Ann a)) handleTerm = \case v@(Var a n) -> maybe @@ -325,13 +325,13 @@ processTerm = handleTerm t -> inlineSaturatedApp =<< forMOf termSubterms t processTerm -- See Note [Renaming strategy] - substName :: name -> InlineM name uni fun a (Maybe (Term name uni fun (Ann a))) + substName :: name -> InlineM name uni fun pat a (Maybe (Term name uni fun pat (Ann a))) substName name = gets (lookupTerm name) >>= traverse renameTerm -- See Note [Inlining approach and 'Secrets of the GHC Inliner'] renameTerm - :: InlineTerm name uni fun (Ann a) - -> InlineM name uni fun a (Term name uni fun (Ann a)) + :: InlineTerm name uni fun pat (Ann a) + -> InlineM name uni fun pat a (Term name uni fun pat (Ann a)) renameTerm = \case -- Already processed term, just rename and put it in, don't do any -- further optimization here. @@ -339,9 +339,9 @@ processTerm = handleTerm processSingleBinding :: InliningConstraints name uni fun - => Term name uni fun (Ann a) - -> (UTermDef name uni fun (Ann a), Ann a) - -> InlineM name uni fun a (Either (Ann a) (UTermDef name uni fun (Ann a)), Ann a) + => Term name uni fun pat (Ann a) + -> (UTermDef name uni fun pat (Ann a), Ann a) + -> InlineM name uni fun pat a (Either (Ann a) (UTermDef name uni fun pat (Ann a)), Ann a) processSingleBinding body (Def vd@(UVarDecl a n) rhs0, aa) = (,aa) <$> do maybeAddSubst body (snd a) n rhs0 >>= \case @@ -363,13 +363,13 @@ Nothing means that we are inlining the term: * we have extended the substitution, and * we are removing the binding (hence we return Nothing). -} maybeAddSubst - :: forall name uni fun a + :: forall name uni fun pat a . InliningConstraints name uni fun - => Term name uni fun (Ann a) + => Term name uni fun pat (Ann a) -> a -> name - -> Term name uni fun (Ann a) - -> InlineM name uni fun a (Maybe (Term name uni fun (Ann a))) + -> Term name uni fun pat (Ann a) + -> InlineM name uni fun pat a (Maybe (Term name uni fun pat (Ann a))) maybeAddSubst body a n rhs0 = do rhs <- processTerm rhs0 @@ -388,8 +388,8 @@ maybeAddSubst body a n rhs0 = do where extendAndDrop :: forall b - . InlineTerm name uni fun (Ann a) - -> InlineM name uni fun a (Maybe b) + . InlineTerm name uni fun pat (Ann a) + -> InlineM name uni fun pat a (Maybe b) extendAndDrop t = modify' (extendTerm n t) >> pure Nothing shouldUnconditionallyInline @@ -398,9 +398,9 @@ shouldUnconditionallyInline {-^ Whether we know that the binding is safe to inline. If so, bypass the purity check. -} -> name - -> Term name uni fun a - -> Term name uni fun b - -> InlineM name uni fun c Bool + -> Term name uni fun pat a + -> Term name uni fun pat b + -> InlineM name uni fun pat c Bool shouldUnconditionallyInline safe n rhs body = do isTermPure <- checkPurity rhs inlineConstants <- view iiInlineConstants @@ -423,17 +423,17 @@ shouldUnconditionallyInline safe n rhs body = do -- | Check if term is pure. See Note [Inlining and purity] checkPurity :: PLC.ToBuiltinMeaning uni fun - => Term name uni fun a - -> InlineM name uni fun b Bool + => Term name uni fun pat a + -> InlineM name uni fun pat b Bool checkPurity t = do builtinSemanticsVariant <- view iiBuiltinSemanticsVariant pure $ isPure builtinSemanticsVariant t nameUsedAtMostOnce - :: forall name uni fun a + :: forall name uni fun pat a . InliningConstraints name uni fun => name - -> InlineM name uni fun a Bool + -> InlineM name uni fun pat a Bool nameUsedAtMostOnce n = do usgs <- view iiUsages -- 'inlining' terms used 0 times is a cheap way to remove dead code @@ -441,11 +441,11 @@ nameUsedAtMostOnce n = do pure $ Usages.getUsageCount n usgs <= 1 isFirstVarBeforeEffects - :: forall name uni fun ann + :: forall name uni fun pat ann . InliningConstraints name uni fun => BuiltinSemanticsVariant fun -> name - -> Term name uni fun ann + -> Term name uni fun pat ann -> Bool isFirstVarBeforeEffects builtinSemanticsVariant n t = -- This can in the worst case traverse a lot of the term, which could lead to @@ -470,14 +470,14 @@ isFirstVarBeforeEffects builtinSemanticsVariant n t = * lambda body * case branch -} isStrictIn - :: forall name uni fun a + :: forall name uni fun pat a . Eq name => name - -> Term name uni fun a + -> Term name uni fun pat a -> Bool isStrictIn name = go where - go :: Term name uni fun a -> Bool + go :: Term name uni fun pat a -> Bool go = \case Var _ann name' -> name == name' LamAbs _ann _paramName _body -> False @@ -489,15 +489,16 @@ isStrictIn name = go Error {} -> False Constr _ann _idx terms -> any go terms Case _ann scrut _branches -> go scrut + Match _ann scrut _alternatives -> go scrut effectSafe - :: forall name uni fun a b + :: forall name uni fun pat a b . InliningConstraints name uni fun - => Term name uni fun a + => Term name uni fun pat a -> name -> Bool -- ^ is it pure? See Note [Inlining and purity] - -> InlineM name uni fun b Bool + -> InlineM name uni fun pat b Bool effectSafe body n termIsPure = do preserveLogging <- view iiPreserveLogging builtinSemantics <- view iiBuiltinSemanticsVariant @@ -511,8 +512,8 @@ or code. See Note [Inlining approach and 'Secrets of the GHC Inliner'] -} acceptable :: Bool -- ^ inline constants - -> Term name uni fun a - -> InlineM name uni fun b Bool + -> Term name uni fun pat a + -> InlineM name uni fun pat b Bool acceptable inlineConstants t = do unconditionalGrowth <- view iiInlineUnconditionalGrowth -- See Note [Inlining criteria] @@ -525,7 +526,7 @@ acceptable inlineConstants t = do {-| Is the cost increase (in terms of evaluation work) of inlining a variable whose RHS is the given term acceptable? -} -costIsAcceptable :: Term name uni fun a -> Bool +costIsAcceptable :: Term name uni fun pat a -> Bool costIsAcceptable = \case Builtin {} -> True Var {} -> True @@ -544,18 +545,19 @@ costIsAcceptable = \case _ -> False -- Inlining a case means redoing the match at each use site Case {} -> False + Match {} -> False Force {} -> False Delay {} -> True -- | Fully apply and beta reduce. fullyApplyAndBetaReduce - :: forall name uni fun a + :: forall name uni fun pat a . InliningConstraints name uni fun => Ann a -- ^ Annotation on the variable to be replaced - -> VarInfo name uni fun (Ann a) - -> [(Ann a, Term name uni fun (Ann a))] - -> InlineM name uni fun a (Maybe (Term name uni fun (Ann a))) + -> VarInfo name uni fun pat (Ann a) + -> [(Ann a, Term name uni fun pat (Ann a))] + -> InlineM name uni fun pat a (Maybe (Term name uni fun pat (Ann a))) fullyApplyAndBetaReduce av info args0 = do rhsBody <- -- Since we would like to fully apply here, we add decorations to @@ -580,10 +582,10 @@ fullyApplyAndBetaReduce av info args0 = do ) <$> liftDupable (let Done rhsBody = info ^. varRhsBody in rhsBody) let go - :: Term name uni fun (Ann a) + :: Term name uni fun pat (Ann a) -> [(name, Ann a)] - -> [(Ann a, Term name uni fun (Ann a))] - -> InlineM name uni fun a (Maybe (Term name uni fun (Ann a))) + -> [(Ann a, Term name uni fun pat (Ann a))] + -> InlineM name uni fun pat a (Maybe (Term name uni fun pat (Ann a))) go acc bs args = case (bs, args) of ([], _) -> pure . Just $ mkIterApp acc args ((param, _annLam) : params, (_annArg, arg) : args') -> do @@ -612,8 +614,8 @@ fullyApplyAndBetaReduce av info args0 = do -- inlining `a`, since inlining is the same as beta reduction. safeToBetaReduce :: name - -> Term name uni fun (Ann a) - -> InlineM name uni fun a Bool + -> Term name uni fun pat (Ann a) + -> InlineM name uni fun pat a Bool safeToBetaReduce a arg = shouldUnconditionallyInline False a arg rhsBody go rhsBody (info ^. varBinders) args0 @@ -621,10 +623,10 @@ fullyApplyAndBetaReduce av info args0 = do 'PlutusIR.Transform.Inline.CallSiteInline.inlineSaturatedApp'. See Note [Inlining and beta reduction of functions]. -} inlineSaturatedApp - :: forall name uni fun a + :: forall name uni fun pat a . InliningConstraints name uni fun - => Term name uni fun (Ann a) - -> InlineM name uni fun a (Term name uni fun (Ann a)) + => Term name uni fun pat (Ann a) + -> InlineM name uni fun pat a (Term name uni fun pat (Ann a)) inlineSaturatedApp t | (Var av name, args) <- UPLC.splitApplication t = gets (lookupVarInfo name) >>= \case @@ -671,12 +673,12 @@ decorations = _1 {-# INLINE decorations #-} -- | Prepend the given decorations -decorateWith :: [Decoration] -> Term name uni fun (Ann a) -> Term name uni fun (Ann a) +decorateWith :: [Decoration] -> Term name uni fun pat (Ann a) -> Term name uni fun pat (Ann a) decorateWith ds = modifyAnn (first (ds ++)) {-# INLINE decorateWith #-} -- | Fold a decorated term into certifier hints. -mkHints :: Term name uni fun (Ann a) -> CertifierHints.Inline +mkHints :: Term name uni fun pat (Ann a) -> CertifierHints.Inline mkHints = go where go t = decorate hints ds @@ -699,6 +701,8 @@ mkHints = go Error {} -> CertifierHints.InlError Constr _ _ args -> CertifierHints.InlConstr (go <$> args) Case _ scrut alts -> CertifierHints.InlCase (go scrut) (go <$> V.toList alts) + Match _ scrut alternatives -> + CertifierHints.InlMatch (go scrut) (go . snd <$> V.toList alternatives) {- Note [Inliner's Certifier Hints] diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/LetFloatOut.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/LetFloatOut.hs index b4cbb7cf0c9..5dc30abfc3e 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/LetFloatOut.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/LetFloatOut.hs @@ -6,7 +6,7 @@ cannot cause any expression to be evaluated more than before. This can unlock further optimizations, such as case-constr and force-delay cancellation. -Specifically, it floats bindings from the following positions: @case@ scrutinee, +Specifically, it floats bindings from the following positions: @case@ or @match@ scrutinee, @force@ body, and the function of @apply@. If we don't care about the order of effects, we can also float bindings from @apply@ @@ -31,19 +31,21 @@ import Control.Lens (transformOf) letFloatOut :: ( PLC.MonadQuote m - , PLC.Rename (Term name uni fun a) + , PLC.Rename (Term name uni fun pat a) ) - => Term name uni fun a - -> OptimizerT name uni fun a m (Term name uni fun a) + => Term name uni fun pat a + -> OptimizerT name uni fun pat a m (Term name uni fun pat a) letFloatOut term = do result <- transformOf termSubterms processTerm <$> PLC.rename term recordOptimization term LetFloatOutStage result pure result -processTerm :: Term name uni fun a -> Term name uni fun a +processTerm :: Term name uni fun pat a -> Term name uni fun pat a processTerm = \case Case ca (Apply aa (LamAbs la x body) rhs) branches -> Apply aa (LamAbs la x (Case ca body branches)) rhs + Match ma (Apply aa (LamAbs la x body) rhs) alternatives -> + Apply aa (LamAbs la x (Match ma body alternatives)) rhs Force fa (Apply aa (LamAbs la x body) rhs) -> Apply aa (LamAbs la x (Force fa body)) rhs Apply aa (Apply aa' (LamAbs la x body) rhs) arg -> diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Optimizer.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Optimizer.hs index f7f60d74ba8..be37a5589de 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Optimizer.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Optimizer.hs @@ -37,53 +37,59 @@ import UntypedPlutusCore.Core.Type (Term) import UntypedPlutusCore.Transform.Certify.Hints qualified as Hints import UntypedPlutusCore.Transform.Certify.Trace qualified as Trace -newtype OptimizerT name uni fun ann m a +newtype OptimizerT name uni fun pat ann m a = OptimizerT - { getOptimizerT :: StateT (Trace.OptimizerTrace name uni fun ann) m a + { getOptimizerT :: StateT (Trace.OptimizerTrace name uni fun pat ann) m a } deriving newtype (Functor, Applicative, Monad, MonadTrans) -instance MonadQuote m => MonadQuote (OptimizerT name uni fun ann m) +instance MonadQuote m => MonadQuote (OptimizerT name uni fun pat ann m) runOptimizerT - :: OptimizerT name uni fun ann m a - -> m (a, Trace.OptimizerTrace name uni fun ann) + :: OptimizerT name uni fun pat ann m a + -> m (a, Trace.OptimizerTrace name uni fun pat ann) runOptimizerT = flip State.runStateT Trace.initOptimizerTrace . getOptimizerT evalOptimizerT - :: Monad m => OptimizerT name uni fun ann m a -> m a + :: Monad m => OptimizerT name uni fun pat ann m a -> m a evalOptimizerT = flip State.evalStateT Trace.initOptimizerTrace . getOptimizerT execOptimizerT - :: Monad m => OptimizerT name uni fun ann m a -> m (Trace.OptimizerTrace name uni fun ann) + :: Monad m + => OptimizerT name uni fun pat ann m a + -> m (Trace.OptimizerTrace name uni fun pat ann) execOptimizerT = flip State.execStateT Trace.initOptimizerTrace . getOptimizerT -type Optimizer name uni fun ann = OptimizerT name uni fun ann Identity +type Optimizer name uni fun pat ann = OptimizerT name uni fun pat ann Identity -runOptimizer :: Optimizer name uni fun ann a -> (a, Trace.OptimizerTrace name uni fun ann) +runOptimizer + :: Optimizer name uni fun pat ann a + -> (a, Trace.OptimizerTrace name uni fun pat ann) runOptimizer = runIdentity . runOptimizerT -evalOptimizer :: Optimizer name uni fun ann a -> a +evalOptimizer :: Optimizer name uni fun pat ann a -> a evalOptimizer = runIdentity . evalOptimizerT -execOptimizer :: Optimizer name uni fun ann a -> Trace.OptimizerTrace name uni fun ann +execOptimizer + :: Optimizer name uni fun pat ann a + -> Trace.OptimizerTrace name uni fun pat ann execOptimizer = runIdentity . execOptimizerT recordOptimization :: Monad m - => Term name uni fun a + => Term name uni fun pat a -> Trace.OptStage - -> Term name uni fun a - -> OptimizerT name uni fun a m () + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m () recordOptimization = recordOptimizationWithHints Hints.NoHints recordOptimizationWithHints :: Monad m => Hints.Hints - -> Term name uni fun a + -> Term name uni fun pat a -> Trace.OptStage - -> Term name uni fun a - -> OptimizerT name uni fun a m () + -> Term name uni fun pat a + -> OptimizerT name uni fun pat a m () recordOptimizationWithHints hints before stage after = let optimization = Trace.Optimization before stage hints after in OptimizerT . State.modify' $ \st -> diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/PolyBuiltin.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/PolyBuiltin.hs index 8eda0a1415a..e7865d3f579 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/PolyBuiltin.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/PolyBuiltin.hs @@ -33,20 +33,20 @@ import Data.Proxy (Proxy (..)) import Data.Traversable (for) polyBuiltin - :: forall m uni fun a + :: forall m uni fun pat a . ( MonadQuote m , Hashable fun , ToBuiltinMeaning uni fun ) => BuiltinSemanticsVariant fun - -> Term Name uni fun a - -> OptimizerT Name uni fun a m (Term Name uni fun a) + -> Term Name uni fun pat a + -> OptimizerT Name uni fun pat a m (Term Name uni fun pat a) polyBuiltin semvar term = do let numForces :: fun -> Int numForces = length . takeWhile (== TypeParam) . builtinArity (Proxy @uni) semvar -- If it is a fully forced polymorphic builtin, return `Just (ann, fun, number of forces)`. - checkFullyForced :: Term Name uni fun a -> Maybe (a, fun, Int) + checkFullyForced :: Term Name uni fun pat a -> Maybe (a, fun, Int) checkFullyForced t = case t' of Builtin _ fun | n >= 1 @@ -83,18 +83,18 @@ polyBuiltin semvar term = do recordOptimization term PolyBuiltinStage result pure result -peelForces :: Term name uni fun a -> (Int, Term name uni fun a) +peelForces :: Term name uni fun pat a -> (Int, Term name uni fun pat a) peelForces = go 0 where go !k (Force _ t) = go (k + 1) t go !k t = (k, t) wrap - :: forall uni fun a + :: forall uni fun pat a . a -> [(fun, (Name, Int))] - -> Term Name uni fun a - -> Term Name uni fun a + -> Term Name uni fun pat a + -> Term Name uni fun pat a wrap ann entries body = let lams = foldr (\(_, (name, _)) -> LamAbs ann name) body entries in F.foldl' @@ -102,6 +102,6 @@ wrap ann entries body = lams entries where - applyForces :: Int -> Term Name uni fun a -> Term Name uni fun a + applyForces :: Int -> Term Name uni fun pat a -> Term Name uni fun pat a applyForces 0 = id applyForces n = applyForces (n - 1) . Force ann diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index a3f9e73f8b5..5600ca39d24 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -23,7 +23,7 @@ module PlutusLedgerApi.Common.Eval ) where import PlutusCore -import PlutusCore.Builtin (CaserBuiltin) +import PlutusCore.Builtin (CaserBuiltin, MatcherBuiltin) import PlutusCore.Data as Plutus import PlutusCore.Default import PlutusCore.Evaluation.Machine.CostModelInterface as Plutus @@ -52,7 +52,13 @@ import NoThunks.Class -- | Errors that can be thrown when evaluating a Plutus script. data EvaluationError = -- | An error from the evaluator itself - CekError !(UPLC.CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) + CekError + !( UPLC.CekEvaluationException + NamedDeBruijn + DefaultUni + DefaultFun + DefaultBuiltinPattern + ) | -- | An error in the pre-evaluation step of converting from de-Bruijn indices DeBruijnError !FreeVariableError | {-| A deserialisation error @@ -109,7 +115,7 @@ mkTermToEvaluate -- ^ the script to evaluate -> [Plutus.Data] -- ^ the arguments that the script's underlying term will be applied to - -> m (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()) + -> m (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) mkTermToEvaluate ll pv script args = do let ScriptNamedDeBruijn (UPLC.Program _ v t) = deserialisedScript script termArgs = fmap (UPLC.mkConstant ()) args @@ -125,13 +131,13 @@ mkTermToEvaluate ll pv script args = do through (liftEither . first DeBruijnError . UPLC.checkScope) appliedT toMachineParameters :: MajorProtocolVersion -> EvaluationContext -> DefaultMachineParameters -toMachineParameters pv (EvaluationContext ll toCaser toSemVar machParsList) = +toMachineParameters pv (EvaluationContext ll toCaser toMatcher toSemVar machParsList) = case lookup (toSemVar pv) machParsList of Nothing -> error $ Prelude.concat ["Internal error: ", show ll, " does not support protocol version ", show pv] - Just machVarPars -> MachineParameters (toCaser pv) machVarPars + Just machVarPars -> MachineParameters (toCaser pv) (toMatcher pv) machVarPars {-| An opaque type that contains all the static parameters that the evaluator needs to evaluate a script. This is so that they can be computed once and cached, rather than being recomputed on every @@ -171,6 +177,12 @@ data EvaluationContext = EvaluationContext is available. FIXME: do we need to test that it fails for older PVs? We can't submit transactions in old PVs, so maybe it doesn't matter. -} + , _evalCtxMatcherBuiltin + :: MajorProtocolVersion + -> MatcherBuiltin DefaultUni DefaultBuiltinPattern + {-^ Specifies how 'match' on built-in values works. Match belongs to the experimental + Plutus Core 1.2 language, which has no ledger protocol activation yet, so all current + ledger evaluation contexts provide an unavailable matcher. -} , _evalCtxToSemVar :: MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun {-^ Specifies how to get a semantics variant for this ledger language given a 'MajorProtocolVersion'. -} @@ -198,13 +210,14 @@ mkDynEvaluationContext :: MonadError CostModelApplyError m => PlutusLedgerLanguage -> (MajorProtocolVersion -> CaserBuiltin DefaultUni) + -> (MajorProtocolVersion -> MatcherBuiltin DefaultUni DefaultBuiltinPattern) -> [BuiltinSemanticsVariant DefaultFun] -> (MajorProtocolVersion -> BuiltinSemanticsVariant DefaultFun) -> Plutus.CostModelParams -> m EvaluationContext -mkDynEvaluationContext ll toCaser semVars toSemVar newCMP = do +mkDynEvaluationContext ll toCaser toMatcher semVars toSemVar newCMP = do machPars <- mkMachineVariantParametersFor semVars newCMP - pure $ EvaluationContext ll toCaser toSemVar machPars + pure $ EvaluationContext ll toCaser toMatcher toSemVar machPars -- FIXME (https://github.com/IntersectMBO/plutus-private/issues/1726): remove this function assertWellFormedCostModelParams @@ -214,12 +227,12 @@ assertWellFormedCostModelParams = void . Plutus.applyCostModelParams Plutus.defa {-| Evaluate a fully-applied term using the CEK machine. Useful for mimicking the behaviour of the on-chain evaluator. -} evaluateTerm - :: UPLC.ExBudgetMode cost DefaultUni DefaultFun + :: UPLC.ExBudgetMode cost DefaultUni DefaultFun DefaultBuiltinPattern -> MajorProtocolVersion -> VerboseMode -> EvaluationContext - -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.CekReport cost NamedDeBruijn DefaultUni DefaultFun + -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> UPLC.CekReport cost NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern evaluateTerm budgetMode pv verbose ectx = UPLC.runCekDeBruijn (toMachineParameters pv ectx) @@ -293,7 +306,7 @@ processLogsAndErrors . (MonadError EvaluationError m, MonadWriter LogOutput m) => PlutusLedgerLanguage -> LogOutput - -> UPLC.CekResult NamedDeBruijn DefaultUni DefaultFun + -> UPLC.CekResult NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern -> m () processLogsAndErrors ll logs res = do tell logs diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs index 7987bec5bd7..321edf8be5e 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs @@ -24,6 +24,7 @@ module PlutusLedgerApi.Common.SerialisedScript import PlutusCore import PlutusCore.Default (defaultUniSize) +import PlutusCore.Version (plcVersion120) import PlutusLedgerApi.Common.Versions import PlutusTx.Code import UntypedPlutusCore qualified as UPLC @@ -146,13 +147,14 @@ serialiseCompiledCode = serialiseUPLC . toNameless . getPlcNoAnn where toNameless - :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun UPLC.DefaultBuiltinPattern () + -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun UPLC.DefaultBuiltinPattern () toNameless = over UPLC.progTerm $ UPLC.termMapNames UPLC.unNameDeBruijn {-| Turns a program's AST (most likely manually constructed) into a binary format that is understood by the network and can be stored on-chain. -} -serialiseUPLC :: UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () -> SerialisedScript +serialiseUPLC + :: UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun UPLC.DefaultBuiltinPattern () -> SerialisedScript serialiseUPLC = -- See Note [Using Flat for serialising/deserialising Script] -- Currently, this is off because the old implementation didn't actually work, so we @@ -161,13 +163,15 @@ serialiseUPLC = {-| Deserialises a 'SerialisedScript' back into an AST. Does *not* do ledger-language-version-specific checks like for allowable builtins. -} -uncheckedDeserialiseUPLC :: SerialisedScript -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () +uncheckedDeserialiseUPLC + :: SerialisedScript -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun UPLC.DefaultBuiltinPattern () uncheckedDeserialiseUPLC = UPLC.unUnrestrictedProgram . unSerialiseViaFlat . deserialise . BSL.fromStrict . fromShort -- | A script with named de-bruijn indices. newtype ScriptNamedDeBruijn - = ScriptNamedDeBruijn (UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ()) + = ScriptNamedDeBruijn + (UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun UPLC.DefaultBuiltinPattern ()) deriving stock (Eq, Show, Generic) deriving anyclass (NFData) @@ -202,7 +206,7 @@ scriptCBORDecoder ll pv = maxBounds = maxBoundsByPV pv maxBoundHeader = mbHeader maxBounds maxBoundConstr = mbConstr maxBounds - flatDecoder = UPLC.decodeProgram checkConstant checkBuiltin checkConstr + flatDecoder = UPLC.decodeProgram checkConstant checkBuiltin checkConstr checkPattern checkConstant (Some (ValueOf uni _)) | defaultUniSize uni <= maxBoundHeader = Nothing @@ -232,9 +236,35 @@ scriptCBORDecoder ll pv = ++ show n ++ " fields is not available in protocol version " ++ show (pretty pv) + + -- Pattern descriptors are part of the PLC language version, just like term constructors. + -- Keep this exhaustive so adding a descriptor requires an explicit compatibility decision. + checkPattern version pat + | patternIntroducedIn pat <= version = Nothing + | otherwise = + Just $ + "built-in pattern " + ++ show pat + ++ " is not available in Plutus Core version " + ++ show (pretty version) + + patternIntroducedIn = \case + DefaultPatternWildcard -> plcVersion120 + DefaultPatternCapture -> plcVersion120 + DefaultPatternInteger {} -> plcVersion120 + DefaultPatternByteString {} -> plcVersion120 + DefaultPatternBool {} -> plcVersion120 + DefaultPatternUnit -> plcVersion120 + DefaultPatternList {} -> plcVersion120 + DefaultPatternPair {} -> plcVersion120 + DefaultPatternDataConstr {} -> plcVersion120 + DefaultPatternDataMap {} -> plcVersion120 + DefaultPatternDataList {} -> plcVersion120 + DefaultPatternDataI {} -> plcVersion120 + DefaultPatternDataB {} -> plcVersion120 in do -- Deserialise using 'FakeNamedDeBruijn' to get the fake names added - (p :: UPLC.Program UPLC.FakeNamedDeBruijn DefaultUni DefaultFun ()) <- + (p :: UPLC.Program UPLC.FakeNamedDeBruijn DefaultUni DefaultFun UPLC.DefaultBuiltinPattern ()) <- decodeViaFlatWith flatDecoder pure $ coerce p diff --git a/plutus-ledger-api/src/PlutusLedgerApi/MachineParameters.hs b/plutus-ledger-api/src/PlutusLedgerApi/MachineParameters.hs index b4f5e711766..ac84c6cf029 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/MachineParameters.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/MachineParameters.hs @@ -2,7 +2,11 @@ module PlutusLedgerApi.MachineParameters where import PlutusLedgerApi.Common -import PlutusCore.Builtin (CaserBuiltin (..), caseBuiltin, unavailableCaserBuiltin) +import PlutusCore.Builtin + ( availableCaserBuiltin + , unavailableCaserBuiltin + , unavailableMatcherBuiltin + ) import PlutusCore.Default (BuiltinSemanticsVariant (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (cekCostModelForVariant) import PlutusCore.Evaluation.Machine.MachineParameters @@ -19,8 +23,9 @@ machineParametersFor ledgerLang majorPV = MachineParameters ( if majorPV < vanRossemPV then unavailableCaserBuiltin $ getMajorProtocolVersion majorPV - else CaserBuiltin caseBuiltin + else availableCaserBuiltin ) + (unavailableMatcherBuiltin $ getMajorProtocolVersion majorPV) (mkMachineVariantParameters builtinSemVar $ cekCostModelForVariant builtinSemVar) where builtinSemVar = diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs index e27f0dc6b48..254144e47b8 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/EvaluationContext.hs @@ -14,7 +14,11 @@ module PlutusLedgerApi.V1.EvaluationContext import PlutusLedgerApi.Common import PlutusLedgerApi.V1.ParamName as V1 -import PlutusCore.Builtin (CaserBuiltin (..), caseBuiltin, unavailableCaserBuiltin) +import PlutusCore.Builtin + ( availableCaserBuiltin + , unavailableCaserBuiltin + , unavailableMatcherBuiltin + ) import PlutusCore.Default ( BuiltinSemanticsVariant ( DefaultFunSemanticsVariantA @@ -51,8 +55,9 @@ mkEvaluationContext = ( \pv -> if pv < vanRossemPV then unavailableCaserBuiltin $ getMajorProtocolVersion pv - else CaserBuiltin caseBuiltin + else availableCaserBuiltin ) + (unavailableMatcherBuiltin . getMajorProtocolVersion) [DefaultFunSemanticsVariantA, DefaultFunSemanticsVariantB, DefaultFunSemanticsVariantD] -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. ( \pv -> diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs index 1628c6ce088..abe715ece7d 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/EvaluationContext.hs @@ -14,7 +14,11 @@ module PlutusLedgerApi.V2.EvaluationContext import PlutusLedgerApi.Common import PlutusLedgerApi.V2.ParamName as V2 -import PlutusCore.Builtin (CaserBuiltin (..), caseBuiltin, unavailableCaserBuiltin) +import PlutusCore.Builtin + ( availableCaserBuiltin + , unavailableCaserBuiltin + , unavailableMatcherBuiltin + ) import PlutusCore.Default ( BuiltinSemanticsVariant ( DefaultFunSemanticsVariantA @@ -51,8 +55,9 @@ mkEvaluationContext = ( \pv -> if pv < vanRossemPV then unavailableCaserBuiltin $ getMajorProtocolVersion pv - else CaserBuiltin caseBuiltin + else availableCaserBuiltin ) + (unavailableMatcherBuiltin . getMajorProtocolVersion) [DefaultFunSemanticsVariantA, DefaultFunSemanticsVariantB, DefaultFunSemanticsVariantD] -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. ( \pv -> diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs index c6c4a3e6054..6e750fca5d9 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/EvaluationContext.hs @@ -12,7 +12,11 @@ module PlutusLedgerApi.V3.EvaluationContext import PlutusLedgerApi.Common import PlutusLedgerApi.V3.ParamName as V3 -import PlutusCore.Builtin (CaserBuiltin (..), caseBuiltin, unavailableCaserBuiltin) +import PlutusCore.Builtin + ( availableCaserBuiltin + , unavailableCaserBuiltin + , unavailableMatcherBuiltin + ) import PlutusCore.Default ( BuiltinSemanticsVariant ( DefaultFunSemanticsVariantC @@ -48,8 +52,9 @@ mkEvaluationContext = ( \pv -> if pv < vanRossemPV then unavailableCaserBuiltin $ getMajorProtocolVersion pv - else CaserBuiltin caseBuiltin + else availableCaserBuiltin ) + (unavailableMatcherBuiltin . getMajorProtocolVersion) [DefaultFunSemanticsVariantC, DefaultFunSemanticsVariantE] -- See Note [Mapping of protocol versions and ledger languages to semantics variants]. ( \pv -> diff --git a/plutus-tx/src/PlutusTx/Code.hs b/plutus-tx/src/PlutusTx/Code.hs index d0fea033bf1..8b960c6b43e 100644 --- a/plutus-tx/src/PlutusTx/Code.hs +++ b/plutus-tx/src/PlutusTx/Code.hs @@ -34,7 +34,7 @@ import Prelude as Haskell -- this 'CompiledCodeIn'. It could be okay to give it a representational role, since -- we compile newtypes the same as their underlying types, but people probably just -- shouldn't coerce the final parameter regardless, so we play it safe with a nominal role. -type role CompiledCodeIn representational representational nominal +type role CompiledCodeIn representational representational representational nominal -- NOTE: any changes to this type must be paralleled by changes -- in the plugin code that generates values of this type. That is @@ -46,7 +46,7 @@ hence the type of the compiled code. Note: the compiled PLC program does *not* have normalized types, if you want to put it on the chain you must normalize the types first. -} -data CompiledCodeIn uni fun a +data CompiledCodeIn uni fun pat a = SerializedCode BS.ByteString -- ^ Serialized UPLC program of type 'UPLC.Program NamedDeBruijn uni fun SrcSpans'. @@ -55,7 +55,7 @@ data CompiledCodeIn uni fun a CoverageIndex | -- Metadata used for program coverage. DeserializedCode - (UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans) + (UPLC.Program UPLC.NamedDeBruijn uni fun pat SrcSpans) -- ^ Deserialized UPLC program (Maybe (PIR.Program PLC.TyName PLC.Name uni fun SrcSpans)) -- ^ Deserialized PIR program, if available @@ -63,20 +63,21 @@ data CompiledCodeIn uni fun a -- ^ Metadata used for program coverage. -- | 'CompiledCodeIn' instantiated with default built-in types and functions. -type CompiledCode = CompiledCodeIn PLC.DefaultUni PLC.DefaultFun +type CompiledCode = CompiledCodeIn PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern -- | Apply a compiled function to a compiled argument. Will fail if the versions don't match. applyCode :: ( PLC.Closed uni , uni `PLC.Everywhere` Flat + , Flat pat , Flat fun , Pretty fun , PLC.Everywhere uni PrettyConst , PrettyBy RenderContext (PLC.SomeTypeIn uni) ) - => CompiledCodeIn uni fun (a -> b) - -> CompiledCodeIn uni fun a - -> Either String (CompiledCodeIn uni fun b) + => CompiledCodeIn uni fun pat (a -> b) + -> CompiledCodeIn uni fun pat a + -> Either String (CompiledCodeIn uni fun pat b) applyCode fun arg = do let uplc = unsafeFromRight $ UPLC.applyProgram (getPlc fun) (getPlc arg) -- Probably this could be done with more appropriate combinators, but the @@ -107,20 +108,23 @@ should only be used in non-production code. -} unsafeApplyCode :: ( PLC.Closed uni , uni `PLC.Everywhere` Flat + , Flat pat , Flat fun , Pretty fun , PLC.Everywhere uni PrettyConst , PrettyBy RenderContext (PLC.SomeTypeIn uni) ) - => CompiledCodeIn uni fun (a -> b) -> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b + => CompiledCodeIn uni fun pat (a -> b) + -> CompiledCodeIn uni fun pat a + -> CompiledCodeIn uni fun pat b unsafeApplyCode fun arg = case applyCode fun arg of Right c -> c Left err -> error err -- | The size of a 'CompiledCodeIn' as measured in AST nodes. countAstNodes - :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a + :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat pat, Flat fun) + => CompiledCodeIn uni fun pat a -> Integer countAstNodes = UPLC.unAstSize . UPLC.programAstSize . getPlc @@ -136,8 +140,9 @@ instance Show ImpossibleDeserialisationFailure where -- | Get the actual Plutus Core program out of a 'CompiledCodeIn'. getPlc - :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans + :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat pat, Flat fun) + => CompiledCodeIn uni fun pat a + -> UPLC.Program UPLC.NamedDeBruijn uni fun pat SrcSpans getPlc wrapper = case wrapper of SerializedCode plc _ _ -> case unflat (BSL.fromStrict plc) of Left e -> throw $ ImpossibleDeserialisationFailure e @@ -145,14 +150,15 @@ getPlc wrapper = case wrapper of DeserializedCode plc _ _ -> plc getPlcNoAnn - :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun () + :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat pat, Flat fun) + => CompiledCodeIn uni fun pat a + -> UPLC.Program UPLC.NamedDeBruijn uni fun pat () getPlcNoAnn = void . getPlc -- | Get the Plutus IR program, if there is one, out of a 'CompiledCodeIn'. getPir :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun SrcSpans) + => CompiledCodeIn uni fun pat a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun SrcSpans) getPir wrapper = case wrapper of SerializedCode _ pir _ -> case pir of Just bs -> case unflat (BSL.fromStrict bs) of @@ -163,10 +169,10 @@ getPir wrapper = case wrapper of getPirNoAnn :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun ()) + => CompiledCodeIn uni fun pat a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun ()) getPirNoAnn = fmap void . getPir -getCovIdx :: CompiledCodeIn uni fun a -> CoverageIndex +getCovIdx :: CompiledCodeIn uni fun pat a -> CoverageIndex getCovIdx wrapper = case wrapper of SerializedCode _ _ idx -> idx DeserializedCode _ _ idx -> idx diff --git a/plutus-tx/src/PlutusTx/Eval.hs b/plutus-tx/src/PlutusTx/Eval.hs index 002906a1313..a8576efd754 100644 --- a/plutus-tx/src/PlutusTx/Eval.hs +++ b/plutus-tx/src/PlutusTx/Eval.hs @@ -21,7 +21,7 @@ import PlutusCore.Evaluation.Machine.MachineParameters.Default (DefaultMachinePa import PlutusCore.Pretty import PlutusTx.Code (CompiledCode, getPlcNoAnn) import Prettyprinter (dot, indent, plural, vsep, (<+>)) -import UntypedPlutusCore (DefaultFun, DefaultUni, Program (..)) +import UntypedPlutusCore (DefaultBuiltinPattern, DefaultFun, DefaultUni, Program (..)) import UntypedPlutusCore.Evaluation.Machine.Cek ( CekEvaluationException , CekReport (..) @@ -35,8 +35,8 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.Internal (NTerm, runCekDeBruijn) data EvalResult = EvalResult { evalResult :: Either - (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) - (NTerm DefaultUni DefaultFun ()) + (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern) + (NTerm DefaultUni DefaultFun DefaultBuiltinPattern ()) , evalResultBudget :: ExBudget , evalResultTraces :: [Text] } diff --git a/plutus-tx/src/PlutusTx/Lift.hs b/plutus-tx/src/PlutusTx/Lift.hs index becfe732f87..3db73f29baa 100644 --- a/plutus-tx/src/PlutusTx/Lift.hs +++ b/plutus-tx/src/PlutusTx/Lift.hs @@ -62,6 +62,7 @@ import Control.Monad.Reader (runReaderT) import Data.Default.Class import Data.Hashable import Data.Proxy +import Data.Typeable (Typeable) -- We do not use qualified import because the whole module contains off-chain code import Prelude as Haskell @@ -69,10 +70,11 @@ import Prelude as Haskell {-| Get a Plutus Core term corresponding to the given value. Allows configuring PIR and UPLC optimization options. -} safeLiftWith - :: forall a uni fun m + :: forall a uni fun pat m . ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , MonadError (PIR.Error uni fun (Provenance ())) m , MonadQuote m , PLC.Typecheckable uni fun @@ -83,6 +85,8 @@ safeLiftWith , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => (PIR.CompilationOpts () -> PIR.CompilationOpts ()) -- ^ Modifier of PIR compilation options @@ -90,7 +94,7 @@ safeLiftWith -- ^ Modifier of UPLC compilation options -> PLC.Version -> a - -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) + -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun pat ()) safeLiftWith f g v x = do pir <- liftQuote $ runDefT () $ Lift.lift x tcConfig <- modifyError (PLCError . PLC.TypeErrorE) $ PLC.getDefTypeCheckConfig $ Original () @@ -120,10 +124,11 @@ safeLiftWith f g v x = do {-| Get a Plutus Core term corresponding to the given value, applying default PIR/UPLC optimizations. -} safeLift - :: forall a uni fun m + :: forall a uni fun pat m . ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , MonadError (PIR.Error uni fun (Provenance ())) m , MonadQuote m , PLC.Typecheckable uni fun @@ -134,19 +139,22 @@ safeLift , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => PLC.Version -> a - -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) + -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun pat ()) safeLift = safeLiftWith id id {-| Like `safeLift` but does not apply PIR/UPLC optimizations. Use this option where lifting speed is more important than optimal code. -} safeLiftUnopt - :: forall a uni fun m + :: forall a uni fun pat m . ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , MonadError (PIR.Error uni fun (Provenance ())) m , MonadQuote m , PLC.Typecheckable uni fun @@ -157,10 +165,12 @@ safeLiftUnopt , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => PLC.Version -> a - -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) + -> m (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun pat ()) safeLiftUnopt = safeLiftWith (set coMaxSimplifierIterations 0) @@ -175,6 +185,7 @@ safeLiftProgram :: ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , MonadError (PIR.Error uni fun (Provenance ())) m , MonadQuote m , PLC.Typecheckable uni fun @@ -185,10 +196,12 @@ safeLiftProgram , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => PLC.Version -> a - -> m (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) + -> m (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun pat ()) safeLiftProgram v x = bimap (PIR.Program () v) (UPLC.Program () v) <$> safeLift v x {-| Like `safeLiftProgram` but does not apply PIR/UPLC optimizations. Use this option @@ -197,6 +210,7 @@ safeLiftProgramUnopt :: ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , MonadError (PIR.Error uni fun (Provenance ())) m , MonadQuote m , PLC.Typecheckable uni fun @@ -207,16 +221,19 @@ safeLiftProgramUnopt , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => PLC.Version -> a - -> m (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) + -> m (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun pat ()) safeLiftProgramUnopt v x = bimap (PIR.Program () v) (UPLC.Program () v) <$> safeLiftUnopt v x safeLiftCode :: ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , MonadError (PIR.Error uni fun (Provenance ())) m , MonadQuote m , PLC.Typecheckable uni fun @@ -227,8 +244,10 @@ safeLiftCode , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) - => PLC.Version -> a -> m (CompiledCodeIn uni fun a) + => PLC.Version -> a -> m (CompiledCodeIn uni fun pat a) safeLiftCode v = fmap ( \(pir, uplc) -> @@ -242,6 +261,7 @@ safeLiftCodeUnopt :: ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , MonadError (PIR.Error uni fun (Provenance ())) m , MonadQuote m , PLC.Typecheckable uni fun @@ -252,8 +272,10 @@ safeLiftCodeUnopt , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) - => PLC.Version -> a -> m (CompiledCodeIn uni fun a) + => PLC.Version -> a -> m (CompiledCodeIn uni fun pat a) safeLiftCodeUnopt v = fmap ( \(pir, uplc) -> @@ -279,15 +301,18 @@ lift , PLC.Typecheckable uni fun , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , PLC.CaseBuiltin uni , Default (PLC.CostingPart uni fun) , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => PLC.Version -> a - -> (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) + -> (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun pat ()) lift v a = unsafely $ safeLift v a {-| Like `lift` but does not apply PIR/UPLC optimizations. Use this option @@ -298,15 +323,18 @@ liftUnopt , PLC.Typecheckable uni fun , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , PLC.CaseBuiltin uni , Default (PLC.CostingPart uni fun) , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => PLC.Version -> a - -> (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun ()) + -> (PIR.Term PLC.TyName PLC.Name uni fun (), UPLC.Term UPLC.NamedDeBruijn uni fun pat ()) liftUnopt v a = unsafely $ safeLiftUnopt v a -- | Get a Plutus Core program corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names. @@ -316,15 +344,18 @@ liftProgram , PLC.Typecheckable uni fun , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , PLC.CaseBuiltin uni , Default (PLC.CostingPart uni fun) , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => PLC.Version -> a - -> (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) + -> (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun pat ()) liftProgram v x = unsafely $ safeLiftProgram v x {-| Like `liftProgram` but does not apply PIR/UPLC optimizations. Use this option @@ -335,15 +366,18 @@ liftProgramUnopt , PLC.Typecheckable uni fun , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , PLC.CaseBuiltin uni , Default (PLC.CostingPart uni fun) , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => PLC.Version -> a - -> (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun ()) + -> (PIR.Program PLC.TyName PLC.Name uni fun (), UPLC.Program UPLC.NamedDeBruijn uni fun pat ()) liftProgramUnopt v x = unsafely $ safeLiftProgram v x -- | Get a Plutus Core program in the default universe with the default version, corresponding to the given value, throwing any errors that occur as exceptions and ignoring fresh names. @@ -351,7 +385,12 @@ liftProgramDef :: Lift.Lift PLC.DefaultUni a => a -> ( PIR.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () - , UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + , UPLC.Program + UPLC.NamedDeBruijn + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () ) liftProgramDef = liftProgram PLC.latestVersion @@ -361,7 +400,12 @@ liftProgramDefUnopt :: Lift.Lift PLC.DefaultUni a => a -> ( PIR.Program PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () - , UPLC.Program UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + , UPLC.Program + UPLC.NamedDeBruijn + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () ) liftProgramDefUnopt = liftProgramUnopt PLC.latestVersion @@ -370,6 +414,7 @@ liftCode :: ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , ThrowableBuiltins uni fun , PLC.Typecheckable uni fun , PLC.CaseBuiltin uni @@ -377,8 +422,10 @@ liftCode , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) - => PLC.Version -> a -> CompiledCodeIn uni fun a + => PLC.Version -> a -> CompiledCodeIn uni fun pat a liftCode v x = unsafely $ safeLiftCode v x {-| Like `liftCode` but does not apply PIR/UPLC optimizations. Use this option @@ -387,6 +434,7 @@ liftCodeUnopt :: ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , ThrowableBuiltins uni fun , PLC.Typecheckable uni fun , PLC.CaseBuiltin uni @@ -394,8 +442,10 @@ liftCodeUnopt , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) - => PLC.Version -> a -> CompiledCodeIn uni fun a + => PLC.Version -> a -> CompiledCodeIn uni fun pat a liftCodeUnopt v x = unsafely $ safeLiftCodeUnopt v x -- | Get a Plutus Core program with the default version, corresponding to the given value as a 'CompiledCodeIn', throwing any errors that occur as exceptions and ignoring fresh names. @@ -403,6 +453,7 @@ liftCodeDef :: ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , ThrowableBuiltins uni fun , PLC.Typecheckable uni fun , PLC.CaseBuiltin uni @@ -410,8 +461,10 @@ liftCodeDef , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) - => a -> CompiledCodeIn uni fun a + => a -> CompiledCodeIn uni fun pat a liftCodeDef = liftCode PLC.latestVersion {-| Like `liftCodeDef` but does not apply PIR/UPLC optimizations. Use this option @@ -420,6 +473,7 @@ liftCodeDefUnopt :: ( Lift.Lift uni a , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , ThrowableBuiltins uni fun , PLC.Typecheckable uni fun , PLC.CaseBuiltin uni @@ -427,8 +481,10 @@ liftCodeDefUnopt , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) - => a -> CompiledCodeIn uni fun a + => a -> CompiledCodeIn uni fun pat a liftCodeDefUnopt = liftCodeUnopt PLC.latestVersion {- Note [Checking the type of a term with Typeable] @@ -485,12 +541,13 @@ typeCheckAgainst p (PLC.Program _ v plcTerm) = do -- | Try to interpret a PLC program as a 'CompiledCodeIn' of the given type. Returns successfully iff the program has the right type. typeCode - :: forall a uni fun m + :: forall a uni fun pat m . ( Lift.Typeable uni a , MonadError (PIR.Error uni fun (Provenance ())) m , MonadQuote m , PLC.GEq uni , PLC.Everywhere uni Eq + , Eq pat , PLC.Typecheckable uni fun , PLC.CaseBuiltin uni , PrettyUni uni @@ -499,10 +556,12 @@ typeCode , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) , Hashable fun + , Hashable pat + , Typeable pat ) => Proxy a -> PLC.Program PLC.TyName PLC.Name uni fun () - -> m (CompiledCodeIn uni fun a) + -> m (CompiledCodeIn uni fun pat a) typeCode p prog = do _ <- typeCheckAgainst p prog compiled <- From 38da81e8ee854518708e5faf852aee510d0bd615 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Wed, 15 Jul 2026 21:05:46 -0500 Subject: [PATCH 2/4] test: add builtin matching coverage and benchmarks --- .../casing/src/PlutusBenchmark/Casing.hs | 4 +- .../common/PlutusBenchmark/Common.hs | 38 +- plutus-benchmark/matching/bench/Bench.hs | 133 +++ .../matching/src/PlutusBenchmark/Matching.hs | 417 ++++++++++ plutus-benchmark/plutus-benchmark.cabal | 28 + plutus-core/plutus-core.cabal | 1 + .../PlutusCore/Generators/NEAT/Spec.hs | 6 +- plutus-core/testlib/PlutusCore/Test.hs | 96 ++- plutus-core/testlib/PlutusIR/Test.hs | 10 +- .../Generators/Hedgehog/AST.hs | 13 +- .../UntypedPlutusCore/Test/DeBruijn/Bad.hs | 41 +- .../UntypedPlutusCore/Test/DeBruijn/Good.hs | 10 +- .../Machines/NumberOfStepCounters.golden | 2 +- .../Parser/Golden/bracket-mismatch.golden | 2 +- .../test/Parser/Golden/invalid-keyword.golden | 2 +- .../Golden/missing-closing-paren.golden | 2 +- plutus-core/untyped-plutus-core/test/Spec.hs | 2 + .../testlib/Analysis/Lib.hs | 14 +- .../testlib/Analysis/Spec.hs | 12 +- .../testlib/DeBruijn/Scope.hs | 2 +- .../testlib/DeBruijn/UnDeBruijnify.hs | 2 +- .../testlib/Evaluation/Builtins/Common.hs | 30 +- .../testlib/Evaluation/Builtins/Conversion.hs | 14 +- .../testlib/Evaluation/Builtins/Definition.hs | 2 +- .../testlib/Evaluation/Builtins/MakeRead.hs | 4 +- .../testlib/Evaluation/Debug.hs | 25 +- .../testlib/Evaluation/FreeVars.hs | 6 +- .../testlib/Evaluation/Golden.hs | 10 +- .../testlib/Evaluation/Helpers.hs | 11 +- .../testlib/Evaluation/Machines.hs | 31 +- .../testlib/Evaluation/Patterns.hs | 770 ++++++++++++++++++ .../untyped-plutus-core/testlib/Flat/Spec.hs | 250 +++++- .../testlib/Generators/Spec.hs | 98 ++- .../testlib/Scoping/Spec.hs | 2 +- .../testlib/Transform/CaseOfCase/Spec.hs | 23 +- .../Transform/EvaluateBuiltins/Spec.hs | 27 +- .../testlib/Transform/Inline/Spec.hs | 29 +- .../testlib/Transform/Lib.hs | 4 +- .../testlib/Transform/Simplify/Lib.hs | 30 +- .../testlib/Transform/Simplify/Spec.hs | 99 +-- plutus-tx/testlib/PlutusTx/Test/Golden.hs | 24 +- plutus-tx/testlib/PlutusTx/Test/Orphans.hs | 6 +- plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs | 22 +- plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs | 64 +- .../testlib/PlutusTx/Test/Util/Compiled.hs | 20 +- 45 files changed, 2161 insertions(+), 277 deletions(-) create mode 100644 plutus-benchmark/matching/bench/Bench.hs create mode 100644 plutus-benchmark/matching/src/PlutusBenchmark/Matching.hs create mode 100644 plutus-core/untyped-plutus-core/testlib/Evaluation/Patterns.hs diff --git a/plutus-benchmark/casing/src/PlutusBenchmark/Casing.hs b/plutus-benchmark/casing/src/PlutusBenchmark/Casing.hs index e1ed7e1f88b..ee4ec47b907 100644 --- a/plutus-benchmark/casing/src/PlutusBenchmark/Casing.hs +++ b/plutus-benchmark/casing/src/PlutusBenchmark/Casing.hs @@ -14,8 +14,8 @@ import PlutusCore.MkPlc import UntypedPlutusCore qualified as UPLC debruijnTermUnsafe - :: UPLC.Term UPLC.Name uni fun ann - -> UPLC.Term UPLC.NamedDeBruijn uni fun ann + :: UPLC.Term UPLC.Name uni fun pat ann + -> UPLC.Term UPLC.NamedDeBruijn uni fun pat ann debruijnTermUnsafe = fromRight (Prelude.error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError diff --git a/plutus-benchmark/common/PlutusBenchmark/Common.hs b/plutus-benchmark/common/PlutusBenchmark/Common.hs index 26b3369b960..e1f978924e7 100644 --- a/plutus-benchmark/common/PlutusBenchmark/Common.hs +++ b/plutus-benchmark/common/PlutusBenchmark/Common.hs @@ -85,7 +85,9 @@ getConfig limit = do } -- | Evaluate a script and return the CPU and memory costs (according to the cost model) -getCostsCek :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () -> (Integer, Integer) +getCostsCek + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> (Integer, Integer) getCostsCek (UPLC.Program _ _ prog) = case Cek.runCekDeBruijn PLC.defaultCekParametersForTesting Cek.tallying Cek.noEmitter prog of Cek.CekReport _res (Cek.TallyingSt _ budget) _logs -> @@ -107,7 +109,8 @@ mkEvalCtx ll semvar = let errOrCtx = LedgerApi.mkDynEvaluationContext ll - (\_ -> PLC.CaserBuiltin PLC.caseBuiltin) + (\_ -> PLC.availableCaserBuiltin) + (PLC.unavailableMatcherBuiltin . LedgerApi.getMajorProtocolVersion) [semvar] (const semvar) p @@ -124,10 +127,26 @@ mkMostRecentEvalCtx = mkEvalCtx maxBound maxBound -- | Evaluate a term as it would be evaluated using the on-chain evaluator. evaluateCekLikeInProd :: LedgerApi.EvaluationContext - -> UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + -> UPLC.Term + PLC.NamedDeBruijn + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () -> Either - (UPLC.CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) - (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) + ( UPLC.CekEvaluationException + UPLC.NamedDeBruijn + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + ) + ( UPLC.Term + UPLC.NamedDeBruijn + UPLC.DefaultUni + UPLC.DefaultFun + PLC.DefaultBuiltinPattern + () + ) evaluateCekLikeInProd evalCtx term = let -- The validation benchmarks were all created from PlutusV1 scripts @@ -140,7 +159,12 @@ evaluateCekLikeInProd evalCtx term = Useful for benchmarking. -} evaluateCekForBench :: LedgerApi.EvaluationContext - -> UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + -> UPLC.Term + PLC.NamedDeBruijn + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () -> () evaluateCekForBench evalCtx = either (error . show) (\_ -> ()) . evaluateCekLikeInProd evalCtx @@ -187,7 +211,7 @@ protocol parameters. -} printSizeStatistics :: Handle -> TestSize - -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () + -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () -> IO () printSizeStatistics h n script = do let serialised = Flat.flat (UPLC.UnrestrictedProgram $ toAnonDeBruijnProg script) diff --git a/plutus-benchmark/matching/bench/Bench.hs b/plutus-benchmark/matching/bench/Bench.hs new file mode 100644 index 00000000000..2e078dada9e --- /dev/null +++ b/plutus-benchmark/matching/bench/Bench.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Benchmarks for matching patterns against builtin values. +module Main (main) where + +import Criterion.Main + +import PlutusBenchmark.Common (Term, getConfig, mkMostRecentEvalCtx) +import PlutusCore.Builtin qualified as PLC +import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..), ExRestrictingBudget (..)) +import PlutusCore.Evaluation.Machine.MachineParameters (MachineParameters (..)) +import PlutusLedgerApi.Common (EvaluationContext) +import PlutusLedgerApi.Common qualified as LedgerApi +import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek + +import PlutusBenchmark.Matching qualified as Matching + +import Control.DeepSeq (force) +import Control.Exception +import Data.Functor + +benchmarks :: EvaluationContext -> [Benchmark] +benchmarks ctx = + [ bgroup + "matching" + [ mkMatchBMs "wildcard" Matching.matchingWildcard + , mkMatchBMs "integer" Matching.matchingInteger + , mkMatchBMs "exact list" Matching.matchingExactList + , mkMatchBMs "capture list" Matching.matchingCaptureList + , mkMatchBMs "alternatives" Matching.matchingAlternatives + , bgroup + "Data.Constr comparison" + [ bgroup ("width " <> show width) $ + let (directUnConstr, checkedUnConstr, wildcardMatch, captureMatch) = + Matching.dataConstrMatchComparison width + in [ bench "direct UnConstrData" $ benchTermCekWithMatch ctx directUnConstr + , bench "checked ChooseData + UnConstrData" $ + benchTermCekWithMatch ctx checkedUnConstr + , bench "Match wildcards" $ benchTermCekWithMatch ctx wildcardMatch + , bench "Match captures" $ benchTermCekWithMatch ctx captureMatch + ] + | width <- [0, 1, 3, 16, 128] + ] + , bgroup + "fixed-point exhaustion" + [ mkExhaustionBM "exact list/1200" $ Matching.matchingFixpointExactList 1200 + , mkExhaustionBM "late list mismatch/1200" $ + Matching.matchingFixpointLateListMismatch 1200 + , mkExhaustionBM "abandoned captures/700" $ + Matching.matchingFixpointAbandonedCaptures 700 + , mkExhaustionBM "short list arity/1200" $ + Matching.matchingFixpointListArityMismatch 1200 (-1) + , mkExhaustionBM "long list arity/1200" $ + Matching.matchingFixpointListArityMismatch 1200 1 + , mkExhaustionBM "capture list/700" $ Matching.matchingFixpointCaptureList 700 + , mkExhaustionBM "alternatives/1000" $ Matching.matchingFixpointAlternatives 1000 + , mkExhaustionBM "wide alternatives/16x64" $ + Matching.matchingFixpointWideAlternatives 16 64 + , mkExhaustionBM "nested Data/1000" $ Matching.matchingFixpointNestedData 1000 + , mkExhaustionBM "nested Data.Constr/1000" $ + Matching.matchingFixpointNestedDataConstr 1000 + , mkExhaustionBM "empty Data.Constr" Matching.matchingFixpointEmptyDataConstr + , mkExhaustionBM "small integer" Matching.matchingFixpointSmallInteger + , mkExhaustionBM "small bytestring" Matching.matchingFixpointSmallByteString + , mkExhaustionBM "wide Data.Constr/1200" $ + Matching.matchingFixpointWideDataConstr 1200 + , mkExhaustionBM "max Int64 integer" Matching.matchingFixpointMaxInteger + , mkExhaustionBM "large bytestring/1000 words" $ + Matching.matchingFixpointLargeByteString 1000 + , mkExhaustionBM "max Word64 Data tag" Matching.matchingFixpointMaxDataTag + ] + ] + ] + where + mkMatchBMs name f = + bgroup name $ + [200, 400 .. 1200] <&> \n -> + bench (show n) $ benchTermCekWithMatch ctx (f n) + mkExhaustionBM name term = + bench name $ benchTermCekWithMatchExhaustion ctx term + +{-| Benchmark an experimental 'UPLC.Match' term using the production CEK and the same +machine variant/cost model as 'benchTermCek', but with the 'DefaultUni' matcher enabled +for this invocation only. Ledger evaluation contexts deliberately keep matching disabled +until PLC 1.2 receives a ledger activation. -} +benchTermCekWithMatch :: EvaluationContext -> Term -> Benchmarkable +benchTermCekWithMatch evalCtx term = + let !term' = force term + in whnf runMatch term' + where + runMatch = + either (error . show) (const ()) + . Cek.cekResultToEither + . Cek._cekReportResult + . Cek.runCekDeBruijn matchParameters Cek.restrictingEnormous Cek.noEmitter + matchParameters = + case LedgerApi.toMachineParameters benchmarkProtocolVersion evalCtx of + MachineParameters caser _matcher variantParameters -> + MachineParameters caser PLC.availableMatcherBuiltin variantParameters + -- Keep this aligned with 'PlutusBenchmark.Common.evaluateCekLikeInProd'. + benchmarkProtocolVersion = LedgerApi.ledgerLanguageIntroducedIn LedgerApi.PlutusV1 + +{-| Benchmark recursive experimental matches that are expected to consume a ledger-scale budget. +The result is checked specifically for budget exhaustion so a malformed benchmark or unrelated CEK +failure cannot be mistaken for a fast successful run. -} +benchTermCekWithMatchExhaustion :: EvaluationContext -> Term -> Benchmarkable +benchTermCekWithMatchExhaustion evalCtx term = + let !term' = force term + in whnf runMatchToExhaustion term' + where + runMatchToExhaustion term' = + case Cek.cekResultToEither . Cek._cekReportResult $ + Cek.runCekDeBruijn + matchParameters + (Cek.restricting nearMaximumCpuBudget) + Cek.noEmitter + term' of + Left (Cek.ErrorWithCause (Cek.OperationalError (Cek.CekOutOfExError _)) _) -> () + result -> error $ "fixed-point Match did not exhaust its budget: " <> show result + matchParameters = + case LedgerApi.toMachineParameters benchmarkProtocolVersion evalCtx of + MachineParameters caser _matcher variantParameters -> + MachineParameters caser PLC.availableMatcherBuiltin variantParameters + -- Keep memory nonbinding to measure the worst latency at the current ledger CPU ceiling. + nearMaximumCpuBudget = ExRestrictingBudget $ ExBudget 10000000000 1000000000 + benchmarkProtocolVersion = LedgerApi.ledgerLanguageIntroducedIn LedgerApi.PlutusV1 + +main :: IO () +main = do + -- Run each benchmark for at least 15 seconds. Change this with -L or --timeout. + config <- getConfig 15.0 + evalCtx <- evaluate mkMostRecentEvalCtx + defaultMainWith config $ benchmarks evalCtx diff --git a/plutus-benchmark/matching/src/PlutusBenchmark/Matching.hs b/plutus-benchmark/matching/src/PlutusBenchmark/Matching.hs new file mode 100644 index 00000000000..8615a8afa0d --- /dev/null +++ b/plutus-benchmark/matching/src/PlutusBenchmark/Matching.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module PlutusBenchmark.Matching where + +import Control.Monad (forM, replicateM) +import Control.Monad.Except +import Data.ByteString qualified as BS +import Data.Either +import Data.Int (Int64) +import Data.List (foldl') +import Data.Vector qualified as V +import Data.Word (Word64) +import PlutusBenchmark.Common (Term) +import PlutusCore (DefaultUni, freshName, runQuote) +import PlutusCore qualified as PLC +import PlutusCore.Data qualified as PLCData +import PlutusCore.Default + ( DefaultBuiltinPattern (..) + , DefaultFun + ) +import PlutusCore.MkPlc +import PlutusCore.Name.Unique (Name (..), Unique (..)) +import UntypedPlutusCore qualified as UPLC + +debruijnTermUnsafe + :: UPLC.Term UPLC.Name uni fun pat ann + -> UPLC.Term UPLC.NamedDeBruijn uni fun pat ann +debruijnTermUnsafe = + fromRight (Prelude.error "debruijnTermUnsafe") + . runExcept @UPLC.FreeVariableError + . UPLC.deBruijnTerm + +-- | Repeated minimal matches. This isolates the fixed fused Match/selection overhead. +matchingWildcard :: Integer -> Term +matchingWildcard i = + foldr + ( \_ handler -> + UPLC.Match () (mkConstant @Integer () 0) $ + V.singleton (DefaultPatternWildcard, handler) + ) + (mkConstant @Integer () 0) + [1 .. i] + +-- | Repeated one-word integer literal matches, charged incrementally as the matcher traverses them. +matchingInteger :: Integer -> Term +matchingInteger i = + foldr + ( \_ handler -> + UPLC.Match () (mkConstant @Integer () 0) $ + V.singleton + ( DefaultPatternInteger 0 + , handler + ) + ) + (mkConstant @Integer () 0) + [1 .. i] + +-- | One wide exact-list match, exercising the fused wildcard streaming traversal. +matchingExactList :: Integer -> Term +matchingExactList i = + let width = fromIntegral i + in UPLC.Match + () + (mkConstant @[Integer] () $ replicate width 0) + ( V.singleton + ( DefaultPatternList $ V.replicate width DefaultPatternWildcard + , mkConstant @Integer () 0 + ) + ) + +-- | A wide successful match in which every field is captured and applied to a handler. +matchingCaptureList :: Integer -> Term +matchingCaptureList i = + let width = fromIntegral i + binder = UPLC.NamedDeBruijn "capture" (UPLC.Index 0) + handler = foldr (const $ UPLC.LamAbs () binder) (mkConstant @Integer () 0) [1 .. i] + in UPLC.Match + () + (mkConstant @[Integer] () $ replicate width 0) + ( V.singleton + ( DefaultPatternList $ V.replicate width DefaultPatternCapture + , handler + ) + ) + +-- | A long ordered chain of late-mismatching scalar alternatives followed by a wildcard. +matchingAlternatives :: Integer -> Term +matchingAlternatives i = + let width = fromIntegral i + miss = + ( DefaultPatternInteger 1 + , mkConstant @Integer () 1 + ) + in UPLC.Match + () + (mkConstant @Integer () 0) + ( V.replicate width miss + <> V.singleton (DefaultPatternWildcard, mkConstant @Integer () 0) + ) + +{-| Four equivalent successful checks of a @Data.Constr 42@ value with exactly the requested +number of fields. The first result uses @UnConstrData@ directly, the second first checks the Data +constructor with @ChooseData@, and the final two use 'Match' with wildcard and capture fields. + +Keeping the terms together here makes the Criterion comparison use the same tag, field values, +success result, fallback result, and exact-arity traversal at every width. -} +dataConstrMatchComparison :: Integer -> (Term, Term, Term, Term) +dataConstrMatchComparison requestedWidth = + ( debruijnTermUnsafe directUnConstr + , debruijnTermUnsafe checkedUnConstr + , debruijnTermUnsafe wildcardMatch + , debruijnTermUnsafe captureMatch + ) + where + width = max 0 $ fromIntegral requestedWidth + scrutinee = mkConstant @PLCData.Data () . PLCData.Constr 42 $ replicate width (PLCData.I 0) + success = mkConstant @Integer () 1 + fallback = mkConstant @Integer () 0 + tagName = Name "tag" (Unique 1000) + fieldsName = Name "fields" (Unique 1001) + fieldName index = Name "field" . Unique $ 2000 + 2 * index + restName index = Name "rest" . Unique $ 2001 + 2 * index + captureName index = Name "capture" . Unique $ 3000 + index + + exactFields index fields + | index == width = + UPLC.Case + () + fields + ( V.fromList + [ UPLC.LamAbs () (fieldName index) $ + UPLC.LamAbs () (restName index) fallback + , success + ] + ) + | otherwise = + UPLC.Case + () + fields + ( V.fromList + [ UPLC.LamAbs () (fieldName index) $ + UPLC.LamAbs () (restName index) $ + exactFields (index + 1) (UPLC.Var () $ restName index) + , fallback + ] + ) + + tagMatches = + mkIterAppNoAnn + (UPLC.Builtin () PLC.EqualsInteger) + [UPLC.Var () tagName, mkConstant @Integer () 42] + directUnConstr = + UPLC.Case + () + (mkIterAppNoAnn (UPLC.Builtin () PLC.UnConstrData) [scrutinee]) + ( V.singleton $ + UPLC.LamAbs () tagName $ + UPLC.LamAbs () fieldsName $ + UPLC.Case + () + tagMatches + ( V.fromList + [ fallback + , exactFields 0 (UPLC.Var () fieldsName) + ] + ) + ) + checkedUnConstr = + UPLC.Force () $ + mkIterAppNoAnn + (UPLC.Force () $ UPLC.Builtin () PLC.ChooseData) + [ scrutinee + , UPLC.Delay () directUnConstr + , UPLC.Delay () fallback + , UPLC.Delay () fallback + , UPLC.Delay () fallback + , UPLC.Delay () fallback + ] + wildcardMatch = + UPLC.Match + () + scrutinee + ( V.fromList + [ + ( DefaultPatternDataConstr 42 $ V.replicate width DefaultPatternWildcard + , success + ) + , (DefaultPatternWildcard, fallback) + ] + ) + captureHandler = + foldr (UPLC.LamAbs () . captureName) success [0 .. width - 1] + captureMatch = + UPLC.Match + () + scrutinee + ( V.fromList + [ + ( DefaultPatternDataConstr 42 $ V.replicate width DefaultPatternCapture + , captureHandler + ) + , (DefaultPatternWildcard, fallback) + ] + ) + +type NamedTerm = UPLC.Term UPLC.Name DefaultUni DefaultFun DefaultBuiltinPattern () + +{-| Repeatedly execute a match through a call-by-value fixed-point combinator. + +The scrutinee is evaluated once outside the recursive loop and captured in its environment. Hence +the timed recursion repeatedly traverses the same pattern and reached value rather than rebuilding +either of them. The integer paired with each alternative is the number of captures its handler +accepts before recurring. + +This is the call-by-value Z combinator rather than Y: the recursive self-application is suspended +under an extra lambda, so constructing the fixed point itself does not diverge. -} +loopingMatch + :: NamedTerm + -> [(DefaultBuiltinPattern, Int)] + -> Term +loopingMatch scrutinee branchShapes = debruijnTermUnsafe $ runQuote $ do + scrutineeName <- freshName "scrutinee" + functionName <- freshName "function" + leftSelfName <- freshName "left-self" + leftArgumentName <- freshName "left-argument" + rightSelfName <- freshName "right-self" + rightArgumentName <- freshName "right-argument" + loopName <- freshName "loop" + loopArgumentName <- freshName "loop-argument" + let unit = mkConstant @() () () + recur = UPLC.Apply () (UPLC.Var () loopName) unit + suspendedSelf selfName argumentName = + UPLC.LamAbs () argumentName $ + UPLC.Apply + () + (UPLC.Apply () (UPLC.Var () selfName) (UPLC.Var () selfName)) + (UPLC.Var () argumentName) + fixHalf selfName argumentName = + UPLC.LamAbs () selfName $ + UPLC.Apply + () + (UPLC.Var () functionName) + (suspendedSelf selfName argumentName) + callByValueFix = + UPLC.LamAbs () functionName $ + UPLC.Apply + () + (fixHalf leftSelfName leftArgumentName) + (fixHalf rightSelfName rightArgumentName) + alternatives <- + forM branchShapes $ \(pat, captureCount) -> do + captureNames <- replicateM captureCount $ freshName "capture" + pure (pat, foldr (UPLC.LamAbs ()) recur captureNames) + let loopBody = + UPLC.Match + () + (UPLC.Var () scrutineeName) + (V.fromList alternatives) + loopFunction = + UPLC.LamAbs () loopName $ + UPLC.LamAbs () loopArgumentName loopBody + runLoop = + UPLC.Apply + () + (UPLC.Apply () callByValueFix loopFunction) + unit + pure $ UPLC.Apply () (UPLC.LamAbs () scrutineeName runLoop) scrutinee + +-- | Repeated successful traversal of a wide exact list pattern. +matchingFixpointExactList :: Integer -> Term +matchingFixpointExactList requestedWidth = + let width = max 1 $ fromIntegral requestedWidth + pat = DefaultPatternList $ V.replicate width DefaultPatternWildcard + in loopingMatch + (mkConstant @[Integer] () $ replicate width 0) + [(pat, 0)] + +-- | Repeated traversal to a mismatch at the final list element, followed by a wildcard fallback. +matchingFixpointLateListMismatch :: Integer -> Term +matchingFixpointLateListMismatch requestedWidth = + let width = max 1 $ fromIntegral requestedWidth + finalMismatch = DefaultPatternInteger 1 + children = V.replicate (width - 1) DefaultPatternWildcard `V.snoc` finalMismatch + pat = DefaultPatternList children + in loopingMatch + (mkConstant @[Integer] () $ replicate width 0) + [(pat, 0), (DefaultPatternWildcard, 0)] + +{-| Repeated late list mismatch after accumulating a long capture prefix. The failed alternative's +captures must be abandoned without either reversing them or applying its handler. -} +matchingFixpointAbandonedCaptures :: Integer -> Term +matchingFixpointAbandonedCaptures requestedWidth = + let width = max 1 $ fromIntegral requestedWidth + finalMismatch = DefaultPatternInteger 1 + children = V.replicate (width - 1) DefaultPatternCapture `V.snoc` finalMismatch + pat = DefaultPatternList children + in loopingMatch + (mkConstant @[Integer] () $ replicate width 0) + [(pat, width - 1), (DefaultPatternWildcard, 0)] + +-- | Repeated exact-list arity mismatch after consuming the entire common prefix. +matchingFixpointListArityMismatch :: Integer -> Integer -> Term +matchingFixpointListArityMismatch requestedPatternWidth requestedDelta = + let patternWidth = max 1 $ fromIntegral requestedPatternWidth + scrutineeWidth = max 0 $ patternWidth + fromIntegral requestedDelta + pat = DefaultPatternList $ V.replicate patternWidth DefaultPatternWildcard + in loopingMatch + (mkConstant @[Integer] () $ replicate scrutineeWidth 0) + [(pat, 0), (DefaultPatternWildcard, 0)] + +-- | Repeated successful wide match in which every field is captured and applied to the handler. +matchingFixpointCaptureList :: Integer -> Term +matchingFixpointCaptureList requestedWidth = + let width = max 1 $ fromIntegral requestedWidth + pat = DefaultPatternList $ V.replicate width DefaultPatternCapture + in loopingMatch + (mkConstant @[Integer] () $ replicate width 0) + [(pat, width)] + +-- | Repeated ordered traversal of many scalar alternatives before taking a wildcard fallback. +matchingFixpointAlternatives :: Integer -> Term +matchingFixpointAlternatives requestedWidth = + let width = max 1 $ fromIntegral requestedWidth + miss = DefaultPatternInteger 1 + in loopingMatch + (mkConstant @Integer () 0) + (replicate width (miss, 0) <> [(DefaultPatternWildcard, 0)]) + +-- | Repeated alternatives that each traverse a substantial list prefix before their late failure. +matchingFixpointWideAlternatives :: Integer -> Integer -> Term +matchingFixpointWideAlternatives requestedAlternatives requestedWidth = + let alternativeCount = max 1 $ fromIntegral requestedAlternatives + width = max 1 $ fromIntegral requestedWidth + finalMismatch = DefaultPatternInteger 1 + children = V.replicate (width - 1) DefaultPatternWildcard `V.snoc` finalMismatch + miss = DefaultPatternList children + in loopingMatch + (mkConstant @[Integer] () $ replicate width 0) + (replicate alternativeCount (miss, 0) <> [(DefaultPatternWildcard, 0)]) + +-- | Repeated traversal of a deeply nested built-in 'Data' pattern. +matchingFixpointNestedData :: Integer -> Term +matchingFixpointNestedData requestedDepth = + let depth = max 1 (fromIntegral requestedDepth) :: Int + pat = + foldl' + (\child _ -> DefaultPatternDataList $ V.singleton child) + DefaultPatternWildcard + [1 .. depth] + value = foldl' (\child _ -> PLCData.List [child]) (PLCData.I 0) [1 .. depth] + in loopingMatch (mkConstant @PLCData.Data () value) [(pat, 0)] + +-- | Repeated traversal of a deeply nested built-in @Data.Constr 0 [child]@ pattern and value. +matchingFixpointNestedDataConstr :: Integer -> Term +matchingFixpointNestedDataConstr requestedDepth = + let depth = max 1 (fromIntegral requestedDepth) :: Int + pat = + foldl' + (\child _ -> DefaultPatternDataConstr 0 $ V.singleton child) + DefaultPatternWildcard + [1 .. depth] + value = foldl' (\child _ -> PLCData.Constr 0 [child]) (PLCData.I 0) [1 .. depth] + in loopingMatch (mkConstant @PLCData.Data () value) [(pat, 0)] + +-- | Repeated streaming traversal of all fields in a wide 'Data.Constr'. +matchingFixpointWideDataConstr :: Integer -> Term +matchingFixpointWideDataConstr requestedWidth = + let width = max 1 $ fromIntegral requestedWidth + pat = DefaultPatternDataConstr 0 $ V.replicate width DefaultPatternWildcard + value = PLCData.Constr 0 $ replicate width (PLCData.I 0) + in loopingMatch (mkConstant @PLCData.Data () value) [(pat, 0)] + +-- | Repeated successful match of the smallest 'Data.Constr' pattern and value. +matchingFixpointEmptyDataConstr :: Term +matchingFixpointEmptyDataConstr = + let pat = DefaultPatternDataConstr 0 V.empty + in loopingMatch (mkConstant @PLCData.Data () $ PLCData.Constr 0 []) [(pat, 0)] + +-- | Repeated equality of an immediate 'Integer', the cheapest scalar representation. +matchingFixpointSmallInteger :: Term +matchingFixpointSmallInteger = + let pat = DefaultPatternInteger 0 + in loopingMatch (mkConstant @Integer () 0) [(pat, 0)] + +-- | Repeated equality of distinct one-byte payloads, covering the shortest bytestring scalar path. +matchingFixpointSmallByteString :: Term +matchingFixpointSmallByteString = + let expected = BS.singleton 0x5A + actual = BS.copy expected + pat = DefaultPatternByteString expected + in loopingMatch (mkConstant @BS.ByteString () actual) [(pat, 0)] + +-- | Repeated equality at the upper boundary of a signed integer pattern. +matchingFixpointMaxInteger :: Term +matchingFixpointMaxInteger = + let expected = maxBound :: Int64 + actual = toInteger expected + pat = DefaultPatternInteger expected + in loopingMatch (mkConstant @Integer () actual) [(pat, 0)] + +-- | Repeated equality of separately allocated large bytestring pattern and scrutinee payloads. +matchingFixpointLargeByteString :: Integer -> Term +matchingFixpointLargeByteString requestedWords = + let words64 = max 1 $ fromIntegral requestedWords + expected = BS.replicate (8 * words64) 0x5A + actual = BS.copy expected + pat = DefaultPatternByteString expected + in loopingMatch (mkConstant @BS.ByteString () actual) [(pat, 0)] + +-- | Repeated equality at the upper boundary of a 'Data.Constr' pattern tag. +matchingFixpointMaxDataTag :: Term +matchingFixpointMaxDataTag = + let expected = maxBound :: Word64 + actual = toInteger expected + pat = DefaultPatternDataConstr expected V.empty + in loopingMatch (mkConstant @PLCData.Data () $ PLCData.Constr actual []) [(pat, 0)] diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index dc8798fe00b..4f5acbf222b 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -281,6 +281,34 @@ benchmark casing , plutus-benchmark-common , plutus-ledger-api ^>=1.65 +---------------- matching ---------------- + +library matching-internal + import: lang, ghc-version-support, os-support + hs-source-dirs: matching/src + exposed-modules: PlutusBenchmark.Matching + build-depends: + , base >=4.9 && <5 + , bytestring + , mtl + , plutus-benchmark-common + , plutus-core ^>=1.65 + , vector + +benchmark matching + import: lang, ghc-version-support, os-support + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: matching/bench + build-depends: + , base >=4.9 && <5 + , criterion >=1.5.9.0 + , deepseq + , matching-internal + , plutus-benchmark-common + , plutus-core ^>=1.65 + , plutus-ledger-api ^>=1.65 + ---------------- data ---------------- library data-internal diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 8c5a951729f..123de1bcd51 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -485,6 +485,7 @@ library untyped-plutus-core-testlib Evaluation.Golden Evaluation.Helpers Evaluation.Machines + Evaluation.Patterns Evaluation.Regressions Flat.Spec Generators.Spec diff --git a/plutus-core/testlib/PlutusCore/Generators/NEAT/Spec.hs b/plutus-core/testlib/PlutusCore/Generators/NEAT/Spec.hs index 5bcceddc848..c9dfcc0661e 100644 --- a/plutus-core/testlib/PlutusCore/Generators/NEAT/Spec.hs +++ b/plutus-core/testlib/PlutusCore/Generators/NEAT/Spec.hs @@ -128,7 +128,7 @@ handleUError :: U.ErrorWithCause (U.EvaluationError structural operational) term -> Either (U.ErrorWithCause (U.EvaluationError structural operational) term) - (U.Term Name DefaultUni DefaultFun ()) + (U.Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()) handleUError e = case U._ewcError e of U.StructuralError _ -> throwError e U.OperationalError _ -> return (U.Error ()) @@ -251,7 +251,7 @@ data TestFail | AgdaErrorP () | FVErrorP FreeVariableError | CkP (CkEvaluationException DefaultUni DefaultFun) - | UCekP (U.CekEvaluationException Name DefaultUni DefaultFun) + | UCekP (U.CekEvaluationException Name DefaultUni DefaultFun DefaultBuiltinPattern) | Ctrex Ctrex data Ctrex @@ -301,7 +301,7 @@ data Ctrex | CtrexUntypedTermEvaluationMismatch ClosedTypeG ClosedTermG - [(String, U.Term Name DefaultUni DefaultFun ())] + [(String, U.Term Name DefaultUni DefaultFun DefaultBuiltinPattern ())] instance Show TestFail where show (TypeError e) = "type error: " ++ show e diff --git a/plutus-core/testlib/PlutusCore/Test.hs b/plutus-core/testlib/PlutusCore/Test.hs index be8cdad0c95..daf72a4f60b 100644 --- a/plutus-core/testlib/PlutusCore/Test.hs +++ b/plutus-core/testlib/PlutusCore/Test.hs @@ -178,13 +178,13 @@ instance ToTPlc a uni fun => ToTPlc (ExceptT SomeException IO a) uni fun where instance ToTPlc (TPLC.Program TPLC.TyName TPLC.Name uni fun ()) uni fun where toTPlc = pure -class ToUPlc a uni fun | a -> uni fun where - toUPlc :: a -> ExceptT SomeException IO (UPLC.Program TPLC.Name uni fun ()) +class ToUPlc a uni fun pat | a -> uni fun pat where + toUPlc :: a -> ExceptT SomeException IO (UPLC.Program TPLC.Name uni fun pat ()) -instance ToUPlc a uni fun => ToUPlc (ExceptT SomeException IO a) uni fun where +instance ToUPlc a uni fun pat => ToUPlc (ExceptT SomeException IO a) uni fun pat where toUPlc a = a >>= toUPlc -instance ToUPlc (UPLC.Program TPLC.Name uni fun ()) uni fun where +instance ToUPlc (UPLC.Program TPLC.Name uni fun pat ()) uni fun pat where toUPlc = pure instance @@ -195,7 +195,11 @@ instance , TPLC.Closed uni , TPLC.Everywhere uni Eq ) - => ToUPlc (TPLC.Program TPLC.TyName UPLC.Name uni fun ()) uni fun + => ToUPlc + (TPLC.Program TPLC.TyName UPLC.Name uni fun ()) + uni + fun + TPLC.DefaultBuiltinPattern where toUPlc = pure @@ -203,7 +207,7 @@ instance . flip runReaderT TPLC.defaultCompilationOpts . TPLC.compileProgram -instance ToUPlc (UPLC.Program UPLC.NamedDeBruijn uni fun ()) uni fun where +instance ToUPlc (UPLC.Program UPLC.NamedDeBruijn uni fun pat ()) uni fun pat where toUPlc p = withExceptT @_ @FreeVariableError toException $ TPLC.runQuoteT $ @@ -263,12 +267,20 @@ instance => Exception (EvaluationExceptionWithLogsAndBudget err) runUPlcFull - :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun + :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun TPLC.DefaultBuiltinPattern => [a] -> ExceptT SomeException IO - (UPLC.Term TPLC.Name TPLC.DefaultUni TPLC.DefaultFun (), TPLC.ExBudget, [Text]) + ( UPLC.Term + TPLC.Name + TPLC.DefaultUni + TPLC.DefaultFun + TPLC.DefaultBuiltinPattern + () + , TPLC.ExBudget + , [Text] + ) runUPlcFull values = do ps <- traverse toUPlc values let (UPLC.Program _ _ t) = foldl1 (unsafeFromRight .* UPLC.applyProgram) ps @@ -279,18 +291,24 @@ runUPlcFull values = do Right resT -> pure (resT, budget, logs) runUPlc - :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun + :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun TPLC.DefaultBuiltinPattern => [a] -> ExceptT SomeException IO - (UPLC.Term TPLC.Name TPLC.DefaultUni TPLC.DefaultFun ()) + ( UPLC.Term + TPLC.Name + TPLC.DefaultUni + TPLC.DefaultFun + TPLC.DefaultBuiltinPattern + () + ) runUPlc values = do (t, _, _) <- runUPlcFull values pure t runUPlcBudget - :: ToUPlc a TPLC.DefaultUni UPLC.DefaultFun + :: ToUPlc a TPLC.DefaultUni UPLC.DefaultFun TPLC.DefaultBuiltinPattern => [a] -> ExceptT SomeException @@ -301,7 +319,7 @@ runUPlcBudget values = do pure budget runUPlcLogs - :: ToUPlc a TPLC.DefaultUni UPLC.DefaultFun + :: ToUPlc a TPLC.DefaultUni UPLC.DefaultFun TPLC.DefaultBuiltinPattern => [a] -> ExceptT SomeException @@ -312,7 +330,7 @@ runUPlcLogs values = do pure logs runUPlcProfile - :: ToUPlc a TPLC.DefaultUni UPLC.DefaultFun + :: ToUPlc a TPLC.DefaultUni UPLC.DefaultFun TPLC.DefaultBuiltinPattern => [a] -> ExceptT SomeException @@ -330,7 +348,7 @@ runUPlcProfile values = do Right _ -> pure logs runUPlcProfile' - :: ToUPlc a TPLC.DefaultUni UPLC.DefaultFun + :: ToUPlc a TPLC.DefaultUni UPLC.DefaultFun TPLC.DefaultBuiltinPattern => [a] -> ExceptT SomeException @@ -392,11 +410,17 @@ goldenTPlcReadable goldenTPlcReadable = goldenTPlcWith ppCatchReadable goldenUPlcWith - :: ToUPlc a UPLC.DefaultUni UPLC.DefaultFun + :: ToUPlc a UPLC.DefaultUni UPLC.DefaultFun TPLC.DefaultBuiltinPattern => ( ExceptT SomeException IO - (UPLC.Program UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) + ( UPLC.Program + UPLC.NamedDeBruijn + UPLC.DefaultUni + UPLC.DefaultFun + TPLC.DefaultBuiltinPattern + () + ) -> IO (Doc ann) ) -> TestName @@ -407,14 +431,14 @@ goldenUPlcWith pp name value = nestedGoldenVsDocM name ".uplc" $ pp $ do withExceptT @_ @FreeVariableError toException $ traverseOf UPLC.progTerm UPLC.deBruijnTerm p goldenUPlc - :: ToUPlc a UPLC.DefaultUni UPLC.DefaultFun + :: ToUPlc a UPLC.DefaultUni UPLC.DefaultFun TPLC.DefaultBuiltinPattern => TestName -> a -> TestNested goldenUPlc = goldenUPlcWith ppCatch goldenUPlcReadable - :: ToUPlc a UPLC.DefaultUni UPLC.DefaultFun + :: ToUPlc a UPLC.DefaultUni UPLC.DefaultFun TPLC.DefaultBuiltinPattern => TestName -> a -> TestNested @@ -428,29 +452,53 @@ goldenTEval goldenTEval name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runTPlc values -goldenUEval :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested +goldenUEval + :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun TPLC.DefaultBuiltinPattern + => TestName + -> [a] + -> TestNested goldenUEval name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlc values -goldenUEvalLogs :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested +goldenUEvalLogs + :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun TPLC.DefaultBuiltinPattern + => TestName + -> [a] + -> TestNested goldenUEvalLogs name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlcLogs values {-| This is mostly useful for profiling a test that is normally tested with one of the other functions, as it's a drop-in replacement and you can then pass the output into `traceToStacks`. -} -goldenUEvalProfile :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested +goldenUEvalProfile + :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun TPLC.DefaultBuiltinPattern + => TestName + -> [a] + -> TestNested goldenUEvalProfile name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlcProfile values -goldenUEvalBudget :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested +goldenUEvalBudget + :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun TPLC.DefaultBuiltinPattern + => TestName + -> [a] + -> TestNested goldenUEvalBudget name values = nestedGoldenVsDocM name ".budget" $ ppCatch $ runUPlcBudget values -goldenAstSize :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> a -> TestNested +goldenAstSize + :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun TPLC.DefaultBuiltinPattern + => TestName + -> a + -> TestNested goldenAstSize name value = nestedGoldenVsDocM name ".astsize" $ pure . pretty . UPLC.programAstSize =<< rethrow (toUPlc value) {-| This is mostly useful for profiling a test that is normally tested with one of the other functions, as it's a drop-in replacement and you can then pass the output into `traceToStacks`. -} -goldenUEvalProfile' :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun => TestName -> [a] -> TestNested +goldenUEvalProfile' + :: ToUPlc a TPLC.DefaultUni TPLC.DefaultFun TPLC.DefaultBuiltinPattern + => TestName + -> [a] + -> TestNested goldenUEvalProfile' name values = nestedGoldenVsDocM name ".eval" $ ppCatch' $ diff --git a/plutus-core/testlib/PlutusIR/Test.hs b/plutus-core/testlib/PlutusIR/Test.hs index 665924e22ae..1fd9d6ebdd7 100644 --- a/plutus-core/testlib/PlutusIR/Test.hs +++ b/plutus-core/testlib/PlutusIR/Test.hs @@ -87,7 +87,11 @@ instance , Default (BuiltinsInfo uni fun) , Default (RewriteRules uni fun) ) - => ToUPlc (PIR.Program PIR.TyName PIR.Name uni fun a) uni fun + => ToUPlc + (PIR.Program PIR.TyName PIR.Name uni fun a) + uni + fun + PLC.DefaultBuiltinPattern where toUPlc = toTPlc >=> toUPlc @@ -233,14 +237,14 @@ goldenPlcFromPirScott = goldenPirM $ \ast -> ppCatch prettyPlcReadableSimple $ d withExceptT @_ @PLC.FreeVariableError toException $ traverseOf PLC.progTerm PLC.deBruijnTerm p goldenNamedUPlcFromPir - :: ToUPlc a PLC.DefaultUni PLC.DefaultFun + :: ToUPlc a PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern => Parser a -> String -> TestNested goldenNamedUPlcFromPir = goldenPirM $ ppCatch prettyPlcReadableSimple . toUPlc goldenEvalPir - :: ToUPlc a PLC.DefaultUni PLC.DefaultFun + :: ToUPlc a PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern => Parser a -> String -> TestNested diff --git a/plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs b/plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs index eef2eac1dec..dc0ef9a1b7a 100644 --- a/plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs +++ b/plutus-core/testlib/UntypedPlutusCore/Generators/Hedgehog/AST.hs @@ -22,26 +22,27 @@ import Universe regenConstantsUntil :: MonadGen m => (Some (ValueOf DefaultUni) -> Bool) - -> Program name DefaultUni fun ann - -> m (Program name DefaultUni fun ann) + -> Program name DefaultUni fun DefaultBuiltinPattern ann + -> m (Program name DefaultUni fun DefaultBuiltinPattern ann) regenConstantsUntil p = progTerm . termSubstConstantsM $ \ann -> fmap (fmap $ Constant ann) . PLC.regenConstantUntil p genTerm :: forall fun . (Bounded fun, Enum fun) - => PLC.AstGen (Term Name DefaultUni fun ()) + => PLC.AstGen (Term Name DefaultUni fun DefaultBuiltinPattern ()) genTerm = fmap eraseTerm PLC.genTerm genProgram :: forall fun - . (Bounded fun, Enum fun) => PLC.AstGen (Program Name DefaultUni fun ()) + . (Bounded fun, Enum fun) + => PLC.AstGen (Program Name DefaultUni fun DefaultBuiltinPattern ()) genProgram = fmap eraseProgram PLC.genProgram -- See Note [Name mangling] mangleNames - :: Term Name DefaultUni DefaultFun () - -> PLC.AstGen (Maybe (Term Name DefaultUni DefaultFun ())) + :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> PLC.AstGen (Maybe (Term Name DefaultUni DefaultFun DefaultBuiltinPattern ())) mangleNames term = do mayMang <- PLC.genNameMangler $ setOf vTerm term for mayMang $ \mang -> termSubstNamesM (const . fmap (fmap $ UPLC.Var ()) . mang) term diff --git a/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Bad.hs b/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Bad.hs index 1edf83cc0c2..0ea6db94318 100644 --- a/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Bad.hs +++ b/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Bad.hs @@ -34,21 +34,24 @@ import UntypedPlutusCore import UntypedPlutusCore.Test.DeBruijn.Good -- | A definitely out-of-scope variable. Our variables start at index 1. -var0 :: Term DeBruijn uni fun () +var0 :: Term DeBruijn uni fun pat () var0 = Var () $ DeBruijn 0 -- | Build a `LamAbs` with the binder having a non-sensical index. -lamAbs1 :: t ~ Term DeBruijn uni fun () => t -> t +lamAbs1 :: t ~ Term DeBruijn uni fun pat () => t -> t lamAbs1 = LamAbs () $ DeBruijn 1 -fun0var0, fun1var0, fun1var1 :: Term DeBruijn DefaultUni DefaultFun () +fun0var0 + , fun1var0 + , fun1var1 + :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () fun0var0 = lamAbs0 var0 fun1var0 = lamAbs1 var0 fun1var1 = lamAbs1 $ Var () $ DeBruijn 1 {-| (lam1 ...n.... (Var n)) Wrong binders, Well-scoped variable -} -deepFun1 :: Natural -> Term DeBruijn DefaultUni DefaultFun () +deepFun1 :: Natural -> Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () deepFun1 n = timesA n lamAbs1 $ Var () $ @@ -57,7 +60,7 @@ deepFun1 n = {-| (lam0 ...n.... (Var n+1)) Correct binders, Out-of-scope variable -} -deepOut0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () +deepOut0 :: Natural -> Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () deepOut0 n = timesA n lamAbs0 $ Var () $ @@ -67,7 +70,7 @@ deepOut0 n = {-| (lam0 ...n.... lam1 ...n.... (Var n+n)) Mix of correct and wrong binders, Well-scoped variable -} -deepMix0_1 :: Natural -> Term DeBruijn DefaultUni DefaultFun () +deepMix0_1 :: Natural -> Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () deepMix0_1 n = timesA n lamAbs0 $ timesA n lamAbs1 $ @@ -78,7 +81,7 @@ deepMix0_1 n = {-| (lam1 ...n.... lam0 ...n.... (Var n+n)) Mix of wrong and correct binders, well-scoped variable -} -deepMix1_0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () +deepMix1_0 :: Natural -> Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () deepMix1_0 n = timesA n lamAbs1 $ timesA n lamAbs0 $ @@ -89,7 +92,7 @@ deepMix1_0 n = {-| (lam1 ...n.... lam0 ...n.... (Var n+n+1)) Mix of correct and wrong binders, out-of-scope variable -} -deepOutMix1_0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () +deepOutMix1_0 :: Natural -> Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () deepOutMix1_0 n = timesA n lamAbs1 $ timesA n lamAbs0 $ @@ -101,7 +104,7 @@ deepOutMix1_0 n = {-| [(force (builtin ifThenElse) (con bool True) (con bool True) var99] Both branches are evaluated *before* the predicate, so it is clear that this should fail in every case. -} -iteStrict0 :: Term DeBruijn DefaultUni DefaultFun () +iteStrict0 :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () iteStrict0 = Force () (Builtin () IfThenElse) @@ [ true -- pred @@ -112,7 +115,7 @@ iteStrict0 = {-| [(force (builtin ifThenElse) (con bool True) (delay true) (delay var99)] The branches are *lazy*. The evaluation result (success or failure) depends on how the machine ignores the irrelevant to the computation) part of the environment. -} -iteLazy0 :: Term DeBruijn DefaultUni DefaultFun () +iteLazy0 :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () iteLazy0 = Force () (Builtin () IfThenElse) @@ [ true -- pred @@ -121,7 +124,7 @@ iteLazy0 = ] -- | [(force (builtin ifThenElse) (con bool True) (lam0 var1) (lam1 var0)] -ite10 :: Term DeBruijn DefaultUni DefaultFun () +ite10 :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () ite10 = Force () (Builtin () IfThenElse) @@ [ true -- pred @@ -130,7 +133,7 @@ ite10 = ] -- | An example with a lot of free vars -manyFree01 :: Term DeBruijn DefaultUni DefaultFun () +manyFree01 :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () manyFree01 = timesA 5 (Apply () (timesA 10 forceDelay var0)) $ timesA 20 forceDelay $ @@ -143,7 +146,7 @@ manyFree01 = {-| [(force (builtin ifThenElse) (con bool True) (con bool True) (con unit ())] Note that the branches have **different** types. The machine cannot catch such a type error. -} -illITEStrict :: Term DeBruijn DefaultUni DefaultFun () +illITEStrict :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () illITEStrict = Force () (Builtin () IfThenElse) @@ [ true -- pred @@ -154,7 +157,7 @@ illITEStrict = {-| [(force (builtin ifThenElse) (con bool True) (lam x (con bool True)) (lam x (con unit ()))] The branches are *lazy*. Note that the branches have **different** types. The machine cannot catch such a type error. -} -illITELazy :: Term DeBruijn DefaultUni DefaultFun () +illITELazy :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () illITELazy = Force () (Builtin () IfThenElse) @@ [ true -- pred @@ -164,7 +167,7 @@ illITELazy = {-| [(builtin addInteger) (con integer 1) (con unit ())] Interesting because it involves a runtime type-error of a builtin. -} -illAdd :: Term DeBruijn DefaultUni DefaultFun () +illAdd :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () illAdd = Builtin () AddInteger @@ [ one @@ -174,7 +177,7 @@ illAdd = {-| [(builtin addInteger) (con integer 1) (con integer 1) (con integer 1)] Interesting because it involves a (builtin) over-saturation type-error, which the machine can recognize. -} -illOverAppBuiltin :: Term DeBruijn DefaultUni DefaultFun () +illOverAppBuiltin :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () illOverAppBuiltin = Builtin () AddInteger @@ [ one @@ -185,7 +188,7 @@ illOverAppBuiltin = {-| [(lam x x) (con integer 1) (con integer 1)] Interesting because it involves a (lambda) over-saturation type-error, which the machine can recognize. -} -illOverAppFun :: Term DeBruijn DefaultUni DefaultFun () +illOverAppFun :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () illOverAppFun = idFun0 @@ [ one @@ -195,10 +198,10 @@ illOverAppFun = {-| [addInteger true] this relates to the immediate vs deferred unlifting. this used to be an immediate type error but now it is deferred until saturation. -} -illPartialBuiltin :: Term DeBruijn DefaultUni DefaultFun () +illPartialBuiltin :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () illPartialBuiltin = Apply () (Builtin () AddInteger) true -- helpers -one :: Term name DefaultUni fun () +one :: Term name DefaultUni fun DefaultBuiltinPattern () one = mkConstant @Integer () 1 diff --git a/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Good.hs b/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Good.hs index 251797afdc7..9ec1f80458b 100644 --- a/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Good.hs +++ b/plutus-core/testlib/UntypedPlutusCore/Test/DeBruijn/Good.hs @@ -13,25 +13,25 @@ import PlutusPrelude import UntypedPlutusCore -- | A helper to intro the only "sensical" lam: debruijn binders are always 0-indexed -lamAbs0 :: t ~ Term DeBruijn uni fun () => t -> t +lamAbs0 :: t ~ Term DeBruijn uni fun pat () => t -> t lamAbs0 = LamAbs () $ DeBruijn deBruijnInitIndex -- | This is a replica of `PlutusCore.StdLib.Data.Function.idFun0` but using `DeBruijn` indices. -idFun0 :: Term DeBruijn uni fun () +idFun0 :: Term DeBruijn uni fun pat () idFun0 = lamAbs0 $ Var () $ DeBruijn 1 -- | This is a replica of `PlutusCore.StdLib.Data.Function.const` but using `DeBruijn` indices. -const0 :: Term DeBruijn uni fun () +const0 :: Term DeBruijn uni fun pat () const0 = lamAbs0 $ lamAbs0 $ Var () $ DeBruijn 2 {-| (lam0 ...n.... (Var n)) Correct binders, well-scoped variable -} -deepFun0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () +deepFun0 :: Natural -> Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () deepFun0 n = timesA n lamAbs0 $ Var () $ DeBruijn $ fromIntegral n {-| (lam0 ...n.... lam0 ...n.... (Var n+n)) Correct binders, well-scoped variable -} -deeperFun0 :: Natural -> Term DeBruijn DefaultUni DefaultFun () +deeperFun0 :: Natural -> Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () deeperFun0 n = timesA n lamAbs0 $ timesA n lamAbs0 $ diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Machines/NumberOfStepCounters.golden b/plutus-core/untyped-plutus-core/test/Evaluation/Machines/NumberOfStepCounters.golden index f11c82a4cb6..f599e28b8ab 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Machines/NumberOfStepCounters.golden +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Machines/NumberOfStepCounters.golden @@ -1 +1 @@ -9 \ No newline at end of file +10 diff --git a/plutus-core/untyped-plutus-core/test/Parser/Golden/bracket-mismatch.golden b/plutus-core/untyped-plutus-core/test/Parser/Golden/bracket-mismatch.golden index 08ae877a79c..302c129ce9f 100644 --- a/plutus-core/untyped-plutus-core/test/Parser/Golden/bracket-mismatch.golden +++ b/plutus-core/untyped-plutus-core/test/Parser/Golden/bracket-mismatch.golden @@ -3,4 +3,4 @@ test:1:18: 1 | (program 1.1.0 [(var x)) | ^^^^^^^ unexpected "var x))" -expecting term keyword (builtin, lam, constr, con, delay, force, error, case) +expecting term keyword (builtin, lam, constr, con, delay, force, error, case, match) diff --git a/plutus-core/untyped-plutus-core/test/Parser/Golden/invalid-keyword.golden b/plutus-core/untyped-plutus-core/test/Parser/Golden/invalid-keyword.golden index bcd7a546c0a..8d26daf8672 100644 --- a/plutus-core/untyped-plutus-core/test/Parser/Golden/invalid-keyword.golden +++ b/plutus-core/untyped-plutus-core/test/Parser/Golden/invalid-keyword.golden @@ -3,4 +3,4 @@ test:1:17: 1 | (program 1.1.0 (foo x)) | ^^^^^^^ unexpected "foo x))" -expecting term keyword (builtin, lam, constr, con, delay, force, error, case) +expecting term keyword (builtin, lam, constr, con, delay, force, error, case, match) diff --git a/plutus-core/untyped-plutus-core/test/Parser/Golden/missing-closing-paren.golden b/plutus-core/untyped-plutus-core/test/Parser/Golden/missing-closing-paren.golden index 29383e32e83..cf6fc486ff4 100644 --- a/plutus-core/untyped-plutus-core/test/Parser/Golden/missing-closing-paren.golden +++ b/plutus-core/untyped-plutus-core/test/Parser/Golden/missing-closing-paren.golden @@ -3,4 +3,4 @@ test:1:24: 1 | (program 1.1.0 (lam x (var x)) | ^^^^^^^ unexpected "var x))" -expecting term keyword (builtin, lam, constr, con, delay, force, error, case) +expecting term keyword (builtin, lam, constr, con, delay, force, error, case, match) diff --git a/plutus-core/untyped-plutus-core/test/Spec.hs b/plutus-core/untyped-plutus-core/test/Spec.hs index 5fb2951d184..bf2b4b897a2 100644 --- a/plutus-core/untyped-plutus-core/test/Spec.hs +++ b/plutus-core/untyped-plutus-core/test/Spec.hs @@ -12,6 +12,7 @@ import Evaluation.Debug (test_debug) import Evaluation.FreeVars (test_freevars) import Evaluation.Golden (test_golden) import Evaluation.Machines (test_NumberOfStepCounters, test_budget, test_machines, test_tallying) +import Evaluation.Patterns (test_patterns) import Evaluation.Regressions (schnorrVerifyRegressions) import Flat.Spec (test_flat) import Generators.Spec (test_parsing) @@ -30,6 +31,7 @@ main = do testGroup "Untyped Plutus Core" [ test_machines + , test_patterns , test_builtins , test_budget , test_caseOfCase diff --git a/plutus-core/untyped-plutus-core/testlib/Analysis/Lib.hs b/plutus-core/untyped-plutus-core/testlib/Analysis/Lib.hs index 9f0fb09cb86..68a02649a32 100644 --- a/plutus-core/untyped-plutus-core/testlib/Analysis/Lib.hs +++ b/plutus-core/untyped-plutus-core/testlib/Analysis/Lib.hs @@ -5,7 +5,7 @@ module Analysis.Lib where import Data.Text qualified as Text import Numeric.Natural (Natural) import PlutusCore.Builtin (BuiltinSemanticsVariant) -import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun, DefaultUni) import PlutusCore.Default.Builtins (DefaultFun (..)) import PlutusCore.MkPlc (mkConstant, mkIterAppNoAnn) import PlutusCore.Name.Unique (Name (..), Unique (..)) @@ -19,7 +19,7 @@ import UntypedPlutusCore.Purity (termEvaluationOrder) builtinSemantics :: BuiltinSemanticsVariant DefaultFun builtinSemantics = def -goldenEvalOrder :: String -> Term Name DefaultUni DefaultFun () -> TestNested +goldenEvalOrder :: String -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> TestNested goldenEvalOrder name tm = let order = termEvaluationOrder builtinSemantics tm in nestedGoldenVsDoc name "" (prettyPlcReadable order) @@ -27,7 +27,7 @@ goldenEvalOrder name tm = -------------------------------------------------------------------------------- -- Terms for testing ----------------------------------------------------------- -termIfThenElse :: Term Name DefaultUni DefaultFun () +termIfThenElse :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () termIfThenElse = Apply () @@ -38,13 +38,13 @@ termIfThenElse = ) (termVar 3) -termVar :: Natural -> Term Name DefaultUni DefaultFun () +termVar :: Natural -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () termVar n = Var () (Name ("var" <> Text.pack (show n)) (Unique (fromIntegral n))) -- that the computation is lazy -- [ [ n m ] (constr 1 [undefined]) ] -dangerTerm :: Term Name DefaultUni DefaultFun () +dangerTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () dangerTerm = runQuote $ do n <- freshName "n" m <- freshName "m" @@ -53,7 +53,7 @@ dangerTerm = runQuote $ do -- arguments for now. pure $ Apply () (Apply () (Var () n) (Var () m)) (Constr () 1 [undefined]) -letFun :: Term Name DefaultUni DefaultFun () +letFun :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () letFun = runQuote $ do n <- freshName "n" let intConst = mkConstant () (1 :: Integer) @@ -63,7 +63,7 @@ letFun = runQuote $ do (LamAbs () n (mkIterAppNoAnn (Var () n) [intConst, intConst])) (Builtin () AddInteger) -letImpure :: Term Name DefaultUni DefaultFun () +letImpure :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () letImpure = runQuote $ do n <- freshName "n" m <- freshName "m" diff --git a/plutus-core/untyped-plutus-core/testlib/Analysis/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Analysis/Spec.hs index 172df89b89e..8991e9b330f 100644 --- a/plutus-core/untyped-plutus-core/testlib/Analysis/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Analysis/Spec.hs @@ -5,7 +5,7 @@ module Analysis.Spec where import Analysis.Lib -import PlutusCore.Default (DefaultFun (..), DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun (..), DefaultUni) import PlutusCore.Name.Unique (Name (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Extras (embed, runTestNested) @@ -76,7 +76,7 @@ testSomeTypeSomeTermArgsLeft = testCase "some type args and some term args are unapplied" $ map (isPure builtinSemantics) terms @?= [True, True] where - terms :: [Term Name DefaultUni DefaultFun ()] = + terms :: [Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()] = [ Builtin () Trace -- 1 type arg and 2 term args are unapplied , Force () (Builtin () FstPair) -- 2 type args, 1 applied and 1 left ] @@ -86,7 +86,7 @@ testNoTypeSomeTermArgsLeft = testCase "no type args and some term args are unapplied" $ map (isPure builtinSemantics) terms @?= [True, True] where - terms :: [Term Name DefaultUni DefaultFun ()] = + terms :: [Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()] = [ Builtin () EncodeUtf8 -- no type args, 1 term arg left to apply , Force () (Builtin () Trace) -- 1 type arg applied, 2 term args left ] @@ -102,7 +102,7 @@ testNoTypeNoTermArgsLeft = testAddInteger :: TestTree = testCase "AddInteger" $ isPure builtinSemantics term @?= False where - term :: Term Name DefaultUni DefaultFun () = + term :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () = Apply () (Apply () (Builtin () AddInteger) (termVar 1)) (termVar 2) testIfThenElse :: TestTree = @@ -124,7 +124,7 @@ testApplyNoTermParam = isPure builtinSemantics termSaturated @?= False ] where - termExpectingType :: Term Name DefaultUni DefaultFun () = + termExpectingType :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () = Apply () (Builtin () Trace) (termVar 1) - termSaturated :: Term Name DefaultUni DefaultFun () = + termSaturated :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () = Apply () (Builtin () EncodeUtf8) (termVar 1) diff --git a/plutus-core/untyped-plutus-core/testlib/DeBruijn/Scope.hs b/plutus-core/untyped-plutus-core/testlib/DeBruijn/Scope.hs index a148aa17c1f..d37c19d0d9a 100644 --- a/plutus-core/untyped-plutus-core/testlib/DeBruijn/Scope.hs +++ b/plutus-core/untyped-plutus-core/testlib/DeBruijn/Scope.hs @@ -16,7 +16,7 @@ import Control.Monad.Except import Test.Tasty.Extras import Test.Tasty.HUnit -type T = Term DeBruijn DefaultUni DefaultFun () +type T = Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () testsOk :: [(String, T)] testsOk = diff --git a/plutus-core/untyped-plutus-core/testlib/DeBruijn/UnDeBruijnify.hs b/plutus-core/untyped-plutus-core/testlib/DeBruijn/UnDeBruijnify.hs index 665209e8813..be6cd3a7593 100644 --- a/plutus-core/untyped-plutus-core/testlib/DeBruijn/UnDeBruijnify.hs +++ b/plutus-core/untyped-plutus-core/testlib/DeBruijn/UnDeBruijnify.hs @@ -19,7 +19,7 @@ import Control.Monad.Except import Control.Monad.State import Test.Tasty.Extras -type T = Term DeBruijn DefaultUni DefaultFun () +type T = Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () -- | (lam0 [2 1 4 (lam1 [1 4 3 5])]) graceElaborate :: T diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Common.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Common.hs index 1fe56fab1f7..52f0edfbd8d 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Common.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Common.hs @@ -63,12 +63,17 @@ typecheckAnd , TPLC.Typecheckable uni fun , GEq uni , CaseBuiltin uni + , MatchBuiltin uni DefaultBuiltinPattern , Closed uni , uni `Everywhere` ExMemoryUsage ) => BuiltinSemanticsVariant fun - -> ( MachineParameters CekMachineCosts fun (CekValue uni fun ()) - -> UPLC.Term Name uni fun () + -> ( MachineParameters + CekMachineCosts + fun + (CekValue uni fun DefaultBuiltinPattern ()) + DefaultBuiltinPattern + -> UPLC.Term Name uni fun DefaultBuiltinPattern () -> a ) -> CostingPart uni fun @@ -82,7 +87,7 @@ typecheckAnd semvar action costingPart term = TPLC.runQuoteT $ do return . action runtime $ TPLC.eraseTerm term where runtime = - MachineParameters def . mkMachineVariantParameters semvar $ + MachineParameters def def . mkMachineVariantParameters semvar $ -- FIXME: make sure we have the the correct cost model for the semantics variant. CostModel defaultCekMachineCostsForTesting costingPart @@ -95,11 +100,12 @@ typecheckEvaluateCek , PrettyUni uni , Pretty fun , CaseBuiltin uni + , MatchBuiltin uni DefaultBuiltinPattern ) => BuiltinSemanticsVariant fun -> CostingPart uni fun -> TPLC.Term TyName Name uni fun () - -> m (EvaluationResult (UPLC.Term Name uni fun ()), [Text]) + -> m (EvaluationResult (UPLC.Term Name uni fun DefaultBuiltinPattern ()), [Text]) typecheckEvaluateCek semvar = typecheckAnd semvar $ \params -> first unsafeSplitStructuralOperational . evaluateCek logEmitter params @@ -113,11 +119,12 @@ typecheckEvaluateCekNoEmit , PrettyUni uni , Pretty fun , CaseBuiltin uni + , MatchBuiltin uni DefaultBuiltinPattern ) => BuiltinSemanticsVariant fun -> CostingPart uni fun -> TPLC.Term TyName Name uni fun () - -> m (EvaluationResult (UPLC.Term Name uni fun ())) + -> m (EvaluationResult (UPLC.Term Name uni fun DefaultBuiltinPattern ())) typecheckEvaluateCekNoEmit semvar = typecheckAnd semvar $ \params -> unsafeSplitStructuralOperational . evaluateCekNoEmit params @@ -131,12 +138,13 @@ typecheckReadKnownCek , PrettyUni uni , Pretty fun , CaseBuiltin uni - , ReadKnown (UPLC.Term Name uni fun ()) a + , MatchBuiltin uni DefaultBuiltinPattern + , ReadKnown (UPLC.Term Name uni fun DefaultBuiltinPattern ()) a ) => BuiltinSemanticsVariant fun -> CostingPart uni fun -> TPLC.Term TyName Name uni fun () - -> m (Either (CekEvaluationException Name uni fun) a) + -> m (Either (CekEvaluationException Name uni fun DefaultBuiltinPattern) a) typecheckReadKnownCek semvar = typecheckAnd semvar readKnownCek @@ -145,7 +153,13 @@ typecheckReadKnownCek semvar = type PlcType = TPLC.Type TPLC.TyName TPLC.DefaultUni () type PlcTerm = TPLC.Term TPLC.TyName TPLC.Name TPLC.DefaultUni TPLC.DefaultFun () type PlcError = TypeErrorPlc TPLC.DefaultUni TPLC.DefaultFun () -type UplcTerm = UPLC.Term TPLC.Name TPLC.DefaultUni TPLC.DefaultFun () +type UplcTerm = + UPLC.Term + TPLC.Name + TPLC.DefaultUni + TPLC.DefaultFun + TPLC.DefaultBuiltinPattern + () -- Possible CEK evluation results, flattened out data TypeErrorOrCekResult diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Conversion.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Conversion.hs index 67bd0b2e062..a427a869afb 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Conversion.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Conversion.hs @@ -680,7 +680,12 @@ genR = Gen.integral (Range.constant 1 255) -- Helpers evaluateAndVerify - :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () + :: UPLC.Term + UPLC.Name + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + () -> PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> PropertyT IO () evaluateAndVerify expected actual = @@ -715,7 +720,12 @@ evaluateShouldFail expr = case typecheckEvaluateCek def defaultBuiltinCostModelF PLC.EvaluationSuccess _ -> assertFailure "should have failed, but didn't" evaluateAssertEqual - :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () + :: UPLC.Term + UPLC.Name + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + () -> PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> IO () evaluateAssertEqual expected actual = diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Definition.hs index a35ae79ed88..ef81d420bdf 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/Definition.hs @@ -293,7 +293,7 @@ test_ScottToMetaUnit = -- @scottToMetaUnit Scott.unitval@ is well-typed and runs successfully. typecheckEvaluateCekNoEmit def () (applyTerm Scott.unitval) @?= Right res let runtime = - MachineParameters def . mkMachineVariantParameters def $ + MachineParameters def def . mkMachineVariantParameters def $ CostModel defaultCekMachineCostsForTesting () -- @scottToMetaUnit Scott.map@ is ill-typed, but still runs successfully, since the builtin -- doesn't look at the argument. diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/MakeRead.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/MakeRead.hs index 152135bf760..f44be742ba5 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/MakeRead.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Builtins/MakeRead.hs @@ -33,7 +33,7 @@ import Data.Text (Text) Haskell value. -} makeRead :: ( MakeKnown (TPLC.Term TyName Name DefaultUni DefaultFun ()) a - , ReadKnown (UPLC.Term Name DefaultUni DefaultFun ()) a + , ReadKnown (UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()) a ) => a -> EvaluationResult a makeRead x = do @@ -49,7 +49,7 @@ makeRead x = do builtinRoundtrip :: ( MakeKnown (TPLC.Term TyName Name DefaultUni DefaultFun ()) a - , ReadKnown (UPLC.Term Name DefaultUni DefaultFun ()) a + , ReadKnown (UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()) a , Show a , Eq a ) diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Debug.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Debug.hs index f2706e75dc3..e6f97f688b1 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Debug.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Debug.hs @@ -22,6 +22,7 @@ import Control.Monad.ST import Control.Monad.Writer import Data.ByteString.Lazy.Char8 qualified as BS import Data.Text qualified as T +import Data.Typeable (Typeable) import Data.Void import Prettyprinter import System.FilePath @@ -41,7 +42,12 @@ newtype EmptyAnn = EmptyAnn () instance Breakpointable EmptyAnn Breakpoints where hasBreakpoints _ = absurd -examples :: [(String, [Cmd Breakpoints], NTerm DefaultUni DefaultFun EmptyAnn)] +examples + :: [ ( String + , [Cmd Breakpoints] + , NTerm DefaultUni DefaultFun DefaultBuiltinPattern EmptyAnn + ) + ] examples = [ ("ex1", repeat Step, Delay mempty $ Error mempty) , ("ex2", replicate 4 Step, Force mempty $ Delay mempty $ Error mempty) @@ -49,7 +55,12 @@ examples = , ("ex4", repeat Step, Error mempty) ] -goldenVsDebug :: (TestName, [Cmd Breakpoints], NTerm DefaultUni DefaultFun EmptyAnn) -> TestTree +goldenVsDebug + :: ( TestName + , [Cmd Breakpoints] + , NTerm DefaultUni DefaultFun DefaultBuiltinPattern EmptyAnn + ) + -> TestTree goldenVsDebug (name, cmds, term) = goldenVsString name @@ -63,7 +74,7 @@ goldenVsDebug (name, cmds, term) = mock :: [Cmd Breakpoints] -- ^ commands to feed - -> NTerm DefaultUni DefaultFun EmptyAnn + -> NTerm DefaultUni DefaultFun DefaultBuiltinPattern EmptyAnn -- ^ term to debug -> [String] -- ^ mocking output @@ -84,15 +95,17 @@ mock cmds t = runST $ unCekM $ do ------------------------------- handle - :: forall uni fun s m + :: forall uni fun pat s m . ( ThrowableBuiltins uni fun + , Pretty pat + , Typeable pat , MonadWriter [String] m , MonadReader [Cmd Breakpoints] m , PrimMonad m , PrimState m ~ s ) - => CekTrans uni fun EmptyAnn s - -> DebugF uni fun EmptyAnn Breakpoints (m ()) + => CekTrans uni fun pat EmptyAnn s + -> DebugF uni fun pat EmptyAnn Breakpoints (m ()) -> m () handle cekTrans = \case StepF prevState k -> do diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/FreeVars.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/FreeVars.hs index 6a3772c87b1..0e9add83e3d 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/FreeVars.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/FreeVars.hs @@ -100,7 +100,7 @@ testDischargeFree = ] ) - dis = dischargeCekValue @DefaultUni @DefaultFun + dis = dischargeCekValue @DefaultUni @DefaultFun @DefaultBuiltinPattern v = Var () . DeBruijn test_freevars :: TestTree @@ -112,5 +112,7 @@ test_freevars = ] -- shortcuts -toFakeTerm :: Term DeBruijn uni fun ann -> Term NamedDeBruijn uni fun ann +toFakeTerm + :: Term DeBruijn uni fun pat ann + -> Term NamedDeBruijn uni fun pat ann toFakeTerm = termMapNames fakeNameDeBruijn diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Golden.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Golden.hs index 1420d0906c8..ec2a5a04598 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Golden.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Golden.hs @@ -25,6 +25,7 @@ import PlutusCore.Evaluation.Machine.ExBudgetingDefaults import PlutusCore.Generators.Hedgehog.Interesting import PlutusCore.MkPlc import PlutusCore.Pretty +import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek import Control.Monad.Except @@ -445,14 +446,19 @@ goldenVsPretty extn name value = goldenVsEvaluatedCK :: String -> Term TyName Name DefaultUni DefaultFun () -> TestTree goldenVsEvaluatedCK name = goldenVsPretty ".golden.plc" name - . bimap (fmap eraseTerm) eraseTerm + . bimap (fmap eraseDefault) eraseDefault . evaluateCkNoEmit defaultBuiltinsRuntimeForTesting def goldenVsEvaluatedCEK :: String -> Term TyName Name DefaultUni DefaultFun () -> TestTree goldenVsEvaluatedCEK name = goldenVsPretty ".golden.uplc" name . evaluateCekNoEmit defaultCekParametersForTesting - . eraseTerm + . eraseDefault + +eraseDefault + :: Term TyName Name DefaultUni DefaultFun () + -> UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern () +eraseDefault = eraseTerm runTypecheck :: Term TyName Name DefaultUni DefaultFun () diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Helpers.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Helpers.hs index 1056473faa5..e1a48c7540d 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Helpers.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Helpers.hs @@ -102,7 +102,16 @@ evaluate it, then produce the required Haskell value from the results. If we fai instead fail the test and report the failure. -} evaluateToHaskell :: forall (a :: Type) - . ReadKnownIn UPLC.DefaultUni (UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun ()) a + . ReadKnownIn + UPLC.DefaultUni + ( UPLC.Term + UPLC.Name + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + () + ) + a => PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> PropertyT IO a evaluateToHaskell expr = diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Machines.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Machines.hs index e90a0e462fe..a716976eb21 100644 --- a/plutus-core/untyped-plutus-core/testlib/Evaluation/Machines.hs +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Machines.hs @@ -39,18 +39,24 @@ import GHC.Exts (fromString) import GHC.Ix import GHC.TypeNats (natVal) import Hedgehog hiding (Size, Var, eval) +import Prettyprinter (hardline) import Test.Tasty import Test.Tasty.Extras import Test.Tasty.Golden +import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.Hedgehog testMachine :: (uni ~ DefaultUni, fun ~ DefaultFun, PrettyPlc structural) => String - -> ( Term Name uni fun () + -> ( Term Name uni fun DefaultBuiltinPattern () -> Either - (EvaluationException structural operational (Term Name uni fun ())) - (Term Name uni fun ()) + ( EvaluationException + structural + operational + (Term Name uni fun DefaultBuiltinPattern ()) + ) + (Term Name uni fun DefaultBuiltinPattern ()) ) -> TestTree testMachine machine eval = @@ -72,9 +78,9 @@ test_machines = testBudget :: (Ix fun, Show fun, Hashable fun, Pretty fun, Typeable fun) - => BuiltinsRuntime fun (CekValue DefaultUni fun ()) + => BuiltinsRuntime fun (CekValue DefaultUni fun DefaultBuiltinPattern ()) -> TestName - -> Term Name DefaultUni fun () + -> Term Name DefaultUni fun DefaultBuiltinPattern () -> TestNested testBudget runtime name term = nestedGoldenVsText @@ -83,7 +89,7 @@ testBudget runtime name term = ( render $ prettyPlcReadable $ runCekNoEmit - ( MachineParameters def $ + ( MachineParameters def def $ MachineVariantParameters Plc.defaultCekMachineCostsForTesting runtime ) Cek.tallying @@ -149,7 +155,7 @@ test_budget = folder runtime = foldPlcFolderContents testNested mempty (\name -> testBudget runtime name . eraseTerm) -testTallying :: TestName -> Term Name DefaultUni DefaultFun () -> TestNested +testTallying :: TestName -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> TestNested testTallying name term = nestedGoldenVsText name @@ -166,6 +172,11 @@ test_tallying = test_NumberOfStepCounters :: TestTree test_NumberOfStepCounters = - runTestNestedM ["untyped-plutus-core", "test", "Evaluation", "Machines"] $ do - nestedGoldenVsDoc "NumberOfStepCounters" "" . pretty . natVal $ Proxy @NumberOfStepCounters - nestedGoldenVsDoc "NumberOfStepCounters" "" . pretty . length $ enumerate @StepKind + testGroup + "NumberOfStepCounters" + [ runTestNestedM ["untyped-plutus-core", "test", "Evaluation", "Machines"] $ do + nestedGoldenVsDoc "NumberOfStepCounters" "" . (<> hardline) . pretty . natVal $ + Proxy @NumberOfStepCounters + , testCase "type-level counter agrees with the StepKind enumeration" $ + natVal (Proxy @NumberOfStepCounters) @?= fromIntegral (length $ enumerate @StepKind) + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Evaluation/Patterns.hs b/plutus-core/untyped-plutus-core/testlib/Evaluation/Patterns.hs new file mode 100644 index 00000000000..988b7121c0c --- /dev/null +++ b/plutus-core/untyped-plutus-core/testlib/Evaluation/Patterns.hs @@ -0,0 +1,770 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Evaluation.Patterns (test_patterns) where + +import Data.ByteString qualified as BS +import Data.Functor.Identity (runIdentity) +import Data.Int (Int64) +import Data.List (foldl') +import Data.Vector qualified as Vector +import Data.Word (Word64) +import PlutusCore.Data qualified as PLC +import PlutusCore.Default + ( DefaultBuiltinPattern (..) + , DefaultFun (..) + , DefaultUni + ) +import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..), ExRestrictingBudget (..)) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParametersForTesting) +import PlutusCore.Evaluation.Machine.Exception + ( MachineError (NonFunctionalApplicationMachineError) + ) +import PlutusCore.Evaluation.Machine.MachineParameters + ( MachineParameters (..) + , MachineVariantParameters (..) + ) +import PlutusCore.MkPlc (mkConstant, mkIterAppNoAnn) +import PlutusCore.Name.Unique (Name (..), Unique (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) +import UntypedPlutusCore qualified as UPLC +import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek +import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts + ( cekMatchCost + , cekPatternCost + , cekPatternFailureCost + , cekPatternStructuralCost + , unitCekMachineCosts + ) +import UntypedPlutusCore.Evaluation.Machine.SteppableCek qualified as SteppableCek + +type UTerm = UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + +patternChildren + :: (Vector.Vector DefaultBuiltinPattern -> DefaultBuiltinPattern) + -> [DefaultBuiltinPattern] + -> DefaultBuiltinPattern +patternChildren constructor = constructor . Vector.fromList + +dataConstrPattern + :: Word64 + -> [DefaultBuiltinPattern] + -> DefaultBuiltinPattern +dataConstrPattern tag = patternChildren (DefaultPatternDataConstr tag) + +dataIPattern :: DefaultBuiltinPattern -> DefaultBuiltinPattern +dataIPattern = DefaultPatternDataI . Just + +dataBPattern :: DefaultBuiltinPattern -> DefaultBuiltinPattern +dataBPattern = DefaultPatternDataB . Just + +pairPattern :: DefaultBuiltinPattern -> DefaultBuiltinPattern -> DefaultBuiltinPattern +pairPattern = DefaultPatternPair + +matchSingle :: DefaultBuiltinPattern -> UTerm -> UTerm -> UTerm +matchSingle pat handler scrutinee = + UPLC.Match () scrutinee $ Vector.singleton (pat, handler) + +constantData :: PLC.Data -> UTerm +constantData = mkConstant @PLC.Data () + +constantInteger :: Integer -> UTerm +constantInteger = mkConstant @Integer () + +assertBothEvaluateTo :: UTerm -> UTerm -> IO () +assertBothEvaluateTo expected term = do + Cek.evaluateCekNoEmit defaultCekParametersForTesting term @?= Right expected + SteppableCek.evaluateCekNoEmit defaultCekParametersForTesting term @?= Right expected + +assertBothFail :: UTerm -> IO () +assertBothFail term = do + assertFails "CEK" $ Cek.evaluateCekNoEmit defaultCekParametersForTesting term + assertFails "steppable CEK" $ SteppableCek.evaluateCekNoEmit defaultCekParametersForTesting term + where + assertFails machine = \case + Left _ -> pure () + Right result -> assertFailure $ machine <> " unexpectedly returned " <> show result + +assertBothFailNonFunctionalWithoutCause :: UTerm -> IO () +assertBothFailNonFunctionalWithoutCause term = do + assertExpectedFailure "CEK" $ Cek.evaluateCekNoEmit defaultCekParametersForTesting term + assertExpectedFailure "steppable CEK" $ + SteppableCek.evaluateCekNoEmit defaultCekParametersForTesting term + where + assertExpectedFailure machine = \case + Left + ( Cek.ErrorWithCause + (Cek.StructuralError NonFunctionalApplicationMachineError) + Nothing + ) -> pure () + result -> + assertFailure $ + machine <> " did not fail with a cause-free non-functional application: " <> show result + +assertBothRunOutOfBudget :: UTerm -> IO () +assertBothRunOutOfBudget term = do + assertOutOfBudget "CEK" . fst $ + Cek.runCekNoEmit defaultCekParametersForTesting (Cek.restricting nearMaximumCpuBudget) term + assertOutOfBudget "steppable CEK" . fst $ + SteppableCek.runCekNoEmit + defaultCekParametersForTesting + (Cek.restricting nearMaximumCpuBudget) + term + where + -- Keep incremental-exhaustion tests fast enough for the regular test suite. + nearMaximumCpuBudget = ExRestrictingBudget $ ExBudget 40000000 1000000000 + assertOutOfBudget machine = \case + Left (Cek.ErrorWithCause (Cek.OperationalError (Cek.CekOutOfExError _)) _) -> pure () + result -> assertFailure $ machine <> " did not stop with an out-of-budget error: " <> show result + +defaultParameters + :: MachineParameters + Cek.CekMachineCosts + DefaultFun + (Cek.CekValue DefaultUni DefaultFun DefaultBuiltinPattern ()) + DefaultBuiltinPattern +defaultParameters = defaultCekParametersForTesting + +unitParameters + :: MachineParameters + Cek.CekMachineCosts + DefaultFun + (Cek.CekValue DefaultUni DefaultFun DefaultBuiltinPattern ()) + DefaultBuiltinPattern +unitParameters = case defaultParameters of + MachineParameters caser matcher (MachineVariantParameters _ runtime) -> + MachineParameters caser matcher (MachineVariantParameters unitCekMachineCosts runtime) + +selectedStepOnly + :: Cek.StepKind + -> Cek.ExBudgetMode ExBudget DefaultUni DefaultFun DefaultBuiltinPattern +selectedStepOnly wanted = Cek.monoidalBudgeting $ \category budget -> case category of + Cek.BStep actual | actual == wanted -> budget + _ -> mempty + +selectedPatternOnly + :: Cek.ExBudgetMode ExBudget DefaultUni DefaultFun DefaultBuiltinPattern +selectedPatternOnly = Cek.monoidalBudgeting $ \category budget -> case category of + Cek.BPattern -> budget + _ -> mempty + +stepBudget :: Cek.StepKind -> UTerm -> ExBudget +stepBudget wanted term = + snd $ Cek.runCekNoEmit unitParameters (selectedStepOnly wanted) term + +steppableStepBudget :: Cek.StepKind -> UTerm -> ExBudget +steppableStepBudget wanted term = + snd $ SteppableCek.runCekNoEmit unitParameters (selectedStepOnly wanted) term + +patternBudget :: UTerm -> ExBudget +patternBudget term = snd $ Cek.runCekNoEmit unitParameters selectedPatternOnly term + +steppablePatternBudget :: UTerm -> ExBudget +steppablePatternBudget term = snd $ SteppableCek.runCekNoEmit unitParameters selectedPatternOnly term + +captureHandler :: UTerm +captureHandler = + UPLC.LamAbs () x $ + UPLC.LamAbs () y $ + UPLC.LamAbs () z $ + UPLC.Var () y + where + x = Name "x" (Unique 0) + y = Name "y" (Unique 1) + z = Name "z" (Unique 2) + +capturePattern :: DefaultBuiltinPattern +capturePattern = + dataConstrPattern + 1 + [DefaultPatternCapture, DefaultPatternCapture, DefaultPatternCapture] + +captureScrutinee :: UTerm +captureScrutinee = constantData $ PLC.Constr 1 [PLC.I 1, PLC.I 2, PLC.I 3] + +captureTerm :: UTerm +captureTerm = matchSingle capturePattern captureHandler captureScrutinee + +totalBudget :: UTerm -> ExBudget +totalBudget term = case Cek.runCekNoEmit defaultParameters Cek.counting term of + (_, Cek.CountingSt budget) -> budget + +{-| Match a particular @Data.Constr@ tag and exact field count using only the traditional builtins. +All non-constructor, wrong-tag, and wrong-arity inputs take the fallback, just as they do in the +corresponding ordered 'UPLC.Match'. -} +traditionalDataConstrMatch :: Int -> UTerm +traditionalDataConstrMatch = snd . traditionalDataConstrMatches + +traditionalUnConstrDataMatch :: Int -> UTerm +traditionalUnConstrDataMatch = fst . traditionalDataConstrMatches + +traditionalDataConstrMatches :: Int -> (UTerm, UTerm) +traditionalDataConstrMatches width = + ( constrBranch + , UPLC.Force () $ + mkIterAppNoAnn + (UPLC.Force () $ UPLC.Builtin () ChooseData) + [ scrutinee + , UPLC.Delay () constrBranch + , UPLC.Delay () fallback + , UPLC.Delay () fallback + , UPLC.Delay () fallback + , UPLC.Delay () fallback + ] + ) + where + scrutinee = constantData . PLC.Constr 42 $ replicate width (PLC.I 0) + success = constantInteger 1 + fallback = constantInteger 0 + tagName = Name "tag" (Unique 1000) + fieldsName = Name "fields" (Unique 1001) + fieldName index = Name "field" . Unique $ 2000 + 2 * index + restName index = Name "rest" . Unique $ 2001 + 2 * index + exactFields index fields + | index == width = + UPLC.Case + () + fields + ( Vector.fromList + [ UPLC.LamAbs () (fieldName index) $ + UPLC.LamAbs () (restName index) fallback + , success + ] + ) + | otherwise = + UPLC.Case + () + fields + ( Vector.fromList + [ UPLC.LamAbs () (fieldName index) $ + UPLC.LamAbs () (restName index) $ + exactFields (index + 1) (UPLC.Var () $ restName index) + , fallback + ] + ) + tagMatches = + mkIterAppNoAnn + (UPLC.Builtin () EqualsInteger) + [UPLC.Var () tagName, constantInteger 42] + constrBranch = + UPLC.Case + () + (mkIterAppNoAnn (UPLC.Builtin () UnConstrData) [scrutinee]) + ( Vector.singleton $ + UPLC.LamAbs () tagName $ + UPLC.LamAbs () fieldsName $ + UPLC.Case + () + tagMatches + ( Vector.fromList + [ fallback + , exactFields 0 (UPLC.Var () fieldsName) + ] + ) + ) + +matchDataConstrWildcards :: Int -> UTerm +matchDataConstrWildcards width = + UPLC.Match + () + scrutinee + ( Vector.fromList + [ (dataConstrPattern 42 $ replicate width DefaultPatternWildcard, constantInteger 1) + , (DefaultPatternWildcard, constantInteger 0) + ] + ) + where + scrutinee = constantData . PLC.Constr 42 $ replicate width (PLC.I 0) + +matchDataConstrCaptures :: Int -> UTerm +matchDataConstrCaptures width = + UPLC.Match + () + scrutinee + ( Vector.fromList + [ (dataConstrPattern 42 $ replicate width DefaultPatternCapture, handler) + , (DefaultPatternWildcard, constantInteger 0) + ] + ) + where + scrutinee = constantData . PLC.Constr 42 $ replicate width (PLC.I 0) + captureName index = Name "capture" . Unique $ 3000 + index + handler = foldr (UPLC.LamAbs () . captureName) (constantInteger 1) [0 .. width - 1] + +nestedDataPattern :: DefaultBuiltinPattern +nestedDataPattern = + patternChildren + DefaultPatternDataList + [ dataConstrPattern + 0 + [dataIPattern $ DefaultPatternInteger 1] + ] + +nestedCapturePattern :: DefaultBuiltinPattern +nestedCapturePattern = + dataConstrPattern + 9 + [ patternChildren + DefaultPatternDataList + [ dataIPattern DefaultPatternCapture + , DefaultPatternCapture + ] + , dataBPattern DefaultPatternCapture + ] + +nestedCaptureScrutinee :: UTerm +nestedCaptureScrutinee = + constantData $ PLC.Constr 9 [PLC.List [PLC.I 11, PLC.I 22], PLC.B "abc"] + +selectCaptureHandler :: Int -> UTerm +selectCaptureHandler selected = + UPLC.LamAbs () first $ + UPLC.LamAbs () second $ + UPLC.LamAbs () third $ + UPLC.Var () $ + [first, second, third] !! selected + where + first = Name "first" (Unique 10) + second = Name "second" (Unique 11) + third = Name "third" (Unique 12) + +test_patterns :: TestTree +test_patterns = + testGroup + "patterns" + [ testCase "single-alternative Data Constr tag/arity match captures fields left-to-right" $ + assertBothEvaluateTo (constantData $ PLC.I 2) captureTerm + , testCase "Match is built-in-only and does not match a UPLC Constr" $ + assertBothFail $ + matchSingle DefaultPatternWildcard (constantInteger 1) (UPLC.Constr () 0 []) + , testCase "ordered Match matches an arbitrary integer value" $ do + let term = + UPLC.Match + () + (constantInteger 42) + ( Vector.fromList + [ (DefaultPatternInteger 7, constantInteger 70) + , (DefaultPatternInteger 42, constantInteger 420) + , (DefaultPatternWildcard, constantInteger 0) + ] + ) + assertBothEvaluateTo (constantInteger 420) term + , testCase "ordered Match matches a nested Data structure" $ do + let scrutinee = constantData $ PLC.List [PLC.Constr 0 [PLC.I 1]] + term = + UPLC.Match + () + scrutinee + ( Vector.fromList + [ (dataConstrPattern 99 [], constantInteger 99) + , (nestedDataPattern, constantInteger 42) + , (DefaultPatternWildcard, constantInteger 0) + ] + ) + assertBothEvaluateTo (constantInteger 42) term + , testCase "ordered Match falls through to a wildcard" $ do + let term = + UPLC.Match + () + (constantData $ PLC.B "not the nested value") + ( Vector.fromList + [ (nestedDataPattern, constantInteger 42) + , (DefaultPatternWildcard, constantInteger 7) + ] + ) + assertBothEvaluateTo (constantInteger 7) term + , testCase "Data Map patterns expose entries as built-in pairs" $ do + let entryPattern = + pairPattern + (dataIPattern $ DefaultPatternInteger 1) + (dataBPattern $ DefaultPatternByteString "value") + mapPattern = patternChildren DefaultPatternDataMap [entryPattern] + term = + UPLC.Match + () + (constantData $ PLC.Map [(PLC.I 1, PLC.B "value")]) + ( Vector.fromList + [ (mapPattern, constantInteger 1) + , (DefaultPatternWildcard, constantInteger 0) + ] + ) + assertBothEvaluateTo (constantInteger 1) term + , testCase "built-in list patterns match an exact length" $ do + let captured = Name "captured" (Unique 3) + handler = UPLC.LamAbs () captured $ UPLC.Var () captured + term = + UPLC.Match + () + (mkConstant @[Integer] () [1, 2, 3]) + ( Vector.fromList + [ + ( patternChildren + DefaultPatternList + [DefaultPatternWildcard, DefaultPatternCapture, DefaultPatternWildcard] + , handler + ) + , (DefaultPatternWildcard, constantInteger 0) + ] + ) + assertBothEvaluateTo (constantInteger 2) term + , testCase "nested captures are supplied depth-first and left-to-right" $ do + let term selected = + matchSingle nestedCapturePattern (selectCaptureHandler selected) nestedCaptureScrutinee + assertBothEvaluateTo (constantInteger 11) $ term 0 + assertBothEvaluateTo (constantData $ PLC.I 22) $ term 1 + assertBothEvaluateTo (mkConstant @BS.ByteString () "abc") $ term 2 + , testCase "single-alternative Data Constr match rejects the wrong arity" $ do + let wrongArity = constantData $ PLC.Constr 1 [PLC.I 1, PLC.I 2] + assertBothFail $ matchSingle capturePattern captureHandler wrongArity + , testCase "deep matching exhausts incrementally without stack overflow" $ do + let depth :: Int + depth = 100000 + deepPattern = + foldl' + (\pat _ -> patternChildren DefaultPatternDataList [pat]) + DefaultPatternWildcard + [1 .. depth] + deepData = + foldl' + (\value _ -> PLC.List [value]) + (PLC.I 0) + [1 .. depth] + -- Force the synthetic generators before entering either CEK. A Flat-decoded script already + -- has these structures; charging arbitrary caller-supplied Haskell thunks is out of scope. + deepPattern `seq` + deepData `seq` + assertBothRunOutOfBudget + (matchSingle deepPattern (constantInteger 0) (constantData deepData)) + , testCase "wide all-wildcard matches do not require an uncharged flattening pass" $ do + let width = 10000 + pat = patternChildren DefaultPatternList $ replicate width DefaultPatternWildcard + term = matchSingle pat (constantInteger 1) $ mkConstant @[Integer] () (replicate width 0) + assertBothEvaluateTo (constantInteger 1) term + , testCase "a fixed-point loop repeatedly matching a wide pattern exhausts promptly" $ do + let width = 2048 + self = Name "self" (Unique 4000) + pat = patternChildren DefaultPatternList $ replicate width DefaultPatternWildcard + scrutinee = mkConstant @[Integer] () $ replicate width 0 + loopBody = + matchSingle + pat + (UPLC.Apply () (UPLC.Var () self) (UPLC.Var () self)) + scrutinee + loop = UPLC.LamAbs () self loopBody + assertBothRunOutOfBudget $ UPLC.Apply () loop loop + , testCase "an early list child mismatch ignores the remaining values" $ do + let width = 10000 + pat = + patternChildren DefaultPatternList $ + DefaultPatternInteger 1 : replicate width (DefaultPatternInteger 0) + term = + UPLC.Match + () + (mkConstant @[Integer] () $ replicate (width + 1) 0) + ( Vector.fromList + [ (pat, constantInteger 0) + , (DefaultPatternWildcard, constantInteger 1) + ] + ) + assertBothEvaluateTo (constantInteger 1) term + , testCase "over-wide exact lists reject before visiting an unreachable child" $ do + let depth :: Int + depth = 10000 + deepPattern = + foldl' + (\pat _ -> patternChildren DefaultPatternDataList [pat]) + DefaultPatternWildcard + [1 .. depth] + deepData = + foldl' + (\value _ -> PLC.List [value]) + (PLC.I 0) + [1 .. depth] + term childPattern childValue = + UPLC.Match + () + (mkConstant @[PLC.Data] () [childValue, PLC.I 1]) + ( Vector.fromList + [ (patternChildren DefaultPatternList [childPattern], constantInteger 0) + , (DefaultPatternWildcard, constantInteger 1) + ] + ) + shallowTerm = term DefaultPatternWildcard (PLC.I 0) + deepTerm = term deepPattern deepData + shallowBudget = ExBudget 4 0 + deepPattern `seq` deepData `seq` pure () + assertBothEvaluateTo (constantInteger 1) shallowTerm + assertBothEvaluateTo (constantInteger 1) deepTerm + patternBudget shallowTerm @?= shallowBudget + steppablePatternBudget shallowTerm @?= shallowBudget + patternBudget deepTerm @?= shallowBudget + steppablePatternBudget deepTerm @?= shallowBudget + , testCase "captured application rejects a deep non-functional handler without a cause" $ do + let depth :: Int + depth = 4096 + deepHandler = + foldl' + (\handler _ -> UPLC.Constr () 0 [handler]) + (UPLC.Constr () 0 []) + [1 .. depth] + term = matchSingle DefaultPatternCapture deepHandler (constantInteger 0) + deepHandler `seq` assertBothFailNonFunctionalWithoutCause term + , testCase "pattern work and synthetic capture applications are explicitly charged" $ do + let exactConstr n child = + matchSingle + (dataConstrPattern 1 $ replicate n child) + (constantInteger 0) + (constantData . PLC.Constr 1 $ replicate n (PLC.I 0)) + noCaptureTerm = exactConstr 3 DefaultPatternWildcard + matchNoCaptureTerm = + UPLC.Match + () + (constantData . PLC.Constr 1 $ replicate 3 (PLC.I 0)) + ( Vector.singleton + ( dataConstrPattern 1 $ replicate 3 DefaultPatternWildcard + , constantInteger 0 + ) + ) + patternBudget (exactConstr 0 DefaultPatternWildcard) @?= ExBudget 2 0 + patternBudget noCaptureTerm @?= ExBudget 5 0 + patternBudget captureTerm @?= ExBudget 11 0 + patternBudget matchNoCaptureTerm @?= ExBudget 5 0 + stepBudget Cek.BApply noCaptureTerm @?= ExBudget 0 0 + stepBudget Cek.BApply captureTerm @?= ExBudget 0 0 + , testCase "every reached capture is charged before alternative selection completes" $ do + let captured = Name "captured" (Unique 5000) + first = Name "first" (Unique 5001) + second = Name "second" (Unique 5002) + identityHandler = UPLC.LamAbs () captured $ UPLC.Var () captured + firstHandler = + UPLC.LamAbs () first $ UPLC.LamAbs () second $ UPLC.Var () first + secondHandler = + UPLC.LamAbs () first $ UPLC.LamAbs () second $ UPLC.Var () second + listMatch pats handler values = + matchSingle + (patternChildren DefaultPatternList pats) + handler + (mkConstant @[Integer] () values) + rootCapture = matchSingle DefaultPatternCapture identityHandler (constantInteger 0) + finalFieldCapture = listMatch [DefaultPatternCapture] identityHandler [0] + nonFinalFieldCapture = + listMatch + [DefaultPatternCapture, DefaultPatternWildcard] + identityHandler + [0, 1] + abandonedCaptures suffixWidth = + UPLC.Match + () + (mkConstant @[Integer] () $ replicate (3 + suffixWidth) 0) + ( Vector.fromList + [ + ( patternChildren DefaultPatternList $ + [DefaultPatternCapture, DefaultPatternCapture, DefaultPatternInteger 1] + <> replicate suffixWidth DefaultPatternCapture + , firstHandler + ) + , (DefaultPatternWildcard, constantInteger 1) + ] + ) + abandonedCaptureWithSuffix suffixWidth = + UPLC.Match + () + (mkConstant @[Integer] () $ replicate (2 + suffixWidth) 0) + ( Vector.fromList + [ + ( patternChildren DefaultPatternList $ + [DefaultPatternCapture, DefaultPatternInteger 1] + <> replicate suffixWidth DefaultPatternCapture + , identityHandler + ) + , (DefaultPatternWildcard, constantInteger 1) + ] + ) + resetCaptures = + UPLC.Match + () + (mkConstant @[Integer] () [10, 20]) + ( Vector.fromList + [ + ( patternChildren + DefaultPatternList + [DefaultPatternCapture, DefaultPatternInteger 99] + , identityHandler + ) + , + ( patternChildren + DefaultPatternList + [DefaultPatternCapture, DefaultPatternCapture] + , secondHandler + ) + ] + ) + assertPatternBudget expected term = do + patternBudget term @?= expected + steppablePatternBudget term @?= expected + assertBothEvaluateTo (constantInteger 0) rootCapture + assertBothEvaluateTo (constantInteger 0) finalFieldCapture + assertBothEvaluateTo (constantInteger 0) nonFinalFieldCapture + assertBothEvaluateTo (constantInteger 1) $ abandonedCaptures 0 + assertBothEvaluateTo (constantInteger 1) $ abandonedCaptures 1000 + assertBothEvaluateTo (constantInteger 1) $ abandonedCaptureWithSuffix 0 + assertBothEvaluateTo (constantInteger 1) $ abandonedCaptureWithSuffix 1000 + assertBothEvaluateTo (constantInteger 20) resetCaptures + assertPatternBudget (ExBudget 4 0) rootCapture + assertPatternBudget (ExBudget 5 0) finalFieldCapture + assertPatternBudget (ExBudget 6 0) nonFinalFieldCapture + assertPatternBudget (ExBudget 10 0) $ abandonedCaptures 0 + assertPatternBudget (ExBudget 10 0) $ abandonedCaptures 1000 + assertPatternBudget (ExBudget 7 0) $ abandonedCaptureWithSuffix 0 + assertPatternBudget (ExBudget 7 0) $ abandonedCaptureWithSuffix 1000 + , testCase "the pre-activation Match coefficients cap ledger-scale work" $ + case defaultParameters of + MachineParameters _ _ (MachineVariantParameters costs _) -> do + runIdentity (cekMatchCost costs) @?= ExBudget 210000 100 + runIdentity (cekPatternCost costs) @?= ExBudget 2500 100 + runIdentity (cekPatternStructuralCost costs) @?= ExBudget 27500 60 + runIdentity (cekPatternFailureCost costs) @?= ExBudget 32500 100 + , testCase "Data.Constr Match costs less than direct and checked UnConstrData" $ do + let assertCpuCheaper label candidateBudget baselineBudget = + case (candidateBudget, baselineBudget) of + (ExBudget candidateCpu _, ExBudget baselineCpu _) -> + assertBool + (label <> " CPU budget was not lower: " <> show (candidateBudget, baselineBudget)) + (candidateCpu < baselineCpu) + assertCheaper label candidate baseline = + case (totalBudget candidate, totalBudget baseline) of + ( candidateBudget@(ExBudget _ candidateMem) + , baselineBudget@(ExBudget _ baselineMem) + ) -> do + assertCpuCheaper label candidateBudget baselineBudget + assertBool + (label <> " memory budget was not lower: " <> show (candidateBudget, baselineBudget)) + (candidateMem < baselineMem) + expectedTraditional width = + ExBudget + (651396 + 64000 * fromIntegral width) + (3165 + 400 * fromIntegral width) + expectedDirectUnConstr width = + ExBudget + (317021 + 64000 * fromIntegral width) + (1633 + 400 * fromIntegral width) + expectedWildcards width = + ExBudget + (244600 + 27500 * fromIntegral width) + (500 + 60 * fromIntegral width) + expectedCaptures width = + ExBudget + (244600 + 48500 * fromIntegral width) + (500 + 360 * fromIntegral width) + mapM_ + ( \width -> do + let traditional = traditionalDataConstrMatch width + directUnConstr = traditionalUnConstrDataMatch width + wildcards = matchDataConstrWildcards width + captures = matchDataConstrCaptures width + suffix = " at width " <> show width + assertBothEvaluateTo (constantInteger 1) traditional + assertBothEvaluateTo (constantInteger 1) directUnConstr + assertBothEvaluateTo (constantInteger 1) wildcards + assertBothEvaluateTo (constantInteger 1) captures + totalBudget traditional @?= expectedTraditional width + totalBudget directUnConstr @?= expectedDirectUnConstr width + totalBudget wildcards @?= expectedWildcards width + totalBudget captures @?= expectedCaptures width + assertCheaper ("wildcard Match" <> suffix) wildcards traditional + assertCheaper ("capture Match" <> suffix) captures traditional + assertCheaper ("wildcard Match versus direct UnConstrData" <> suffix) wildcards directUnConstr + assertCheaper + ("capture Match versus direct UnConstrData" <> suffix) + captures + directUnConstr + ) + [0, 1, 3, 16] + , testCase "fixed-width integer and Data tag patterns have constant scalar cost" $ do + let integerTerm expected = + matchSingle + (DefaultPatternInteger expected) + (constantInteger 0) + (constantInteger $ toInteger expected) + smallBytes = "a" + largeBytes = BS.replicate 65 97 + bytesTerm bytes = + matchSingle + (DefaultPatternByteString bytes) + (constantInteger 0) + (mkConstant @BS.ByteString () bytes) + dataConstrTerm tag = + matchSingle + (dataConstrPattern tag []) + (constantInteger 0) + (constantData $ PLC.Constr (toInteger tag) []) + integerTerms = + [ integerTerm (minBound :: Int64) + , integerTerm 0 + , integerTerm (maxBound :: Int64) + ] + dataConstrTerms = + [dataConstrTerm 0, dataConstrTerm (maxBound :: Word64)] + mapM_ (\term -> patternBudget term @?= ExBudget 2 0) integerTerms + mapM_ (\term -> patternBudget term @?= ExBudget 2 0) dataConstrTerms + patternBudget (bytesTerm smallBytes) @?= ExBudget 3 0 + patternBudget (bytesTerm largeBytes) @?= ExBudget 11 0 + mapM_ + ( \term -> do + assertBothEvaluateTo (constantInteger 0) term + steppablePatternBudget term @?= patternBudget term + ) + (integerTerms <> dataConstrTerms) + , testCase "exact-list matching charges only the traversed prefix" $ do + let listPattern = patternChildren DefaultPatternList $ replicate 3 DefaultPatternWildcard + listTerm elements = + UPLC.Match + () + (mkConstant @[Integer] () elements) + ( Vector.fromList + [ (listPattern, constantInteger 0) + , (DefaultPatternWildcard, constantInteger 1) + ] + ) + assertBothEvaluateTo (constantInteger 1) $ listTerm [1, 2] + assertBothEvaluateTo (constantInteger 1) $ listTerm [1, 2, 3, 4] + assertBothEvaluateTo (constantInteger 0) $ listTerm [1, 2, 3] + patternBudget (listTerm [1, 2]) @?= ExBudget 5 0 + patternBudget (listTerm [1, 2, 3, 4]) @?= ExBudget 6 0 + patternBudget (listTerm [1, 2, 3]) @?= ExBudget 5 0 + , testCase "production and steppable CEK agree on Match and Apply budgets" $ do + let assertParity wanted term = + steppableStepBudget wanted term @?= stepBudget wanted term + assertPatternParity term = + steppablePatternBudget term @?= patternBudget term + matchTerm = + UPLC.Match + () + captureScrutinee + (Vector.singleton (capturePattern, captureHandler)) + shortBuiltinMatch = + UPLC.Match + () + (mkConstant @[Integer] () []) + ( Vector.fromList + [ + ( patternChildren DefaultPatternList $ replicate 8 DefaultPatternWildcard + , constantInteger 0 + ) + , (DefaultPatternWildcard, constantInteger 1) + ] + ) + assertPatternParity captureTerm + assertParity Cek.BApply captureTerm + assertPatternParity matchTerm + assertParity Cek.BApply matchTerm + assertBothEvaluateTo (constantInteger 1) shortBuiltinMatch + assertPatternParity shortBuiltinMatch + , testCase "direct pattern spending cannot pollute the BConst counter" $ do + let term = matchSingle DefaultPatternWildcard (constantInteger 1) (constantInteger 0) + assertBothEvaluateTo (constantInteger 1) term + stepBudget Cek.BConst term @?= ExBudget 2 0 + steppableStepBudget Cek.BConst term @?= ExBudget 2 0 + ] diff --git a/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs index 309b0244885..19249864cd7 100644 --- a/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Flat/Spec.hs @@ -12,23 +12,42 @@ import Codec.Serialise (serialise) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL import Data.Char (ord) +import Data.Vector qualified as Vector import Data.Word import PlutusCore.Data (Data) import PlutusCore.DeBruijn -import PlutusCore.Default (DefaultFun (..), DefaultUni (..)) +import PlutusCore.Default + ( DefaultBuiltinPattern (..) + , DefaultFun (..) + , DefaultUni (..) + ) import PlutusCore.Flat import PlutusCore.Flat.Bits (asBytes, bits) +import PlutusCore.FlatInstances (safeEncodeBits) import PlutusCore.Generators.QuickCheck.Builtin () import PlutusCore.Name.Unique (Name (..), TyName (..), Unique (..)) +import PlutusCore.Version (knownVersions, latestVersion, plcVersion110, plcVersion120) import Test.Cardano.Base.QuickCheck qualified as BaseQC import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck hiding (Some) +import Test.Tasty.QuickCheck hiding (Some, getSize) import Universe (Some (..), ValueOf (..)) import UntypedPlutusCore.Core.Type -- Also brings the Flat (Strict.Vector a) orphan instance into scope: -import UntypedPlutusCore (UnrestrictedProgram (..)) +import UntypedPlutusCore + ( UnrestrictedProgram (..) + , decodeProgram + , decodeTerm + ) + +-- | An encode-only value for exercising reserved Flat tags through the real decoders. +data RawTag = RawTag Int Word8 + +instance Flat RawTag where + encode (RawTag width tag) = safeEncodeBits width tag + decode = fail "RawTag is encode-only" + size (RawTag width _) n = width + n test_deBruijnIso :: TestTree test_deBruijnIso = testProperty "deBruijnIso" $ \d -> @@ -415,12 +434,233 @@ test_uplcProgramFlat = flatBytes (UnrestrictedProgram prog) @?= [1, 1, 0, 72, 0, 0] ] where - prog :: Program DeBruijn DefaultUni DefaultFun () = + prog :: Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () = Program () (Version 1 1 0) (Constant () (Some (ValueOf DefaultUniInteger (0 :: Integer)))) +test_patternProgramFlat :: TestTree +test_patternProgramFlat = + testGroup + "UPLC Match Programs" + [ testCase "version 1.2 match roundtrip" $ + let program = matchProg $ Version 1 2 0 + in unrestrictedDecode (flat $ UnrestrictedProgram program) @?= Right program + , testCase "all default built-in pattern descriptors roundtrip" $ + mapM_ + (\pat -> unflat (flat pat) @?= (Right pat :: Either DecodeException DefaultBuiltinPattern)) + [ DefaultPatternWildcard + , DefaultPatternCapture + , DefaultPatternInteger (-42) + , DefaultPatternInteger minBound + , DefaultPatternInteger maxBound + , DefaultPatternByteString "pattern-bytes" + , DefaultPatternBool True + , DefaultPatternUnit + , DefaultPatternList emptyChildren + , DefaultPatternPair + DefaultPatternWildcard + DefaultPatternCapture + , DefaultPatternDataConstr maxBound emptyChildren + , DefaultPatternDataMap emptyChildren + , DefaultPatternDataList emptyChildren + , DefaultPatternDataI Nothing + , DefaultPatternDataB Nothing + ] + , testCase "version 1.2 match stable encoding" $ + flatBytes (UnrestrictedProgram $ matchProg (Version 1 2 0)) + @?= [1, 2, 0, 164, 128, 3, 88, 0, 136, 144, 42, 65, 32, 0, 0] + , testCase "all default built-in pattern descriptors have stable encodings" $ + mapM_ + (\(pat, expected) -> flatBytes pat @?= expected) + [ (DefaultPatternWildcard, [0]) + , (DefaultPatternCapture, [16]) + , (DefaultPatternInteger 0, [32, 0]) + , (DefaultPatternByteString mempty, [49, 0]) + , (DefaultPatternBool False, [64]) + , (DefaultPatternUnit, [80]) + , (DefaultPatternList emptyChildren, [96]) + , + ( DefaultPatternPair + DefaultPatternWildcard + DefaultPatternCapture + , [112, 16] + ) + , (DefaultPatternDataConstr 0 emptyChildren, [128, 0]) + , (DefaultPatternDataConstr 1 emptyChildren, [128, 16]) + , (DefaultPatternDataMap emptyChildren, [144]) + , (DefaultPatternDataList emptyChildren, [160]) + , (DefaultPatternDataI Nothing, [176]) + , (DefaultPatternDataB Nothing, [192]) + ] + , testCase "match is rejected before version 1.2" $ do + assertUnrestrictedRejects "pre-1.2 match program" $ matchProg (Version 1 1 0) + , testCase "restricted decoder accepts match-alternative arity at its limit" $ + let withinLimit = wideMatchProg 3 + in restrictedDecode (flat $ UnrestrictedProgram withinLimit) @?= Right withinLimit + , testCase "restricted decoder rejects oversized match-alternative arity" $ + assertRestrictedRejects "oversized match alternative" $ + wideMatchProg 4 + , testCase "restricted decoder rejects unavailable built-in pattern descriptor" $ + assertPatternRestrictedRejects "unavailable built-in pattern descriptor" $ + matchProg (Version 1 2 0) + , testCase "reserved term tags are rejected" $ + mapM_ assertReservedTermTag [11 .. 15] + , testCase "reserved default built-in pattern tags are rejected" $ + mapM_ assertReservedDefaultPatternTag [13 .. 15] + , testCase "truncated built-in pattern descriptor payloads are rejected" $ + mapM_ + assertTruncatedDefaultPattern + [ DefaultPatternInteger maxBound + , DefaultPatternByteString $ BS.pack [1 .. 8] + , DefaultPatternDataConstr maxBound emptyChildren + ] + ] + where + emptyChildren = Vector.empty + + matchProg + :: Version + -> Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + matchProg version = Program () version matchBody + + nestedPattern :: DefaultBuiltinPattern + nestedPattern = + DefaultPatternDataList $ + Vector.singleton + ( DefaultPatternDataConstr + 0 + (Vector.singleton DefaultPatternCapture) + ) + + matchBody :: Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + matchBody = + Match + () + (Constant () $ Some (ValueOf DefaultUniInteger (0 :: Integer))) + ( Vector.fromList + [ (nestedPattern, Constant () $ Some (ValueOf DefaultUniInteger (42 :: Integer))) + , (DefaultPatternWildcard, Constant () $ Some (ValueOf DefaultUniInteger (0 :: Integer))) + ] + ) + + wideMatchProg + :: Int + -> Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + wideMatchProg childCount = + Program + () + (Version 1 2 0) + ( Match + () + (Constant () $ Some (ValueOf DefaultUniInteger (0 :: Integer))) + ( Vector.singleton + ( DefaultPatternList $ Vector.replicate childCount DefaultPatternWildcard + , Constant () $ Some (ValueOf DefaultUniInteger (0 :: Integer)) + ) + ) + ) + + unrestrictedDecode + :: BS.ByteString + -> Either + DecodeException + (Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) + unrestrictedDecode = fmap unUnrestrictedProgram . unflat + + restrictedDecode + :: BS.ByteString + -> Either + DecodeException + (Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) + restrictedDecode = + unflatWith $ + decodeProgram + (const Nothing) + (const Nothing) + (const Nothing) + (const checkPatternArity) + + patternRestrictedDecode + :: BS.ByteString + -> Either + DecodeException + (Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) + patternRestrictedDecode = + unflatWith $ + decodeProgram + (const Nothing) + (const Nothing) + (const Nothing) + (const checkPatternDescriptor) + + checkPatternArity (DefaultPatternList children) + | Vector.length children > 3 = + Just "pattern has too many children" + checkPatternArity _ = Nothing + + checkPatternDescriptor (DefaultPatternDataList _) = Just "data-list patterns are unavailable" + checkPatternDescriptor _ = Nothing + + assertUnrestrictedRejects description program = + case unrestrictedDecode . flat $ UnrestrictedProgram program of + Left _ -> pure () + Right result -> assertFailure $ "decoded a " <> description <> ": " <> show result + + assertRestrictedRejects description program = + case restrictedDecode . flat $ UnrestrictedProgram program of + Left _ -> pure () + Right result -> assertFailure $ "decoded an " <> description <> ": " <> show result + + assertPatternRestrictedRejects description program = + case patternRestrictedDecode . flat $ UnrestrictedProgram program of + Left _ -> pure () + Right result -> assertFailure $ "decoded an " <> description <> ": " <> show result + + assertReservedTermTag tag = + assertDecodeRejects + ("reserved term tag " <> show tag) + ( unflatWith + ( decodeTerm + (Version 1 2 0) + (const Nothing) + (const Nothing) + (const Nothing) + (const Nothing) + ) + (flat $ RawTag 4 tag) + :: Either + DecodeException + (Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) + ) + + assertReservedDefaultPatternTag tag = + assertDecodeRejects + ("reserved default built-in pattern tag " <> show tag) + ( unflat (flat $ RawTag 4 tag) + :: Either DecodeException DefaultBuiltinPattern + ) + + assertTruncatedDefaultPattern pat = + let encoded = flat pat + truncated = BS.take (BS.length encoded - 2) encoded + in assertDecodeRejects + ("truncated default built-in pattern " <> show pat) + (unflat truncated :: Either DecodeException DefaultBuiltinPattern) + + assertDecodeRejects description result = + case result of + Left _ -> pure () + Right value -> assertFailure $ "decoded " <> description <> ": " <> show value + +test_matchVersionRemainsExperimental :: TestTree +test_matchVersionRemainsExperimental = + testCase "Plutus Core 1.2 Match remains experimental" $ do + latestVersion @?= plcVersion110 + assertBool "Plutus Core 1.2 unexpectedly appears in knownVersions" $ + plcVersion120 `notElem` knownVersions + test_flat :: TestTree test_flat = testGroup @@ -434,6 +674,8 @@ test_flat = , test_binderStaticEncoding , test_binderNewtypeRoundtrip , test_uplcProgramFlat + , test_patternProgramFlat + , test_matchVersionRemainsExperimental , test_canonicalData , test_canonicalByteString , test_nonCanonicalByteStringDecoding diff --git a/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs index ac0126bfd94..f08f8d2ebc3 100644 --- a/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Generators/Spec.hs @@ -10,23 +10,29 @@ import PlutusPrelude (display, fold, getAnn, void, (&&&)) import Control.Lens (view) import Data.Text (Text) import Data.Text qualified as T +import Data.Vector qualified as Vector import Hedgehog (annotate, annotateShow, failure, property, tripping, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import PlutusCore (Name) import PlutusCore.Annotation (SrcSpan (..)) -import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Default + ( DefaultBuiltinPattern (..) + , DefaultFun + , DefaultUni + ) import PlutusCore.Error (ParserErrorBundle (ParseErrorB)) import PlutusCore.Flat (flat, unflat) import PlutusCore.Generators.Hedgehog (forAllPretty) import PlutusCore.Generators.Hedgehog.AST (runAstGen) +import PlutusCore.MkPlc (mkConstant) import PlutusCore.Parser (defaultUni, parseGen) import PlutusCore.Pretty (displayPlc) import PlutusCore.Quote (runQuoteT) import PlutusCore.Test (isSerialisable) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) import Test.Tasty.Hedgehog (testPropertyNamed) import Text.Megaparsec (errorBundlePretty) @@ -47,6 +53,7 @@ test_parsing = "Parsing" [ propFlat , propParser + , propMatchParser , propTermSrcSpan , propUnit , propDefaultUni @@ -79,9 +86,94 @@ propParser = testPropertyNamed "Parser" "parser" $ property $ do tripping prog displayPlc (fmap void . parseProg) where parseProg - :: T.Text -> Either ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan) + :: T.Text + -> Either + ParserErrorBundle + (Program Name DefaultUni DefaultFun DefaultBuiltinPattern SrcSpan) parseProg = runQuoteT . parseProgram +propMatchParser :: TestTree +propMatchParser = + testGroup + "Match classic parser" + [ testCase "version 1.2 roundtrip" $ do + let original = matchParserProgram $ UPLC.Version 1 2 0 + source = displayPlc original + assertBool ("expected classic Match syntax in: " <> T.unpack source) $ "(match" `T.isInfixOf` source + case runQuoteT $ parseProgram source of + Left err -> assertFailure $ display err + Right parsed -> void parsed @?= original + , testCase "fixed-width pattern boundaries roundtrip" $ do + let original = boundaryMatchParserProgram + case runQuoteT . parseProgram $ displayPlc original of + Left err -> assertFailure $ display err + Right parsed -> void parsed @?= original + , testCase "rejects Match before version 1.2" $ do + let source = displayPlc . matchParserProgram $ UPLC.Version 1 1 0 + case runQuoteT $ parseProgram source of + Left _ -> pure () + Right parsed -> assertFailure $ "parsed pre-1.2 Match program: " <> show parsed + , testCase "rejects integer patterns outside the Int64 range" $ do + assertMatchParseRejects $ + "(program 1.2.0 (match (con integer 0) " + <> "(pattern (integer 9223372036854775808) (con integer 0))))" + assertMatchParseRejects $ + "(program 1.2.0 (match (con integer 0) " + <> "(pattern (integer -9223372036854775809) (con integer 0))))" + , testCase "rejects Data.Constr pattern tags outside the Word64 range" $ do + assertMatchParseRejects $ + "(program 1.2.0 (match (con integer 0) " + <> "(pattern (data-constr -1) (con integer 0))))" + assertMatchParseRejects $ + "(program 1.2.0 (match (con integer 0) " + <> "(pattern (data-constr 18446744073709551616) (con integer 0))))" + ] + where + assertMatchParseRejects source = + case runQuoteT $ parseProgram source of + Left _ -> pure () + Right parsed -> assertFailure $ "parsed out-of-range Match pattern: " <> show parsed + +matchParserProgram + :: UPLC.Version + -> Program Name DefaultUni DefaultFun DefaultBuiltinPattern () +matchParserProgram version = + UPLC.Program + () + version + ( UPLC.Match + () + (mkConstant @[Integer] () [1]) + ( Vector.fromList + [ + ( DefaultPatternList $ Vector.singleton (DefaultPatternInteger 1) + , mkConstant @Integer () 42 + ) + , (DefaultPatternWildcard, mkConstant @Integer () 0) + ] + ) + ) + +boundaryMatchParserProgram + :: Program Name DefaultUni DefaultFun DefaultBuiltinPattern () +boundaryMatchParserProgram = + UPLC.Program + () + (UPLC.Version 1 2 0) + ( UPLC.Match + () + (mkConstant @Integer () 0) + ( Vector.fromList + [ (DefaultPatternInteger minBound, mkConstant @Integer () 0) + , (DefaultPatternInteger maxBound, mkConstant @Integer () 1) + , + ( DefaultPatternDataConstr maxBound Vector.empty + , mkConstant @Integer () 2 + ) + ] + ) + ) + -- | The `SrcSpan` of a parsed `Term` should not including trailing whitespaces. propTermSrcSpan :: TestTree propTermSrcSpan = testPropertyNamed diff --git a/plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs index d362c9d4b4f..c0e6ed24057 100644 --- a/plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Scoping/Spec.hs @@ -38,7 +38,7 @@ test_mangle = -- | Test equality of a program and its renamed version, given a renamer. prop_equalityFor - :: program ~ Program Name DefaultUni DefaultFun () + :: program ~ Program Name DefaultUni DefaultFun DefaultBuiltinPattern () => (program -> Quote program) -> Property prop_equalityFor ren = property $ do diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/CaseOfCase/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Transform/CaseOfCase/Spec.hs index 82d5a4955b4..a9b7de787b0 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/CaseOfCase/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/CaseOfCase/Spec.hs @@ -24,7 +24,7 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) import Test.Tasty.HUnit (testCase, (@?=)) import Transform.Lib (builtinTrue, case_, con, constr, err, ite, sopFalse, sopTrue, var) -import UntypedPlutusCore (DefaultFun, DefaultUni, Name, Term (..)) +import UntypedPlutusCore (DefaultBuiltinPattern, DefaultFun, DefaultUni, Name, Term (..)) import UntypedPlutusCore.Core qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek ( CekMachineCosts @@ -47,7 +47,7 @@ test_caseOfCase = , testCaseOfCaseWithError ] -caseOfCase1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +caseOfCase1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () caseOfCase1 = case_ (ite (var "b") sopTrue sopFalse) @@ -58,12 +58,12 @@ caseOfCase1 = {-| This should not simplify, because one of the branches of `ifThenElse` is not a `Constr`. Unless both branches are known constructors, the case-of-case transformation may increase the program size. -} -caseOfCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun () +caseOfCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () caseOfCase2 = case_ (ite (var "b") (var "t") sopFalse) [con 1, con 2] {-| Similar to `caseOfCase1`, but the type of the @true@ and @false@ branches is @[Integer]@ rather than Bool (note that @constr 0@ has two parameters, @x@ and @xs@). -} -caseOfCase3 :: Term Name PLC.DefaultUni PLC.DefaultFun () +caseOfCase3 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () caseOfCase3 = case_ (ite (var "b") (constr 0 [var "x", var "xs"]) sopFalse) @@ -85,7 +85,7 @@ After the `CaseOfCase` transformation the program should evaluate to `()` as wel @ force ((force ifThenElse) True (delay ()) (delay _|_)) @ -} -caseOfCaseWithError :: Term Name DefaultUni DefaultFun () +caseOfCaseWithError :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () caseOfCaseWithError = case_ (ite builtinTrue sopTrue sopFalse) [mkConstant @() () (), err] testCaseOfCaseWithError :: TestTree @@ -98,13 +98,13 @@ testCaseOfCaseWithError = -- Helper functions -------------------------------------------------------------------------------- evalCaseOfCase - :: Term Name DefaultUni DefaultFun () - -> Term Name DefaultUni DefaultFun () + :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () evalCaseOfCase term = evalOptimizer $ caseOfCase term evaluateUplc - :: UPLC.Term Name DefaultUni DefaultFun () - -> EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()) + :: UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> EvaluationResult (UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()) evaluateUplc = unsafeSplitStructuralOperational . fst <$> evaluateCek noEmitter machineParameters where costModel :: CostModel CekMachineCosts BuiltinCostModel @@ -114,9 +114,10 @@ evaluateUplc = unsafeSplitStructuralOperational . fst <$> evaluateCek noEmitter machineParameters :: DefaultMachineParameters machineParameters = -- TODO: proper semantic variant. What should def be? - MachineParameters def $ mkMachineVariantParameters def costModel + MachineParameters def def $ mkMachineVariantParameters def costModel -goldenVsSimplified :: String -> Term Name PLC.DefaultUni PLC.DefaultFun () -> TestTree +goldenVsSimplified + :: String -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> TestTree goldenVsSimplified testName = goldenVsString testName diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/EvaluateBuiltins/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Transform/EvaluateBuiltins/Spec.hs index a1a1bd226f8..2e189b4fabd 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/EvaluateBuiltins/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/EvaluateBuiltins/Spec.hs @@ -11,7 +11,7 @@ import PlutusPrelude (Default (def)) import Test.Tasty (TestTree, testGroup) import Transform.Lib (app, builtin, builtinTrue, con, force, ite, lam, text, var) import Transform.Simplify.Lib (goldenVsPretty) -import UntypedPlutusCore (DefaultFun, DefaultUni, Name, Term (..)) +import UntypedPlutusCore (DefaultBuiltinPattern, DefaultFun, DefaultUni, Name, Term (..)) import UntypedPlutusCore.Transform.EvaluateBuiltins (evaluateBuiltinsPass) import UntypedPlutusCore.Transform.Optimizer (evalOptimizer) @@ -36,46 +36,47 @@ test_evaluateBuiltins = , ("uncompressAndEqualBlsNonConservative", uncompressAndEqualBlsTerm) ] -goldenVsEvaluated :: Bool -> String -> Term Name DefaultUni DefaultFun () -> TestTree +goldenVsEvaluated + :: Bool -> String -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> TestTree goldenVsEvaluated conservative testName = goldenVsPretty ".golden.uplc" ("EvaluateBuiltins/" ++ testName) . runEvaluateBuiltins conservative runEvaluateBuiltins :: Bool - -> Term Name DefaultUni DefaultFun () - -> Term Name DefaultUni DefaultFun () + -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () runEvaluateBuiltins conservative = evalOptimizer . evaluateBuiltinsPass conservative def def -addIntegerTerm :: Term Name DefaultUni DefaultFun () +addIntegerTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () addIntegerTerm = builtin PLC.AddInteger `app` con 1 `app` con 2 -ifThenElseTerm :: Term Name DefaultUni DefaultFun () +ifThenElseTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () ifThenElseTerm = ite builtinTrue (con 1) (con 2) -- Used for both traceConservative (unchanged) and traceNonConservative (reduced to 1) -traceTerm :: Term Name DefaultUni DefaultFun () +traceTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () traceTerm = force (builtin PLC.Trace) `app` text "hello" `app` con 1 -- Division by zero; evaluates to error so should be left in place -failingBuiltinTerm :: Term Name DefaultUni DefaultFun () +failingBuiltinTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () failingBuiltinTerm = builtin PLC.DivideInteger `app` con 1 `app` con 0 -- The variable argument prevents evaluation -nonConstantArgTerm :: Term Name DefaultUni DefaultFun () +nonConstantArgTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () nonConstantArgTerm = builtin PLC.AddInteger `app` var "x" `app` con 2 -- ifThenElse returns a function (lambda), then applied to an extra argument -overApplicationTerm :: Term Name DefaultUni DefaultFun () +overApplicationTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () overApplicationTerm = ite builtinTrue (lam "x" (con 1)) (lam "x" (con 2)) `app` con 3 -- Missing an argument, should be left unchanged -underApplicationTerm :: Term Name DefaultUni DefaultFun () +underApplicationTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () underApplicationTerm = builtin PLC.AddInteger `app` con 1 -- In both conservative and non-conservative mode: left unchanged because the -- result (a G2 element) is an unserializable constant -uncompressBlsG2Term :: Term Name DefaultUni DefaultFun () +uncompressBlsG2Term :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () uncompressBlsG2Term = builtin PLC.Bls12_381_G2_uncompress `app` mkConstant @BS.ByteString () blsG2Bytes where @@ -87,7 +88,7 @@ uncompressBlsG2Term = -- In non-conservative mode: left unchanged because intermediate results -- (G1 elements) are unserializable, so we can't evaluate through them -uncompressAndEqualBlsTerm :: Term Name DefaultUni DefaultFun () +uncompressAndEqualBlsTerm :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () uncompressAndEqualBlsTerm = builtin PLC.Bls12_381_G1_equal `app` (builtin PLC.Bls12_381_G1_uncompress `app` blsG1BytesTerm) diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/Inline/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Transform/Inline/Spec.hs index 48ae193ad37..80f729f5b16 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/Inline/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/Inline/Spec.hs @@ -7,7 +7,7 @@ module Transform.Inline.Spec where import Control.Monad.Reader (runReaderT) import Control.Monad.State (runStateT) import PlutusCore.Annotation (Inline (MayInline)) -import PlutusCore.Default (DefaultFun (..), DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun (..), DefaultUni) import PlutusCore.Name.Unique (Name) import PlutusCore.Quote (runQuote) import PlutusPrelude (def) @@ -64,7 +64,7 @@ testVarBeforeAfterEffects = do assertBool "c is not evaluated before effects" $ not do isFirstVarBeforeEffects def (name "c") term where - term :: Term Name DefaultUni DefaultFun () + term :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () term = {- Evaluation order: @@ -85,7 +85,7 @@ testVarIsEventuallyEvaluatedDelay = do assertBool "it's not known if var 'c' is eventually evaluated" $ not (isStrictIn (name "c") term) where - term :: Term Name DefaultUni DefaultFun () + term :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () term = delay (var "a" `plus` var "b") `plus` var "b" testVarIsEventuallyEvaluatedLambda :: Assertion @@ -97,7 +97,7 @@ testVarIsEventuallyEvaluatedLambda = do assertBool "it's not known if var 'd' is eventually evaluated" $ not (isStrictIn (name "d") term) where - term :: Term Name DefaultUni DefaultFun () + term :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () term = lam "b" (var "a" `plus` var "c") `app` var "c" testVarIsEventuallyEvaluatedCaseBranch :: Assertion @@ -109,7 +109,7 @@ testVarIsEventuallyEvaluatedCaseBranch = do assertBool "it is not known if var 'd' is eventually evaluated" $ not (isStrictIn (name "d") term) where - term :: Term Name DefaultUni DefaultFun () + term :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () term = case_ (var "b") [var "a", var "b", var "c"] testEffectSafePreservedLogs :: Assertion @@ -119,7 +119,7 @@ testEffectSafePreservedLogs = do assertBool "a var before effects is \"effect safe\"" $ runInlineWithLogging (effectSafe term (name "a") False) where - term :: Term Name DefaultUni DefaultFun () + term :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () term = (var "a" `plus` var "b") `plus` var "c" testEffectSafeWithoutPreservedLogs :: Assertion @@ -129,19 +129,26 @@ testEffectSafeWithoutPreservedLogs = do assertBool "a var before effects is \"effect safe\"" $ runInlineWithoutLogging (effectSafe term (name "a") False) where - term :: Term Name DefaultUni DefaultFun () + term :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () term = (var "a" `plus` var "b") `plus` var "c" -------------------------------------------------------------------------------- -- InlineM runner -------------------------------------------------------------- -runInlineWithoutLogging :: InlineM Name DefaultUni DefaultFun () r -> r +runInlineWithoutLogging + :: InlineM Name DefaultUni DefaultFun DefaultBuiltinPattern () r + -> r runInlineWithoutLogging = runInlineM False -runInlineWithLogging :: InlineM Name DefaultUni DefaultFun () r -> r +runInlineWithLogging + :: InlineM Name DefaultUni DefaultFun DefaultBuiltinPattern () r + -> r runInlineWithLogging = runInlineM True -runInlineM :: Bool -> InlineM Name DefaultUni DefaultFun () r -> r +runInlineM + :: Bool + -> InlineM Name DefaultUni DefaultFun DefaultBuiltinPattern () r + -> r runInlineM preserveLogging m = result where (result, _finalState) = @@ -157,7 +164,7 @@ runInlineM preserveLogging m = result , _iiInlineCallsiteGrowth = AstSize 1_000_000 , _iiPreserveLogging = preserveLogging } - initialState :: S Name DefaultUni DefaultFun (Ann ()) + initialState :: S Name DefaultUni DefaultFun DefaultBuiltinPattern (Ann ()) initialState = S {_subst = Subst (TermEnv mempty), _vars = mempty} -------------------------------------------------------------------------------- diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/Lib.hs b/plutus-core/untyped-plutus-core/testlib/Transform/Lib.hs index 7fcdfccc580..d809df4cc19 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/Lib.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/Lib.hs @@ -30,7 +30,7 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Word (Word64) import GHC.Exts (fromList) -import PlutusCore.Default (DefaultFun (IfThenElse), DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun (IfThenElse), DefaultUni) import PlutusCore.MkPlc (mkConstant) import PlutusCore.Name.Unique (Name (..), Unique (..)) import UntypedPlutusCore.Core.Type (Term (..)) @@ -63,7 +63,7 @@ aliasing silently. -} -- | Convenient alias used throughout the test modules. -type T = Term Name DefaultUni DefaultFun () +type T = Term Name DefaultUni DefaultFun DefaultBuiltinPattern () {-| A 'Var' occurrence of the variable with the given name. See Note [Names from strings] -} diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Lib.hs b/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Lib.hs index 30b45b0a2d2..e070b31d480 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Lib.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Lib.hs @@ -39,7 +39,8 @@ goldenVsPretty extn name value = pure . BSL.fromStrict . encodeUtf8 . render $ prettyPlcReadableSimple value -goldenVsOptimized :: String -> Term Name PLC.DefaultUni PLC.DefaultFun () -> TestTree +goldenVsOptimized + :: String -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> TestTree goldenVsOptimized name t = testGroup name @@ -54,7 +55,14 @@ goldenVsOptimized name t = (t', trace) = PLC.runQuote (testOptimize t) hintsPath = "untyped-plutus-core/test/Transform/" ++ name ++ ".golden.certifier-hints" -renderCertifierHints :: Trace.OptimizerTrace Name PLC.DefaultUni PLC.DefaultFun () -> Text +renderCertifierHints + :: Trace.OptimizerTrace + Name + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () + -> Text renderCertifierHints (Trace.OptimizerTrace ss) | null ss = "" | otherwise = @@ -91,16 +99,20 @@ renderCertifierHints (Trace.OptimizerTrace ss) line i "InlCase" <> renderInlineHints (i + 2) scrut <> foldMap (renderInlineHints (i + 2)) alts + Hints.InlMatch scrut alternatives -> + line i "InlMatch" + <> renderInlineHints (i + 2) scrut + <> foldMap (renderInlineHints (i + 2)) alternatives Hints.InlExpand x -> line i "InlExpand" <> renderInlineHints (i + 2) x Hints.InlDrop x -> line i "InlDrop" <> renderInlineHints (i + 2) x line i payload = T.replicate i " " <> payload <> "\n" testOptimize - :: Term Name PLC.DefaultUni PLC.DefaultFun () + :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> PLC.Quote - ( Term Name PLC.DefaultUni PLC.DefaultFun () - , OptimizerTrace Name PLC.DefaultUni PLC.DefaultFun () + ( Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + , OptimizerTrace Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ) testOptimize = runOptimizerT @@ -117,7 +129,7 @@ testOptimize = goldenVsCse :: CseWhichSubterms -> String - -> Term Name PLC.DefaultUni PLC.DefaultFun () + -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> TestTree goldenVsCse whichSubterms name = goldenVsPretty ".golden.uplc" name @@ -127,10 +139,10 @@ goldenVsCse whichSubterms name = testCse :: CseWhichSubterms - -> Term Name PLC.DefaultUni PLC.DefaultFun () + -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> PLC.Quote - ( Term Name PLC.DefaultUni PLC.DefaultFun () - , OptimizerTrace Name PLC.DefaultUni PLC.DefaultFun () + ( Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + , OptimizerTrace Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ) testCse whichSubterms = runOptimizerT diff --git a/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Spec.hs b/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Spec.hs index 8ae04542499..4ada08a6e66 100644 --- a/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Spec.hs +++ b/plutus-core/untyped-plutus-core/testlib/Transform/Simplify/Spec.hs @@ -24,6 +24,7 @@ import Transform.Lib import Transform.Simplify.Lib (goldenVsCse, goldenVsOptimized) import UntypedPlutusCore ( CseWhichSubterms (..) + , DefaultBuiltinPattern , DefaultFun , DefaultUni , Name @@ -32,41 +33,41 @@ import UntypedPlutusCore ) import UntypedPlutusCore.MkUPlc (mkIterLamAbs) -basic :: Term Name PLC.DefaultUni PLC.DefaultFun () +basic :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () basic = force $ delay $ con 1 -nested :: Term Name PLC.DefaultUni PLC.DefaultFun () +nested :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () nested = force $ force $ delay $ delay $ con 1 -extraDelays :: Term Name PLC.DefaultUni PLC.DefaultFun () +extraDelays :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () extraDelays = force $ delay $ delay $ con 1 -interveningLambda :: Term Name PLC.DefaultUni PLC.DefaultFun () +interveningLambda :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () interveningLambda = force (lam "a" (delay (var "a" `app` var "a")) `app` con 1) -caseOfCase1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +caseOfCase1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () caseOfCase1 = case_ (ite (var "b") sopTrue sopFalse) [con 1, con 2] {-| This should not simplify, because one of the branches of `ifThenElse` is not a `Constr`. Unless both branches are known constructors, the case-of-case transformation may increase the program size. -} -caseOfCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun () +caseOfCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () caseOfCase2 = case_ (ite (var "b") (var "t") sopFalse) [con 1, con 2] {-| Similar to `caseOfCase1`, but the type of the @true@ and @false@ branches is @[Integer]@ rather than Bool (note that @Constr 0@ has two parameters, @x@ and @xs@). -} -caseOfCase3 :: Term Name PLC.DefaultUni PLC.DefaultFun () +caseOfCase3 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () caseOfCase3 = case_ (ite (var "b") trueBranch sopFalse) [var "f", con 2] where trueBranch = constr 0 [var "x", var "xs"] -- | The `Delay` should be floated into the lambda. -floatDelay1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +floatDelay1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () floatDelay1 = lam "a" (force (var "a") `plus` force (var "a")) `app` delay (con 1) {-| The `Delay` should not be floated into the lambda, because the argument (1 + 2) is not work-free. -} -floatDelay2 :: Term Name PLC.DefaultUni PLC.DefaultFun () +floatDelay2 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () floatDelay2 = lam "a" (force (var "a") `plus` force (var "a")) `app` delay (con 1 `plus` con 2) @@ -74,19 +75,19 @@ floatDelay2 = {-| The `Delay` should not be floated into the lambda in the first simplifier iteration, because one of the occurrences of `a` is not under `Force`. It should be floated into the lambda in the second simplifier iteration, after `b` is inlined. -} -floatDelay3 :: Term Name PLC.DefaultUni PLC.DefaultFun () +floatDelay3 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () floatDelay3 = lam "a" (force (var "a") `plus` force (lam "b" (var "b") `app` var "a")) `app` delay (con 1) {-| The 'Delay' should not be floated into the lambda because the argument to the 'Delay' is not pure. -} -floatDelay4 :: Term Name PLC.DefaultUni PLC.DefaultFun () +floatDelay4 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () floatDelay4 = lam "a" body `app` delay (constr 0 [err]) where body = case_ (constr 0 []) [con 1, force (var "a")] -basicInline :: Term Name PLC.DefaultUni PLC.DefaultFun () +basicInline :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () basicInline = lam "a" (var "a") `app` con 1 {-| A helper function to create a term which tests whether the inliner @@ -95,22 +96,22 @@ together with a list of its free variables. The free variables are bound at the top level of the final term in order to ensure that the produced final term is well-scoped. -} mkInlinePurityTest - :: ([Name], Term Name PLC.DefaultUni PLC.DefaultFun ()) - -> Term Name PLC.DefaultUni PLC.DefaultFun () + :: ([Name], Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ()) + -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () mkInlinePurityTest (freeVars, term) = -- In `[(\a . \b . a) term]`, `term` will be inlined if and only if it is pure. mkIterLamAbs (UVarDecl () <$> freeVars) $ lam "a" (lam "b" (var "a")) `app` term -- | A single @Var@ is pure. -inlinePure1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +inlinePure1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () inlinePure1 = mkInlinePurityTest ([name "a"], var "a") {-| @force (delay a)@ is pure. Note that this relies on @forceDelayCancel@ to cancel the @force@ and the @delay@, otherwise the inliner would treat the term as impure. -} -inlinePure2 :: Term Name PLC.DefaultUni PLC.DefaultFun () +inlinePure2 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () inlinePure2 = mkInlinePurityTest ([name "a"], force $ delay (var "a")) {-| @[(\x -> \y -> [x x]) (con integer 1)]@ is pure. @@ -118,7 +119,7 @@ inlinePure2 = mkInlinePurityTest ([name "a"], force $ delay (var "a")) Note that the @(con integer 1)@ won't get inlined: it isn't pre-inlined because @x@ occurs twice, and it isn't post-inlined because @costIsAcceptable Constant{} = False@. However, the entire term will be inlined since it is pure. -} -inlinePure3 :: Term Name PLC.DefaultUni PLC.DefaultFun () +inlinePure3 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () inlinePure3 = mkInlinePurityTest ([], app (lam "x" $ lam "y" $ var "x" `app` var "x") (con 1)) @@ -126,7 +127,7 @@ inlinePure3 = {-| @force ([(\x -> delay (\y -> [x x])) (delay ([error (con integer 1)]))])@ is pure, but it is very tricky to see so. It requires us to match up a force and a delay through several steps of intervening computation. -} -inlinePure4 :: Term Name PLC.DefaultUni PLC.DefaultFun () +inlinePure4 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () inlinePure4 = mkInlinePurityTest ( [] @@ -136,22 +137,22 @@ inlinePure4 = ) -- | @error@ is impure. -inlineImpure1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +inlineImpure1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () inlineImpure1 = mkInlinePurityTest ([], err) -- | @force (delay error)@ is impure. -inlineImpure2 :: Term Name PLC.DefaultUni PLC.DefaultFun () +inlineImpure2 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () inlineImpure2 = mkInlinePurityTest ([], force (delay err)) {-| @force (force (force (delay (delay (delay (error))))))@ is impure, since it is the same as @error@. -} -inlineImpure3 :: Term Name PLC.DefaultUni PLC.DefaultFun () +inlineImpure3 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () inlineImpure3 = mkInlinePurityTest ([], force . force . force . delay . delay $ delay err) {-| @force (force (force (delay (delay a))))@ is impure, since @a@ may expand to an impure term such as @error@. -} -inlineImpure4 :: Term Name PLC.DefaultUni PLC.DefaultFun () +inlineImpure4 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () inlineImpure4 = mkInlinePurityTest ( [name "a"] @@ -165,7 +166,7 @@ the size or the cost. The second occurrence of `a` should be unconditionally inlined in the second simplifier iteration, but in this test we are only running one iteration. -} -callsiteInline :: Term Name PLC.DefaultUni PLC.DefaultFun () +callsiteInline :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () callsiteInline = lam "f" $ lam "g" $ app fun arg where fun = @@ -179,7 +180,7 @@ callsiteInline = lam "f" $ lam "g" $ app fun arg lam "x" . lam "y" $ mkIterAppNoAnn (var "g") [var "y", var "x"] -multiApp :: Term Name PLC.DefaultUni PLC.DefaultFun () +multiApp :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () multiApp = mkIterAppNoAnn applyLam [con 1, con 2, con 3] where applyLam = @@ -188,10 +189,10 @@ multiApp = mkIterAppNoAnn applyLam [con 1, con 2, con 3] lam "c" $ mkIterAppNoAnn (var "c") [var "a", var "b"] -forceDelayNoApps :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceDelayNoApps :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceDelayNoApps = force $ delay $ force $ delay $ force $ delay $ con 1 -forceDelayNoAppsLayered :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceDelayNoAppsLayered :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceDelayNoAppsLayered = force $ force $ force $ delay $ delay $ delay $ con 1 {-| The UPLC term in this test should come from the following TPLC term after erasing its types: @@ -201,14 +202,14 @@ forceDelayNoAppsLayered = force $ force $ force $ delay $ delay $ delay $ con 1 This case is simple in the sense that each type abstraction is followed by a single term abstraction. -} -forceDelaySimple :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceDelaySimple :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceDelaySimple = force (force (force t `app` con 1) `app` con 2) `app` con 3 where t = delay (lam "x" (delay (lam "y" (delay (lam "z" (var "z")))))) {-| A test for the case when there are multiple applications between the 'Force' at the top and the 'Delay' at the top of the term inside the abstractions/applications. -} -forceDelayMultiApply :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceDelayMultiApply :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceDelayMultiApply = lam "funcVar" $ force $ @@ -224,7 +225,7 @@ forceDelayMultiApply = {-| A test for the case when there are multiple type abstractions over a single term abstraction/application. -} -forceDelayMultiForce :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceDelayMultiForce :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceDelayMultiForce = force $ force $ force $ app (lam "x" $ delay $ delay $ delay (var "x")) (con 1) @@ -239,7 +240,7 @@ forceDelayMultiForce = > (funcVar : Int -> Int -> String -> String -> Int -> String) Note this term has multiple interleaved type and term instantiations/applications. -} -forceDelayComplex :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceDelayComplex :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceDelayComplex = whole where term = @@ -285,29 +286,29 @@ forceDelayComplex = whole ) (var "funcVar") -forceCaseDelayNoApps1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceCaseDelayNoApps1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceCaseDelayNoApps1 = lam "scrut" $ force $ case_ (var "scrut") [delay (con 1)] -forceCaseDelayWithApps1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceCaseDelayWithApps1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceCaseDelayWithApps1 = lam "scrut" $ force $ case_ (var "scrut") [lam "x" $ delay (con 1)] -forceCaseDelayNoApps2 :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceCaseDelayNoApps2 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceCaseDelayNoApps2 = lam "scrut" $ force $ case_ (var "scrut") [delay (con 1), delay (con 2)] -forceCaseDelayWithApps2 :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceCaseDelayWithApps2 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceCaseDelayWithApps2 = lam "scrut" $ force $ case_ (var "scrut") [lam "x" $ delay (con 1), delay (con 2)] -forceCaseDelayNoApps2Fail :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceCaseDelayNoApps2Fail :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceCaseDelayNoApps2Fail = lam "scrut" $ force $ case_ (var "scrut") [delay (con 1), con 2] -forceCaseDelayWithApps2Fail :: Term Name PLC.DefaultUni PLC.DefaultFun () +forceCaseDelayWithApps2Fail :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () forceCaseDelayWithApps2Fail = lam "scrut" $ force $ @@ -318,25 +319,25 @@ forceCaseDelayWithApps2Fail = ] -- case ((\x -> constr 0 []) 1) [42] -letFloatOutCase1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +letFloatOutCase1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () letFloatOutCase1 = case_ (lam "x" sopTrue `app` con 1) [con 42] -- \a -> case ((\x -> constr 0 [x, x]) a) addInteger -letFloatOutCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun () +letFloatOutCase2 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () letFloatOutCase2 = lam "a" $ case_ binding [builtin PLC.AddInteger] where body = constr 0 [var "x", var "x"] binding = lam "x" body `app` var "a" -- \a -> force ((\x -> delay x) a) -letFloatOutForce :: Term Name PLC.DefaultUni PLC.DefaultFun () +letFloatOutForce :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () letFloatOutForce = lam "a" (force binding) where delayLam = lam "x" (delay (var "x")) binding = delayLam `app` var "a" -- | This is the first example in Note [CSE]. -cse1 :: Term Name PLC.DefaultUni PLC.DefaultFun () +cse1 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () cse1 = lam "x" (lam "y" (plus onePlusTwoPlusX caseExpr)) where twoPlusX = plus (con 2) (var "x") @@ -349,7 +350,7 @@ cse1 = lam "x" (lam "y" (plus onePlusTwoPlusX caseExpr)) caseExpr = case_ (var "y") [branch1, branch2, branch3] -- | This is the second example in Note [CSE]. -cse2 :: Term Name DefaultUni DefaultFun () +cse2 :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () cse2 = force (force body) where body = mkIterApp (builtin PLC.IfThenElse) [((), cond), ((), trueBranch), ((), falseBranch)] @@ -358,7 +359,7 @@ cse2 = force (force body) falseBranch = delay (plus (con 1) (con 2)) -- | This is the third example in Note [CSE]. -cse3 :: Term Name PLC.DefaultUni PLC.DefaultFun () +cse3 :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () cse3 = lam "f" $ lam "x" $ var "f" `app` arg1 `app` arg2 where arg1 = @@ -371,13 +372,13 @@ cse3 = lam "f" $ lam "x" $ var "f" `app` arg1 `app` arg2 -- ((1+2) + (3+4) + ...) -- + -- ((1+2) + (3+4) + ...) -cseExpensive :: Term Name DefaultUni DefaultFun () +cseExpensive :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () cseExpensive = mkArg [0 .. 200] `plus` mkArg [0 .. 200] where mkArg = foldl1 plus . map (\i -> plus (con (2 * i)) (con (2 * i + 1))) -- tree where nodes are + and leaves are constants -csePlusTree :: Term Name DefaultUni DefaultFun () +csePlusTree :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () csePlusTree = go 5 where go :: Int -> T @@ -387,14 +388,15 @@ csePlusTree = go 5 -- (1 + (1 + ... + 0)) -- optimised to -- let f = (1 +) in f (f (... 0)) -cseRepeatPlus :: Term Name DefaultUni DefaultFun () +cseRepeatPlus :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () cseRepeatPlus = go 5 where go :: Int -> T go 0 = con 0 go n = plus (con 1) (go (n - 1)) -testSimplifyInputs :: [(String, Term Name PLC.DefaultUni PLC.DefaultFun ())] +testSimplifyInputs + :: [(String, Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ())] testSimplifyInputs = [ ("basic", basic) , ("nested", nested) @@ -432,7 +434,7 @@ testSimplifyInputs = , ("letFloatOutForce", letFloatOutForce) ] -testCseInputs :: [(String, Term Name PLC.DefaultUni PLC.DefaultFun ())] +testCseInputs :: [(String, Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ())] testCseInputs = [ ("cse1", cse1) , ("cse2", cse2) @@ -440,7 +442,8 @@ testCseInputs = , ("cseExpensive", cseExpensive) ] -testCseInputsWorkFree :: [(String, Term Name PLC.DefaultUni PLC.DefaultFun ())] +testCseInputsWorkFree + :: [(String, Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ())] testCseInputsWorkFree = [ ("cse1WorkFree", cse1) , ("csePlusTree", csePlusTree) diff --git a/plutus-tx/testlib/PlutusTx/Test/Golden.hs b/plutus-tx/testlib/PlutusTx/Test/Golden.hs index d48daf07a98..5a53958203f 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Golden.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Golden.hs @@ -146,8 +146,8 @@ goldenBudget name compiledCode = do goldenBundle :: TestName - -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun a - -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun b + -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun PLC.DefaultBuiltinPattern a + -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun PLC.DefaultBuiltinPattern b -> TestNested goldenBundle name x y = do goldenPirReadable name x @@ -156,7 +156,7 @@ goldenBundle name x y = do goldenBundle' :: TestName - -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun a + -> CompiledCodeIn UPLC.DefaultUni UPLC.DefaultFun PLC.DefaultBuiltinPattern a -> TestNested goldenBundle' name x = goldenBundle name x x @@ -164,7 +164,7 @@ goldenBundle' name x = goldenBundle name x x goldenPir :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) => TestName - -> CompiledCodeIn uni fun a + -> CompiledCodeIn uni fun pat a -> TestNested goldenPir name value = nestedGoldenVsDoc name ".pir" @@ -177,7 +177,7 @@ goldenPir name value = goldenPirReadable :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) => TestName - -> CompiledCodeIn uni fun a + -> CompiledCodeIn uni fun pat a -> TestNested goldenPirReadable name value = nestedGoldenVsDoc name ".pir" @@ -192,7 +192,7 @@ change if all uniques are printed. It is nonetheless useful sometimes. -} goldenPirReadableU :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) => TestName - -> CompiledCodeIn uni fun a + -> CompiledCodeIn uni fun pat a -> TestNested goldenPirReadableU name value = nestedGoldenVsDoc name ".pir" @@ -203,13 +203,13 @@ goldenPirBy :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) => PrettyConfigClassic PrettyConfigName -> TestName - -> CompiledCodeIn uni fun a + -> CompiledCodeIn uni fun pat a -> TestNested goldenPirBy config name value = nestedGoldenVsDoc name ".pir" $ prettyBy config $ getPir value goldenEvalCek - :: ToUPlc a PLC.DefaultUni PLC.DefaultFun + :: ToUPlc a PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern => TestName -> a -> TestNested @@ -218,7 +218,7 @@ goldenEvalCek name value = prettyPlcClassicSimple <$> rethrow (runPlcCek value) goldenEvalCekCatch - :: ToUPlc a PLC.DefaultUni PLC.DefaultFun + :: ToUPlc a PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern => TestName -> a -> TestNested goldenEvalCekCatch name value = nestedGoldenVsDocM name ".eval" $ @@ -239,7 +239,7 @@ goldenEvalCekCatchBudget name compiledCode = pure (render @Text contents) goldenEvalCekLog - :: ToUPlc a PLC.DefaultUni PLC.DefaultFun + :: ToUPlc a PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern => TestName -> a -> TestNested goldenEvalCekLog name value = nestedGoldenVsDocM name ".eval" $ @@ -262,7 +262,9 @@ of bytes when the given program serialized into bytestring using binary flat enc Cost of storing smart contract onchain is partially determined by the Flat size. So it is useful to have Flat size measurement in case we adopt new or introduce optimizations to the flat encoding format. -} -prettyCodeSize :: CompiledCodeIn PLC.DefaultUni PLC.DefaultFun a -> Doc ann +prettyCodeSize + :: CompiledCodeIn PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern a + -> Doc ann prettyCodeSize compiledCode = vsep [ fill 10 "AST Size:" <+> prettyIntRightAligned astSize diff --git a/plutus-tx/testlib/PlutusTx/Test/Orphans.hs b/plutus-tx/testlib/PlutusTx/Test/Orphans.hs index 30d19d85ae5..d491c15afba 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Orphans.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Orphans.hs @@ -25,8 +25,8 @@ import PlutusCore.Flat (Flat) import Test.Tasty.Extras () instance - (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) - => ToUPlc (CompiledCodeIn uni fun a) uni fun + (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun, Flat pat) + => ToUPlc (CompiledCodeIn uni fun pat a) uni fun pat where toUPlc compiledCode = toUPlc =<< catchAll (getPlcNoAnn compiledCode) @@ -44,7 +44,7 @@ instance , Default (PIR.BuiltinsInfo uni fun) , Default (PIR.RewriteRules uni fun) ) - => ToTPlc (CompiledCodeIn uni fun a) uni fun + => ToTPlc (CompiledCodeIn uni fun pat a) uni fun where toTPlc compiledCode = catchAll (getPir compiledCode) >>= \case diff --git a/plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs b/plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs index 001273009dc..ed9727c0e45 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Run/Uplc.hs @@ -24,15 +24,21 @@ import Test.Tasty.Extras () import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek qualified as UPLC -type Term = UPLC.Term PLC.Name DefaultUni DefaultFun () +type Term = UPLC.Term PLC.Name DefaultUni DefaultFun PLC.DefaultBuiltinPattern () runPlcCek - :: ToUPlc a PLC.DefaultUni PLC.DefaultFun + :: ToUPlc a PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern => a -> ExceptT SomeException IO - (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) + ( UPLC.Term + PLC.Name + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () + ) runPlcCek val = do term <- toUPlc val fromRightM (throwError . SomeException) $ @@ -41,14 +47,14 @@ runPlcCek val = do (term ^. UPLC.progTerm) runPlcCekTrace - :: ToUPlc a PLC.DefaultUni PLC.DefaultFun + :: ToUPlc a PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern => a -> ExceptT SomeException IO ( [Text] , UPLC.CekExTally PLC.DefaultFun - , UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun () + , UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ) runPlcCekTrace value = do term <- toUPlc value @@ -62,12 +68,14 @@ runPlcCekTrace value = do pure (logOut, tally, res) runPlcCekBudget - :: ToUPlc a PLC.DefaultUni PLC.DefaultFun + :: ToUPlc a PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern => a -> ExceptT SomeException IO - (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun (), PLC.ExBudget) + ( UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + , PLC.ExBudget + ) runPlcCekBudget val = do term <- toUPlc val fromRightM (throwError . SomeException) $ do diff --git a/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs b/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs index 8d8e9534756..9b9a22fb4c4 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Util/Apply.hs @@ -21,42 +21,46 @@ import PlutusCore.Pretty (Pretty, PrettyBy, PrettyConst, RenderContext) import PlutusTx.Code type family CompiledCodeFuncToHaskType t r where - CompiledCodeFuncToHaskType (CompiledCodeIn uni fun (a -> b)) r = - CompiledCodeIn uni fun a -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun b) r - CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) r = r + CompiledCodeFuncToHaskType (CompiledCodeIn uni fun pat (a -> b)) r = + CompiledCodeIn uni fun pat a + -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun pat b) r + CompiledCodeFuncToHaskType (CompiledCodeIn uni fun pat a) r = r type family FinalType t where FinalType (a -> b) = FinalType b FinalType a = a -class CompiledCodeFuncToHask t r uni fun where +class CompiledCodeFuncToHask t r uni fun pat where applyCodeN' - :: (Either String (CompiledCodeIn uni fun (FinalType t)) -> r) - -> Either String (CompiledCodeIn uni fun t) - -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun t) r + :: (Either String (CompiledCodeIn uni fun pat (FinalType t)) -> r) + -> Either String (CompiledCodeIn uni fun pat t) + -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun pat t) r instance {-# OVERLAPPING #-} ( PLC.Everywhere uni Flat , PLC.Everywhere uni PrettyConst , PLC.Closed uni + , Flat pat , Flat fun , Pretty fun , PrettyBy RenderContext (PLC.SomeTypeIn uni) - , CompiledCodeFuncToHask b r uni fun - , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun (a -> b)) r - ~ (CompiledCodeIn uni fun a -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun b) r) + , CompiledCodeFuncToHask b r uni fun pat + , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun pat (a -> b)) r + ~ ( CompiledCodeIn uni fun pat a + -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun pat b) r + ) ) - => CompiledCodeFuncToHask (a -> b) r uni fun + => CompiledCodeFuncToHask (a -> b) r uni fun pat where applyCodeN' cont f a = applyCodeN' @b @r cont $ f >>= flip applyCode a instance ( FinalType a ~ a - , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) r ~ r + , CompiledCodeFuncToHaskType (CompiledCodeIn uni fun pat a) r ~ r ) - => CompiledCodeFuncToHask a r uni fun + => CompiledCodeFuncToHask a r uni fun pat where applyCodeN' = ($) @@ -70,28 +74,40 @@ baz :: CompiledCode () applyCodeN foo bar baz :: Either String (CompiledCode Bool) ``` -} applyCodeN - :: forall uni fun a - . CompiledCodeFuncToHask a (Either String (CompiledCodeIn uni fun (FinalType a))) uni fun - => CompiledCodeIn uni fun a + :: forall uni fun pat a + . CompiledCodeFuncToHask + a + (Either String (CompiledCodeIn uni fun pat (FinalType a))) + uni + fun + pat + => CompiledCodeIn uni fun pat a -> CompiledCodeFuncToHaskType - (CompiledCodeIn uni fun a) - (Either String (CompiledCodeIn uni fun (FinalType a))) + (CompiledCodeIn uni fun pat a) + (Either String (CompiledCodeIn uni fun pat (FinalType a))) applyCodeN = applyCodeN' @a - @(Either String (CompiledCodeIn uni fun (FinalType a))) + @(Either String (CompiledCodeIn uni fun pat (FinalType a))) id . pure -- | Same as 'applyCodeN' but is partial instead of returning `Either String`. unsafeApplyCodeN - :: forall uni fun a - . CompiledCodeFuncToHask a (CompiledCodeIn uni fun (FinalType a)) uni fun - => CompiledCodeIn uni fun a - -> CompiledCodeFuncToHaskType (CompiledCodeIn uni fun a) (CompiledCodeIn uni fun (FinalType a)) + :: forall uni fun pat a + . CompiledCodeFuncToHask + a + (CompiledCodeIn uni fun pat (FinalType a)) + uni + fun + pat + => CompiledCodeIn uni fun pat a + -> CompiledCodeFuncToHaskType + (CompiledCodeIn uni fun pat a) + (CompiledCodeIn uni fun pat (FinalType a)) unsafeApplyCodeN = applyCodeN' @a - @(CompiledCodeIn uni fun (FinalType a)) + @(CompiledCodeIn uni fun pat (FinalType a)) (either error id) . pure diff --git a/plutus-tx/testlib/PlutusTx/Test/Util/Compiled.hs b/plutus-tx/testlib/PlutusTx/Test/Util/Compiled.hs index 6fa417e6f44..6f9302d57c6 100644 --- a/plutus-tx/testlib/PlutusTx/Test/Util/Compiled.hs +++ b/plutus-tx/testlib/PlutusTx/Test/Util/Compiled.hs @@ -27,8 +27,8 @@ import PlutusTx.Code (CompiledCode, getPlcNoAnn) import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek as Cek -type Term = UPLC.Term PLC.NamedDeBruijn DefaultUni DefaultFun () -type Program = UPLC.Program PLC.NamedDeBruijn DefaultUni DefaultFun () +type Term = UPLC.Term PLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () +type Program = UPLC.Program PLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () {-| The size of a 'CompiledCodeIn' as measured in Flat bytes. @@ -58,23 +58,27 @@ countFlatBytes = call unDeBruijn, that will rename the variables to things like "v123", where 123 is the relevant de Bruijn index. -} toNamedDeBruijnTerm - :: UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () - -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () + :: UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () toNamedDeBruijnTerm = UPLC.termMapNames UPLC.fakeNameDeBruijn -- | Remove the textual names from a NamedDeBruijn term -toAnonDeBruijnTerm :: Term -> UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun () +toAnonDeBruijnTerm + :: Term + -> UPLC.Term UPLC.DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () toAnonDeBruijnTerm = UPLC.termMapNames UPLC.unNameDeBruijn toAnonDeBruijnProg - :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () toAnonDeBruijnProg (UPLC.Program () ver body) = UPLC.Program () ver $ toAnonDeBruijnTerm body {-| Just extract the body of a program wrapped in a 'CompiledCodeIn'. We use this a lot. -} -compiledCodeToTerm :: Tx.CompiledCodeIn DefaultUni DefaultFun a -> Term +compiledCodeToTerm + :: Tx.CompiledCodeIn DefaultUni DefaultFun DefaultBuiltinPattern a + -> Term compiledCodeToTerm code = let UPLC.Program _ _ body = Tx.getPlcNoAnn code in body {-| Evaluate a PLC term and check that the result matches a given Haskell value From 622c70bcb721e36f287d9fe34eb044537c79aeea Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Wed, 15 Jul 2026 23:05:24 -0500 Subject: [PATCH 3/4] make everything buildable --- .../Validator/Data/TestsCommon.hs | 14 ++- .../Constitution/Validator/TestsCommon.hs | 14 ++- .../PlutusBenchmark/Agda/Common.hs | 6 +- .../src/PlutusBenchmark/BLS12_381/Scripts.hs | 45 ++++++---- plutus-benchmark/cek-calibration/Main.hs | 14 ++- .../certifier/src/Certifier/Common.hs | 6 +- plutus-benchmark/coop/exe/Main.hs | 1 + .../data/src/PlutusBenchmark/Data.hs | 9 +- .../src/PlutusBenchmark/Ed25519/Common.hs | 6 +- plutus-benchmark/flat-decode/bench/Main.hs | 2 +- .../src/PlutusBenchmark/ForceDelay/Common.hs | 5 +- .../src/PlutusBenchmark/ForceDelay/Script.hs | 10 +-- .../PlutusBenchmark/Lists/Sum/HandWritten.hs | 4 +- .../src/PlutusBenchmark/Marlowe/BenchUtil.hs | 3 +- plutus-benchmark/marlowe/test/Lib.hs | 4 +- plutus-benchmark/nofib/exe/Main.hs | 86 ++++++++++--------- plutus-benchmark/uplc-evaluator/Main.hs | 39 +++++++-- .../src/PlutusBenchmark/Validation/Common.hs | 13 ++- plutus-benchmark/validation/test/Spec.hs | 19 +++- plutus-conformance/agda/Spec.hs | 7 +- plutus-conformance/haskell-steppable/Spec.hs | 4 +- plutus-conformance/haskell/Spec.hs | 4 +- .../src/PlutusConformance/Common.hs | 8 +- .../budgeting-bench/Benchmarks/Nops.hs | 9 +- .../cost-model/budgeting-bench/Common.hs | 8 +- .../test/CostModelInterface/Spec.hs | 4 + .../plutus-core/test/CostModelSafety/Spec.hs | 8 ++ .../PlutusIR/Generators/QuickCheck/Tests.hs | 2 +- .../Transform/StrictLetRec/Tests/Lib.hs | 12 +-- plutus-executables/executables/plc/Main.hs | 3 +- plutus-executables/executables/uplc/Main.hs | 24 ++++-- .../plutus/AnyProgram/Compile.hs | 40 ++++++--- plutus-executables/plutus/AnyProgram/Run.hs | 6 +- plutus-executables/plutus/AnyProgram/With.hs | 18 +++- .../plutus/Debugger/TUI/Main.hs | 22 +++-- .../plutus/Debugger/TUI/Types.hs | 6 +- plutus-executables/plutus/Types.hs | 3 +- .../certifier/Test/Certifier/Executable.hs | 13 +-- .../exe/analyse-script-events/Main.hs | 10 ++- .../src/PlutusCore/Executable/AstIO.hs | 12 ++- .../src/PlutusCore/Executable/Common.hs | 9 +- .../src/PlutusCore/Executable/Eval.hs | 30 ++++--- .../PlutusCore/Executable/OptimizerReport.hs | 2 +- .../src/PlutusCore/Executable/Types.hs | 4 +- plutus-ledger-api/test/Spec/Data/Eval.hs | 2 +- plutus-ledger-api/test/Spec/Data/Versions.hs | 13 +-- plutus-ledger-api/test/Spec/Eval.hs | 2 +- plutus-ledger-api/test/Spec/Versions.hs | 16 ++-- .../testlib/PlutusLedgerApi/Test/Scripts.hs | 2 +- plutus-metatheory/src/Certifier.hs | 4 +- .../src/Evaluator/Program.lagda.md | 5 +- plutus-metatheory/src/Evaluator/Term.lagda.md | 4 +- plutus-metatheory/src/FFI/AgdaUnparse.hs | 1 + plutus-metatheory/src/FFI/OptimizerTrace.hs | 13 ++- plutus-metatheory/src/FFI/Untyped.hs | 7 +- .../src/MAlonzo/Code/Certifier.hs | 16 ++-- .../src/MAlonzo/Code/CertifierReport.hs | 24 +++--- .../src/MAlonzo/Code/Evaluator/Program.hs | 4 +- .../src/MAlonzo/Code/Evaluator/Term.hs | 5 +- .../src/MAlonzo/Code/VerifiedCompilation.hs | 40 ++++----- .../MAlonzo/Code/VerifiedCompilation/Trace.hs | 85 +++++++++--------- .../src/VerifiedCompilation/Trace.lagda.md | 3 +- .../certifier-report/Test/Certifier/Report.hs | 17 ++-- .../test/certifier/Test/Certifier/AST.hs | 24 +++--- .../Test/Certifier/AST/ForceDelay.hs | 48 +++++------ .../certifier/Test/Certifier/Optimizer.hs | 13 +-- plutus-tx-plugin/src/PlutusTx/PLCTypes.hs | 6 +- .../src/PlutusTx/Plugin/Common.hs | 2 +- .../test-ledger-api/Spec/ScriptSize.hs | 4 +- .../test/ByteStringLiterals/Spec.hs | 12 ++- plutus-tx-plugin/test/CallTrace/Lib.hs | 2 +- plutus-tx-plugin/test/ShortCircuit/Spec.hs | 8 +- 72 files changed, 587 insertions(+), 363 deletions(-) diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/Data/TestsCommon.hs b/cardano-constitution/test/Cardano/Constitution/Validator/Data/TestsCommon.hs index 14899c30480..4b63690b134 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/Data/TestsCommon.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/Data/TestsCommon.hs @@ -60,13 +60,16 @@ Doing (ioProperty . isRight . tryApplyEval) is probably redundant here, since QC allVldtrsPassed vs ctx = conjoin $ fmap (B.fromOpaque . (`applyOnData` ctx)) vs unsafeRunCekRes - :: t ~ Term NamedDeBruijn DefaultUni DefaultFun () + :: t ~ Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () => t -> t unsafeRunCekRes = unsafeFromRight . runCekRes runCekRes - :: t ~ Term NamedDeBruijn DefaultUni DefaultFun () - => t -> Either (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) t + :: t ~ Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + => t + -> Either + (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern) + t runCekRes t = UPLC.cekResultToEither . UPLC._cekReportResult $ UPLC.runCekDeBruijn defaultCekParametersForTesting restrictingEnormous noEmitter t @@ -74,5 +77,8 @@ runCekRes t = liftCode110 :: Lift DefaultUni a => a -> CompiledCode a liftCode110 = liftCode plcVersion110 -liftCode110Norm :: Lift DefaultUni a => a -> Term NamedDeBruijn DefaultUni DefaultFun () +liftCode110Norm + :: Lift DefaultUni a + => a + -> Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () liftCode110Norm = unsafeRunCekRes . _progTerm . getPlcNoAnn . liftCode110 diff --git a/cardano-constitution/test/Cardano/Constitution/Validator/TestsCommon.hs b/cardano-constitution/test/Cardano/Constitution/Validator/TestsCommon.hs index ad22c0f0bc2..7903131b158 100644 --- a/cardano-constitution/test/Cardano/Constitution/Validator/TestsCommon.hs +++ b/cardano-constitution/test/Cardano/Constitution/Validator/TestsCommon.hs @@ -60,13 +60,16 @@ Doing (ioProperty . isRight . tryApplyEval) is probably redundant here, since QC allVldtrsPassed vs ctx = conjoin $ fmap (B.fromOpaque . (`applyOnData` ctx)) vs unsafeRunCekRes - :: t ~ Term NamedDeBruijn DefaultUni DefaultFun () + :: t ~ Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () => t -> t unsafeRunCekRes = unsafeFromRight . runCekRes runCekRes - :: t ~ Term NamedDeBruijn DefaultUni DefaultFun () - => t -> Either (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) t + :: t ~ Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + => t + -> Either + (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern) + t runCekRes t = UPLC.cekResultToEither . UPLC._cekReportResult $ UPLC.runCekDeBruijn defaultCekParametersForTesting restrictingEnormous noEmitter t @@ -74,5 +77,8 @@ runCekRes t = liftCode110 :: Lift DefaultUni a => a -> CompiledCode a liftCode110 = liftCode plcVersion110 -liftCode110Norm :: Lift DefaultUni a => a -> Term NamedDeBruijn DefaultUni DefaultFun () +liftCode110Norm + :: Lift DefaultUni a + => a + -> Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () liftCode110Norm = unsafeRunCekRes . _progTerm . getPlcNoAnn . liftCode110 diff --git a/plutus-benchmark/agda-common/PlutusBenchmark/Agda/Common.hs b/plutus-benchmark/agda-common/PlutusBenchmark/Agda/Common.hs index b7d62884ed7..af90be23414 100644 --- a/plutus-benchmark/agda-common/PlutusBenchmark/Agda/Common.hs +++ b/plutus-benchmark/agda-common/PlutusBenchmark/Agda/Common.hs @@ -5,7 +5,7 @@ module PlutusBenchmark.Agda.Common where import PlutusCore qualified as PLC -import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun, DefaultUni) import UntypedPlutusCore qualified as UPLC import MAlonzo.Code.Evaluator.Term (runUAgda) @@ -14,8 +14,8 @@ import Criterion.Main (Benchmarkable, nf) -- This code is in its own file so that we only build the metatheory when we really need it. -type Term = UPLC.Term PLC.NamedDeBruijn DefaultUni DefaultFun () -type Program = UPLC.Program PLC.NamedDeBruijn DefaultUni DefaultFun () +type Term = UPLC.Term PLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () +type Program = UPLC.Program PLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () ---------------- Run a term or program using the plutus-metatheory CEK evaluator ---------------- diff --git a/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/Scripts.hs b/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/Scripts.hs index 3f76c674d58..47a0686d1d1 100644 --- a/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/Scripts.hs +++ b/plutus-benchmark/bls12-381-costs/src/PlutusBenchmark/BLS12_381/Scripts.hs @@ -43,7 +43,7 @@ module PlutusBenchmark.BLS12_381.Scripts where import Plinth.Plugin () -import PlutusCore (DefaultFun, DefaultUni) +import PlutusCore (DefaultBuiltinPattern, DefaultFun, DefaultUni) import PlutusLedgerApi.V1.Bytes qualified as P (bytes, fromHex) import PlutusTx qualified as Tx import PlutusTx.List qualified as List @@ -102,7 +102,9 @@ hashAndAddG1 l = go (q : qs) !acc = go qs $ Tx.bls12_381_G1_add (Tx.bls12_381_G1_hashToGroup q emptyByteString) acc {-# INLINEABLE hashAndAddG1 #-} -mkHashAndAddG1Script :: [ByteString] -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkHashAndAddG1Script + :: [ByteString] + -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkHashAndAddG1Script l = let points = List.map toBuiltin l in Tx.getPlcNoAnn $ $$(Tx.compile [||hashAndAddG1||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points @@ -116,7 +118,9 @@ hashAndAddG2 l = go (q : qs) !acc = go qs $ Tx.bls12_381_G2_add (Tx.bls12_381_G2_hashToGroup q emptyByteString) acc {-# INLINEABLE hashAndAddG2 #-} -mkHashAndAddG2Script :: [ByteString] -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkHashAndAddG2Script + :: [ByteString] + -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkHashAndAddG2Script l = let points = List.map toBuiltin l in Tx.getPlcNoAnn $ $$(Tx.compile [||hashAndAddG2||]) `Tx.unsafeApplyCode` Tx.liftCodeDef points @@ -131,7 +135,8 @@ uncompressAndAddG1 l = {-# INLINEABLE uncompressAndAddG1 #-} mkUncompressAndAddG1Script - :: [ByteString] -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () + :: [ByteString] + -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkUncompressAndAddG1Script l = let ramdomPoint bs = Tx.bls12_381_G1_hashToGroup bs emptyByteString points = List.map (Tx.bls12_381_G1_compress . ramdomPoint . toBuiltin) l @@ -147,7 +152,8 @@ uncompressAndAddG2 l = {-# INLINEABLE uncompressAndAddG2 #-} mkUncompressAndAddG2Script - :: [ByteString] -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () + :: [ByteString] + -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkUncompressAndAddG2Script l = let ramdomPoint bs = Tx.bls12_381_G2_hashToGroup bs emptyByteString points = List.map (Tx.bls12_381_G2_compress . ramdomPoint . toBuiltin) l @@ -174,7 +180,7 @@ mkPairingScript -> BuiltinBLS12_381_G2_Element -> BuiltinBLS12_381_G1_Element -> BuiltinBLS12_381_G2_Element - -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () + -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkPairingScript p1 q1 p2 q2 = Tx.getPlcNoAnn $ $$(Tx.compile [||runPairingFunctions||]) @@ -313,7 +319,8 @@ groth16Verify {-| Make a UPLC script applying groth16Verify to the inputs. Passing the newtype inputs increases the size and CPU cost slightly, so we unwrap them first. This should return `True`. -} -mkGroth16VerifyScript :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkGroth16VerifyScript + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkGroth16VerifyScript = Tx.getPlcNoAnn $ $$(Tx.compile [||groth16Verify||]) @@ -374,7 +381,8 @@ verifyBlsSimpleScript privKey message = checkVerifyBlsSimpleScript :: Bool checkVerifyBlsSimpleScript = verifyBlsSimpleScript simpleVerifyPrivKey simpleVerifyMessage -mkVerifyBlsSimplePolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkVerifyBlsSimplePolicy + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkVerifyBlsSimplePolicy = Tx.getPlcNoAnn $ $$(Tx.compile [||verifyBlsSimpleScript||]) @@ -498,7 +506,8 @@ checkVrfBlsScript = pk = Tx.bls12_381_G2_compress $ Tx.bls12_381_G2_scalarMul vrfPrivKey g2generator in vrfBlsScript vrfMessage pk (generateVrfProof vrfPrivKey vrfMessage) -mkVrfBlsPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkVrfBlsPolicy + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkVrfBlsPolicy = let g2generator = Tx.bls12_381_G2_uncompress Tx.bls12_381_G2_compressed_generator in Tx.getPlcNoAnn @@ -557,7 +566,8 @@ checkG1VerifyScript :: Bool checkG1VerifyScript = g1VerifyScript g1VerifyMessage g1VerifyPubKey g1VerifySignature blsSigBls12381G2XmdSha256SswuRoNul -mkG1VerifyPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkG1VerifyPolicy + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkG1VerifyPolicy = Tx.getPlcNoAnn $ $$(Tx.compile [||g1VerifyScript||]) @@ -616,7 +626,8 @@ checkG2VerifyScript :: Bool checkG2VerifyScript = g2VerifyScript g2VerifyMessage g2VerifyPubKey g2VerifySignature blsSigBls12381G2XmdSha256SswuRoNul -mkG2VerifyPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkG2VerifyPolicy + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkG2VerifyPolicy = Tx.getPlcNoAnn $ $$(Tx.compile [||g2VerifyScript||]) @@ -702,7 +713,8 @@ checkAggregateSingleKeyG1Script = aggregateSingleKeyG1Signature blsSigBls12381G2XmdSha256SswuRoNul -mkAggregateSingleKeyG1Policy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkAggregateSingleKeyG1Policy + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkAggregateSingleKeyG1Policy = Tx.getPlcNoAnn $ $$(Tx.compile [||aggregateSingleKeyG1Script||]) @@ -872,7 +884,8 @@ checkAggregateMultiKeyG2Script = byteString16Null blsSigBls12381G2XmdSha256SswuRoNul -mkAggregateMultiKeyG2Policy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkAggregateMultiKeyG2Policy + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkAggregateMultiKeyG2Policy = Tx.getPlcNoAnn $ $$(Tx.compile [||aggregateMultiKeyG2Script||]) @@ -952,7 +965,8 @@ checkSchnorrG1VerifyScript = schnorrG1VerifySignature byteString16Null -mkSchnorrG1VerifyPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkSchnorrG1VerifyPolicy + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkSchnorrG1VerifyPolicy = Tx.getPlcNoAnn $ $$(Tx.compile [||schnorrG1VerifyScript||]) @@ -1034,7 +1048,8 @@ checkSchnorrG2VerifyScript = schnorrG2VerifySignature byteString16Null -mkSchnorrG2VerifyPolicy :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkSchnorrG2VerifyPolicy + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkSchnorrG2VerifyPolicy = Tx.getPlcNoAnn $ $$(Tx.compile [||schnorrG2VerifyScript||]) diff --git a/plutus-benchmark/cek-calibration/Main.hs b/plutus-benchmark/cek-calibration/Main.hs index b4bcd8f0292..e3f51f4069d 100644 --- a/plutus-benchmark/cek-calibration/Main.hs +++ b/plutus-benchmark/cek-calibration/Main.hs @@ -31,7 +31,7 @@ import Control.Monad.Except import Criterion.Main import Criterion.Types qualified as C -type PlainTerm = UPLC.Term Name DefaultUni DefaultFun () +type PlainTerm = UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern () rev :: [()] -> [()] rev l0 = rev' l0 [] @@ -62,10 +62,14 @@ go :: Integer -> [()] go n = zipl (mkList n) (rev $ mkList n) {-# INLINEABLE go #-} -mkListProg :: Integer -> UPLC.Program NamedDeBruijn DefaultUni DefaultFun () +mkListProg + :: Integer + -> UPLC.Program NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkListProg n = Tx.getPlcNoAnn $ $$(Tx.compile [||go||]) `Tx.unsafeApplyCode` Tx.liftCodeDef n -mkListTerm :: Integer -> UPLC.Term NamedDeBruijn DefaultUni DefaultFun () +mkListTerm + :: Integer + -> UPLC.Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkListTerm n = let (UPLC.Program _ _ code) = mkListProg n in code @@ -76,7 +80,9 @@ mkListBM ctx n = bench (Haskell.show n) $ benchTermCek ctx (mkListTerm n) mkListBMs :: EvaluationContext -> [Integer] -> Benchmark mkListBMs ctx ns = bgroup "List" [mkListBM ctx n | n <- ns] -writePlc :: UPLC.Program NamedDeBruijn DefaultUni DefaultFun () -> Haskell.IO () +writePlc + :: UPLC.Program NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> Haskell.IO () writePlc p = case runExcept @UPLC.FreeVariableError $ runQuoteT diff --git a/plutus-benchmark/certifier/src/Certifier/Common.hs b/plutus-benchmark/certifier/src/Certifier/Common.hs index 8cda043ca84..da56ce52019 100644 --- a/plutus-benchmark/certifier/src/Certifier/Common.hs +++ b/plutus-benchmark/certifier/src/Certifier/Common.hs @@ -35,10 +35,10 @@ loadFrom name = do pure . runQuote $ mkFfiOptimizerTrace . snd <$> simplify term simplify - :: Term Name DefaultUni DefaultFun () + :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> Quote - ( Term Name DefaultUni DefaultFun () - , OptimizerTrace Name DefaultUni DefaultFun () + ( Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + , OptimizerTrace Name DefaultUni DefaultFun DefaultBuiltinPattern () ) simplify = runOptimizerT diff --git a/plutus-benchmark/coop/exe/Main.hs b/plutus-benchmark/coop/exe/Main.hs index 12118c26d34..49e671265c6 100644 --- a/plutus-benchmark/coop/exe/Main.hs +++ b/plutus-benchmark/coop/exe/Main.hs @@ -51,6 +51,7 @@ createIfNotExists name term = do UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun + UPLC.DefaultBuiltinPattern SrcSpans ) bs diff --git a/plutus-benchmark/data/src/PlutusBenchmark/Data.hs b/plutus-benchmark/data/src/PlutusBenchmark/Data.hs index 2ef01cc6177..64f5bc19470 100644 --- a/plutus-benchmark/data/src/PlutusBenchmark/Data.hs +++ b/plutus-benchmark/data/src/PlutusBenchmark/Data.hs @@ -15,8 +15,13 @@ import PlutusCore.MkPlc import UntypedPlutusCore qualified as UPLC debruijnTermUnsafe - :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun ann - -> UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ann + :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun PLC.DefaultBuiltinPattern ann + -> UPLC.Term + UPLC.NamedDeBruijn + UPLC.DefaultUni + UPLC.DefaultFun + PLC.DefaultBuiltinPattern + ann debruijnTermUnsafe = fromRight (Prelude.error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError diff --git a/plutus-benchmark/ed25519-costs/src/PlutusBenchmark/Ed25519/Common.hs b/plutus-benchmark/ed25519-costs/src/PlutusBenchmark/Ed25519/Common.hs index 461b1b52ce5..1f3a2e518a4 100644 --- a/plutus-benchmark/ed25519-costs/src/PlutusBenchmark/Ed25519/Common.hs +++ b/plutus-benchmark/ed25519-costs/src/PlutusBenchmark/Ed25519/Common.hs @@ -18,7 +18,7 @@ import PlutusBenchmark.Common import System.IO (Handle) import Plinth.Plugin () -import PlutusCore (DefaultFun, DefaultUni) +import PlutusCore (DefaultBuiltinPattern, DefaultFun, DefaultUni) import PlutusCore.Crypto.Hash qualified as Hash import PlutusTx qualified as Tx import PlutusTx.List qualified as List @@ -143,7 +143,9 @@ verifyInputs hash d = {-| Create the input data, convert it to BuiltinData, and apply the verification script to that. -} -mkSigCheckScript :: Integer -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () +mkSigCheckScript + :: Integer + -> UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkSigCheckScript n = Tx.getPlcNoAnn $ $$(Tx.compile [||verifyInputs builtinHash||]) diff --git a/plutus-benchmark/flat-decode/bench/Main.hs b/plutus-benchmark/flat-decode/bench/Main.hs index e14b43d1895..a9dfd2dbcf3 100644 --- a/plutus-benchmark/flat-decode/bench/Main.hs +++ b/plutus-benchmark/flat-decode/bench/Main.hs @@ -56,7 +56,7 @@ mkBM (sz, a) = mkProg :: DefaultUni `Contains` a => a - -> UPLC.Program DeBruijn DefaultUni DefaultFun () + -> UPLC.Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () mkProg a = UPLC.Program () plcVersion100 $ mkConstant () a main :: IO () diff --git a/plutus-benchmark/force-delay/src/PlutusBenchmark/ForceDelay/Common.hs b/plutus-benchmark/force-delay/src/PlutusBenchmark/ForceDelay/Common.hs index 5439e0f33ca..eba6b6f533c 100644 --- a/plutus-benchmark/force-delay/src/PlutusBenchmark/ForceDelay/Common.hs +++ b/plutus-benchmark/force-delay/src/PlutusBenchmark/ForceDelay/Common.hs @@ -9,6 +9,7 @@ module PlutusBenchmark.ForceDelay.Common import PlutusBenchmark.Common (benchTermCek, getConfig, getDataDir, mkEvalCtx) import PlutusBenchmark.NaturalSort +import PlutusCore.Default (DefaultBuiltinPattern) import PlutusCore.Flat import UntypedPlutusCore qualified as UPLC @@ -26,7 +27,9 @@ getScriptDirectory = do return $ root "force-delay" "data" unsafeUnflat - :: String -> BS.ByteString -> UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () + :: String + -> BS.ByteString + -> UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun DefaultBuiltinPattern () unsafeUnflat file contents = case unflat contents of Left e -> errorWithoutStackTrace $ "Flat deserialisation failure for " ++ file ++ ": " ++ show e diff --git a/plutus-benchmark/force-delay/src/PlutusBenchmark/ForceDelay/Script.hs b/plutus-benchmark/force-delay/src/PlutusBenchmark/ForceDelay/Script.hs index 9234582c703..91e0954b480 100644 --- a/plutus-benchmark/force-delay/src/PlutusBenchmark/ForceDelay/Script.hs +++ b/plutus-benchmark/force-delay/src/PlutusBenchmark/ForceDelay/Script.hs @@ -15,15 +15,15 @@ import Data.Foldable qualified as F import Data.Text qualified as T nameToDebruijn - :: Program Name DefaultUni DefaultFun () - -> Program DeBruijn DefaultUni DefaultFun () + :: Program Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () nameToDebruijn (Program ann ver term) = Program ann ver . termMapNames unNameDeBruijn . unsafeFromRight @PLC.FreeVariableError $ deBruijnTerm term -nested0 :: Int -> Program DeBruijn DefaultUni DefaultFun () +nested0 :: Int -> Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () nested0 n | n <= 0 = error "nested0: n must be positive" | otherwise = nameToDebruijn . Program () plcVersion100 . runQuote $ do @@ -33,7 +33,7 @@ nested0 n result = F.foldl' (\acc _ -> Force () acc) inner (replicate n ()) pure result -nested1 :: Int -> Program DeBruijn DefaultUni DefaultFun () +nested1 :: Int -> Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () nested1 n | n <= 0 = error "nested1: n must be positive" | otherwise = nameToDebruijn . Program () plcVersion100 . runQuote $ do @@ -43,7 +43,7 @@ nested1 n args = [mkConstant @Integer () (toInteger i) | i <- [1 .. n]] pure $ F.foldl' (\acc arg -> Apply () (Force () acc) arg) delayed args -nested2 :: Int -> Program DeBruijn DefaultUni DefaultFun () +nested2 :: Int -> Program DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () nested2 n | n <= 0 = error "nested2: n must be positive" | otherwise = nameToDebruijn . Program () plcVersion100 . runQuote $ do diff --git a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/HandWritten.hs b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/HandWritten.hs index 8baa805e3ae..e13793e2e49 100644 --- a/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/HandWritten.hs +++ b/plutus-benchmark/lists/src/PlutusBenchmark/Lists/Sum/HandWritten.hs @@ -39,7 +39,7 @@ mkSumRightScottTerm l = UPLC.Apply () (debruijnTermUnsafe $ eraseTerm ScottList.sumr) (mkScottList l) debruijnTermUnsafe - :: UPLC.Term UPLC.Name uni fun ann - -> UPLC.Term UPLC.NamedDeBruijn uni fun ann + :: UPLC.Term UPLC.Name uni fun pat ann + -> UPLC.Term UPLC.NamedDeBruijn uni fun pat ann debruijnTermUnsafe = fromRight (error "debruijnTermUnsafe") . runExcept @UPLC.FreeVariableError . UPLC.deBruijnTerm diff --git a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs index eee8f37f4c1..cf0d40f2b1d 100644 --- a/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs +++ b/plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/BenchUtil.hs @@ -56,7 +56,8 @@ import System.FilePath ((<.>), ()) import UntypedPlutusCore (NamedDeBruijn, applyProgram) import UntypedPlutusCore qualified as UPLC -type Program a = UPLC.Program NamedDeBruijn PLC.DefaultUni PLC.DefaultFun a +type Program a = + UPLC.Program NamedDeBruijn PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern a -- | Turn a `PlutusBenchmark.Marlowe.Types.Benchmark` to a UPLC program. benchmarkToUPLC diff --git a/plutus-benchmark/marlowe/test/Lib.hs b/plutus-benchmark/marlowe/test/Lib.hs index 3bce3b8de98..c0dc2e6efbf 100644 --- a/plutus-benchmark/marlowe/test/Lib.hs +++ b/plutus-benchmark/marlowe/test/Lib.hs @@ -10,7 +10,7 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO import Formatting qualified as F -import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun, DefaultUni) import PlutusCore.Evaluation.Machine.ExMemory (CostingInteger) import PlutusCore.Test (runUPlcFull) import PlutusLedgerApi.V3 (ExBudget (..), ExCPU (..), ExMemory (..), fromSatInt) @@ -28,7 +28,7 @@ import UntypedPlutusCore.Core.Type qualified as UPLC -- | Measure the given program's execution budget and size. measureProgram - :: UPLC.Program NamedDeBruijn DefaultUni DefaultFun () + :: UPLC.Program NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () -> IO (ExCPU, ExMemory, UPLC.AstSize) measureProgram program = runExceptT (runUPlcFull [program]) >>= \case diff --git a/plutus-benchmark/nofib/exe/Main.hs b/plutus-benchmark/nofib/exe/Main.hs index c37c508a4ac..df13605089e 100644 --- a/plutus-benchmark/nofib/exe/Main.hs +++ b/plutus-benchmark/nofib/exe/Main.hs @@ -31,7 +31,7 @@ import PlutusBenchmark.NoFib.Prime qualified as Prime import PlutusBenchmark.NoFib.Queens qualified as Queens import PlutusCore qualified as PLC -import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun, DefaultUni) import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) @@ -245,18 +245,23 @@ options = ---------------- Evaluation ---------------- evaluateWithCek - :: UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.EvaluationResult (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun ()) + :: UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> UPLC.EvaluationResult + (UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) evaluateWithCek = UPLC.unsafeSplitStructuralOperational . UPLC.cekResultToEither . UPLC._cekReportResult . UPLC.runCekDeBruijn PLC.defaultCekParametersForTesting UPLC.restrictingEnormous UPLC.noEmitter -writeFlatNamed :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () -> IO () +writeFlatNamed + :: UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> IO () writeFlatNamed prog = BS.putStr . Flat.flat . UPLC.UnrestrictedProgram $ prog -writeFlatDeBruijn :: UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun () -> IO () +writeFlatDeBruijn + :: UPLC.Program UPLC.DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> IO () writeFlatDeBruijn prog = BS.putStr . Flat.flat . UPLC.UnrestrictedProgram $ prog description :: Hs.String @@ -372,40 +377,43 @@ printSizesAndBudgets = do main :: IO () main = do execParser - (info (helper <*> options) (fullDesc <> progDesc description <> footerDoc (Just footerInfo))) >>= \case - RunPLC pa -> - print . prettyPlc . fmap fromNamedDeBruijnUPLC . evaluateWithCek . getTerm $ pa - RunHaskell pa -> - case pa of - Clausify formula -> print $ Clausify.runClausify formula - Knights depth boardSize -> print $ Knights.runKnights depth boardSize - LastPiece -> print $ LastPiece.runLastPiece - Queens boardSize alg -> print $ Queens.runQueens boardSize alg - Prime input -> print $ Prime.runFixedPrimalityTest input - Primetest n -> - if n < 0 - then Hs.error "Positive number expected" - else print $ Prime.runPrimalityTest n - DumpPLC pa -> - traverse_ putStrLn - $ unindent - . prettyPlc - . UPLC.Program () PLC.latestVersion - . fromNamedDeBruijnUPLC - . getTerm - $ pa - where - -- These are big programs and with indentation the output is > 90% whitespace - unindent d = map (dropWhile isSpace) $ (Hs.lines . Hs.show $ d) - DumpFlatNamed pa -> - writeFlatNamed . UPLC.Program () PLC.latestVersion . getTerm $ pa - DumpFlatDeBruijn pa -> - writeFlatDeBruijn . UPLC.Program () PLC.latestVersion . toAnonDeBruijnTerm . getTerm $ pa - SizesAndBudgets -> - printSizesAndBudgets + (info (helper <*> options) (fullDesc <> progDesc description <> footerDoc (Just footerInfo))) + >>= \case + RunPLC pa -> + print . prettyPlc . fmap fromNamedDeBruijnUPLC . evaluateWithCek . getTerm $ pa + RunHaskell pa -> + case pa of + Clausify formula -> print $ Clausify.runClausify formula + Knights depth boardSize -> print $ Knights.runKnights depth boardSize + LastPiece -> print $ LastPiece.runLastPiece + Queens boardSize alg -> print $ Queens.runQueens boardSize alg + Prime input -> print $ Prime.runFixedPrimalityTest input + Primetest n -> + if n < 0 + then Hs.error "Positive number expected" + else print $ Prime.runPrimalityTest n + DumpPLC pa -> + traverse_ putStrLn + $ unindent + . prettyPlc + . UPLC.Program () PLC.latestVersion + . fromNamedDeBruijnUPLC + . getTerm + $ pa + where + -- These are big programs and with indentation the output is > 90% whitespace + unindent d = map (dropWhile isSpace) $ (Hs.lines . Hs.show $ d) + DumpFlatNamed pa -> + writeFlatNamed . UPLC.Program () PLC.latestVersion . getTerm $ pa + DumpFlatDeBruijn pa -> + writeFlatDeBruijn . UPLC.Program () PLC.latestVersion . toAnonDeBruijnTerm . getTerm $ pa + SizesAndBudgets -> + printSizesAndBudgets where -- Write the output to stdout and let the user deal with redirecting it. - getTerm :: ProgAndArgs -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () + getTerm + :: ProgAndArgs + -> UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () getTerm = \case Clausify formula -> Clausify.mkClausifyTerm formula @@ -418,8 +426,8 @@ main = do then Hs.error "Positive number expected" else Prime.mkPrimalityTestTerm n fromNamedDeBruijnUPLC - :: UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun () - -> UPLC.Term UPLC.Name DefaultUni DefaultFun () + :: UPLC.Term UPLC.NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () + -> UPLC.Term UPLC.Name DefaultUni DefaultFun DefaultBuiltinPattern () fromNamedDeBruijnUPLC = unsafeFromRight @PLC.FreeVariableError . PLC.runQuoteT diff --git a/plutus-benchmark/uplc-evaluator/Main.hs b/plutus-benchmark/uplc-evaluator/Main.hs index 3bc20052f30..e95c0b64512 100644 --- a/plutus-benchmark/uplc-evaluator/Main.hs +++ b/plutus-benchmark/uplc-evaluator/Main.hs @@ -155,7 +155,11 @@ isUplcFile path = {-| Parse a UPLC program from textual syntax. Returns either a descriptive error message or the parsed program with unit annotations. -} -parseUplcProgram :: Text -> Either Text (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun ()) +parseUplcProgram + :: Text + -> Either + Text + (UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ()) parseUplcProgram input = case runQuoteT (UPLC.Parser.parseProgram input) of Left err -> Left $ T.pack $ show err @@ -194,8 +198,16 @@ instance NFData EvalFailure {-| Convert a parsed UPLC program (with Name) to a term with NamedDeBruijn indices. This is required for CEK machine evaluation. -} toNamedDeBruijnTerm - :: UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun () - -> Either EvalFailure (UPLC.Term UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun ()) + :: UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + -> Either + EvalFailure + ( UPLC.Term + UPLC.NamedDeBruijn + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () + ) toNamedDeBruijnTerm (UPLC.Program _ _ term) = case UPLC.deBruijnTerm term of Left err -> Left $ ConversionError $ T.pack $ show err @@ -205,7 +217,12 @@ toNamedDeBruijnTerm (UPLC.Program _ _ term) = Returns the CPU and memory budget consumed, or an error if evaluation fails. -} {-# NOINLINE evaluateWithBudget #-} evaluateWithBudget - :: UPLC.Term UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + :: UPLC.Term + UPLC.NamedDeBruijn + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () -> Either EvalFailure EvalBudget evaluateWithBudget term = case Cek.runCekDeBruijn PLC.defaultCekParametersForTesting Cek.tallying Cek.noEmitter term of @@ -258,7 +275,12 @@ Performs warm-up iterations first, then collects timing samples. Budget values are deterministic and returned separately from variable timing data. Returns early with error if initial validation fails. -} collectMeasurements - :: UPLC.Term UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + :: UPLC.Term + UPLC.NamedDeBruijn + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () -> Int -- ^ Number of samples to collect -> IO (Either EvalFailure (EvalBudget, [TimingSample])) @@ -286,7 +308,12 @@ collectMeasurements term sampleCount = do -- depends on the lambda-bound 't', so full laziness cannot float it out. {-# NOINLINE measureSingleExecution #-} measureSingleExecution - :: UPLC.Term UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + :: UPLC.Term + UPLC.NamedDeBruijn + PLC.DefaultUni + PLC.DefaultFun + PLC.DefaultBuiltinPattern + () -> IO Word64 measureSingleExecution t = do (_, timeNs) <- measureExecution $ evaluate (evaluateWithBudget t) diff --git a/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs b/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs index 5db0cc1411f..7ff5b65cf54 100644 --- a/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs +++ b/plutus-benchmark/validation/src/PlutusBenchmark/Validation/Common.hs @@ -16,6 +16,7 @@ import PlutusBenchmark.NaturalSort import PlutusCore.Builtin qualified as PLC import PlutusCore.Data qualified as PLC +import PlutusCore.Default qualified as PLC import UntypedPlutusCore qualified as UPLC import Criterion.Main @@ -84,7 +85,14 @@ l `withAnyPrefixFrom` ps = concatMap (\p -> filter (isPrefixOf p) l) ps unsafeUnflat - :: String -> BS.ByteString -> UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () + :: String + -> BS.ByteString + -> UPLC.Program + UPLC.DeBruijn + UPLC.DefaultUni + UPLC.DefaultFun + PLC.DefaultBuiltinPattern + () unsafeUnflat file contents = case unflat contents of Left e -> errorWithoutStackTrace $ "Flat deserialisation failure for " ++ file ++ ": " ++ show e @@ -136,7 +144,8 @@ benchWith act = do env (BS.readFile $ dir file) $ \(~scriptBS) -> bench (dropExtension file) $ act file scriptBS -type Term = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +type Term = + UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun PLC.DefaultBuiltinPattern () {-| If the term is an application of something to some arguments, peel off those arguments which are 'Data' constants. -} diff --git a/plutus-benchmark/validation/test/Spec.hs b/plutus-benchmark/validation/test/Spec.hs index d294a3ab363..0ccce9ebf23 100644 --- a/plutus-benchmark/validation/test/Spec.hs +++ b/plutus-benchmark/validation/test/Spec.hs @@ -9,6 +9,7 @@ import PlutusBenchmark.NaturalSort import PlutusBenchmark.Validation.Common import PlutusCore.Annotation qualified as PLC +import PlutusCore.Default qualified as PLC import PlutusTx.Code qualified as Tx import PlutusTx.Test qualified as Tx import UntypedPlutusCore qualified as UPLC @@ -28,10 +29,24 @@ mkCase path name = do parsed :: Either DecodeException - (UPLC.Program UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun PLC.SrcSpans) + ( UPLC.Program + UPLC.NamedDeBruijn + UPLC.DefaultUni + UPLC.DefaultFun + PLC.DefaultBuiltinPattern + PLC.SrcSpans + ) parsed = (fmap mempty . UPLC.programMapNames UPLC.fakeNameDeBruijn . UPLC.unUnrestrictedProgram) - <$> unflat @(UPLC.UnrestrictedProgram UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) bs + <$> unflat + @( UPLC.UnrestrictedProgram + UPLC.DeBruijn + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + () + ) + bs case parsed of Left err -> error $ show err Right parsed' -> diff --git a/plutus-conformance/agda/Spec.hs b/plutus-conformance/agda/Spec.hs index b8b6f0e44a2..93b0ef69217 100644 --- a/plutus-conformance/agda/Spec.hs +++ b/plutus-conformance/agda/Spec.hs @@ -21,7 +21,8 @@ import PlutusConformance.Common ) import PlutusCore (Error (..)) import PlutusCore.Default - ( DefaultFun + ( DefaultBuiltinPattern + , DefaultFun , DefaultUni ) import PlutusCore.Evaluation.Machine.CostModelInterface @@ -100,7 +101,7 @@ agdaEvalUplcProg WithCosting = :: ExceptT FreeVariableError Quote - (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) + (UPLC.Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) tmUDB = deBruijnTerm tmU in case runQuote $ runExceptT $ withExceptT FreeVariableErrorE tmUDB of @@ -129,7 +130,7 @@ agdaEvalUplcProg WithoutCosting = :: ExceptT FreeVariableError Quote - (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) + (UPLC.Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) tmUDB = deBruijnTerm tmU in case runQuote $ runExceptT $ withExceptT FreeVariableErrorE tmUDB of Left _ -> Nothing diff --git a/plutus-conformance/haskell-steppable/Spec.hs b/plutus-conformance/haskell-steppable/Spec.hs index 7e52a8a0343..df7ad8ca237 100644 --- a/plutus-conformance/haskell-steppable/Spec.hs +++ b/plutus-conformance/haskell-steppable/Spec.hs @@ -4,6 +4,7 @@ module Main (main) where import PlutusConformance.Common +import PlutusCore.Builtin qualified as PLC import PlutusCore.Evaluation.Machine.MachineParameters qualified as UPLC import PlutusCore.Evaluation.Machine.MachineParameters.Default import PlutusPrelude @@ -32,7 +33,8 @@ evalSteppableUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) -> do params <- case mkMachineVariantParametersFor [def] modelParams of Left _ -> Nothing - Right machParamsList -> UPLC.MachineParameters def <$> lookup def machParamsList + Right machParamsList -> + UPLC.MachineParameters def PLC.availableMatcherBuiltin <$> lookup def machParamsList -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with -- free variables, that is why we manually check first for any free vars case UPLC.deBruijnTerm t of diff --git a/plutus-conformance/haskell/Spec.hs b/plutus-conformance/haskell/Spec.hs index 2289562769c..12c208b337a 100644 --- a/plutus-conformance/haskell/Spec.hs +++ b/plutus-conformance/haskell/Spec.hs @@ -4,6 +4,7 @@ module Main (main) where import PlutusConformance.Common (UplcEvaluator (..), runUplcEvalTests) +import PlutusCore.Builtin qualified as PLC import PlutusCore.Evaluation.Machine.MachineParameters qualified as UPLC import PlutusCore.Evaluation.Machine.MachineParameters.Default import PlutusPrelude (def) @@ -16,7 +17,8 @@ evalUplcProg = UplcEvaluatorWithCosting $ \modelParams (UPLC.Program a v t) -> do params <- case mkMachineVariantParametersFor [def] modelParams of Left _ -> Nothing - Right machParamsList -> UPLC.MachineParameters def <$> lookup def machParamsList + Right machParamsList -> + UPLC.MachineParameters def PLC.availableMatcherBuiltin <$> lookup def machParamsList -- runCek-like functions (e.g. evaluateCekNoEmit) are partial on term's with -- free variables, that is why we manually check first for any free vars case UPLC.deBruijnTerm t of diff --git a/plutus-conformance/src/PlutusConformance/Common.hs b/plutus-conformance/src/PlutusConformance/Common.hs index 637170949df..95407121641 100644 --- a/plutus-conformance/src/PlutusConformance/Common.hs +++ b/plutus-conformance/src/PlutusConformance/Common.hs @@ -9,7 +9,7 @@ import Data.Maybe (fromJust) import Data.Text qualified as T import Data.Text.IO qualified as T import PlutusCore.Annotation -import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun, DefaultUni) import PlutusCore.Error (ParserErrorBundle) import PlutusCore.Evaluation.Machine.CostModelInterface import PlutusCore.Evaluation.Machine.ExBudget @@ -44,11 +44,13 @@ shownEvaluationFailure = "evaluation failure" -- | The default parser to parse UPLC program inputs. parseTxt :: T.Text - -> Either ParserErrorBundle (UPLC.Program Name DefaultUni DefaultFun SrcSpan) + -> Either + ParserErrorBundle + (UPLC.Program Name DefaultUni DefaultFun DefaultBuiltinPattern SrcSpan) parseTxt resTxt = runQuoteT $ UPLC.parseProgram resTxt -- | The input/output UPLC program type. -type UplcProg = UPLC.Program Name DefaultUni DefaultFun () +type UplcProg = UPLC.Program Name DefaultUni DefaultFun DefaultBuiltinPattern () -- UPLC evaluation test functions diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs index a8582328c79..6a76b8f1214 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs @@ -129,9 +129,14 @@ nopCostModel = (ModelSixArgumentsConstantCost 600) } -nopCostParameters :: MachineParameters CekMachineCosts NopFun (CekValue DefaultUni NopFun ()) +nopCostParameters + :: MachineParameters + CekMachineCosts + NopFun + (CekValue DefaultUni NopFun DefaultBuiltinPattern ()) + DefaultBuiltinPattern nopCostParameters = - MachineParameters def . mkMachineVariantParameters def $ + MachineParameters def def . mkMachineVariantParameters def $ CostModel defaultCekMachineCostsForTesting nopCostModel -- Benchmark a function in `NopFun` with the nopCostParameters using `whnf`. diff --git a/plutus-core/cost-model/budgeting-bench/Common.hs b/plutus-core/cost-model/budgeting-bench/Common.hs index dd6ccd5b895..07303a2d427 100644 --- a/plutus-core/cost-model/budgeting-bench/Common.hs +++ b/plutus-core/cost-model/budgeting-bench/Common.hs @@ -48,7 +48,7 @@ import Data.Bifunctor (bimap) import Data.ByteString qualified as BS import Data.Typeable (Typeable) -type PlainTerm uni fun = UPLC.Term Name uni fun () +type PlainTerm uni fun = UPLC.Term Name uni fun DefaultBuiltinPattern () showMemoryUsage :: ExMemoryUsage a => a -> String showMemoryUsage = show . sumCostStream . flattenCostRose . memoryUsage @@ -109,7 +109,11 @@ data Normaliser benchWith :: (Pretty fun, Typeable fun, NFData fun) => Normaliser - -> MachineParameters CekMachineCosts fun (CekValue DefaultUni fun ()) + -> MachineParameters + CekMachineCosts + fun + (CekValue DefaultUni fun DefaultBuiltinPattern ()) + DefaultBuiltinPattern -> String -> PlainTerm DefaultUni fun -> Benchmark diff --git a/plutus-core/plutus-core/test/CostModelInterface/Spec.hs b/plutus-core/plutus-core/test/CostModelInterface/Spec.hs index 04469aac4cc..3ff2e40a600 100644 --- a/plutus-core/plutus-core/test/CostModelInterface/Spec.hs +++ b/plutus-core/plutus-core/test/CostModelInterface/Spec.hs @@ -64,6 +64,10 @@ randomCekCosts = , cekBuiltinCost = pure $ ExBudget 4 4 , cekConstrCost = pure $ ExBudget 8 100000 , cekCaseCost = pure $ ExBudget 3324234 555 + , cekMatchCost = pure $ ExBudget 456789 777 + , cekPatternCost = pure $ ExBudget 7654321 666 + , cekPatternStructuralCost = pure $ ExBudget 8765432 555 + , cekPatternFailureCost = pure $ ExBudget 9876543 444 } cekVarCostCpuKey :: Text.Text diff --git a/plutus-core/plutus-core/test/CostModelSafety/Spec.hs b/plutus-core/plutus-core/test/CostModelSafety/Spec.hs index 47e60023a15..41d6abb12ce 100644 --- a/plutus-core/plutus-core/test/CostModelSafety/Spec.hs +++ b/plutus-core/plutus-core/test/CostModelSafety/Spec.hs @@ -101,6 +101,10 @@ testMachineCostModel cekBuiltinBudget cekConstrBudget cekCaseBudget + cekMatchBudget + cekPatternBudget + cekPatternStructuralBudget + cekPatternFailureBudget ) = do checkBudget cekStartupBudget checkBudget cekVarBudget @@ -112,6 +116,10 @@ testMachineCostModel checkBudget cekBuiltinBudget checkBudget cekConstrBudget checkBudget cekCaseBudget + checkBudget cekMatchBudget + checkBudget cekPatternBudget + checkBudget cekPatternStructuralBudget + checkBudget cekPatternFailureBudget -- Builtin costs diff --git a/plutus-core/plutus-ir/test/PlutusIR/Generators/QuickCheck/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Generators/QuickCheck/Tests.hs index 4a227095a22..6a9fee34af7 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Generators/QuickCheck/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Generators/QuickCheck/Tests.hs @@ -215,7 +215,7 @@ prop_noTermShrinkLoops = BaseQC.withNumTests 0 tm `notElem` map snd (shrinkClosedTypedTerm (ty, tm)) -- | Check that evaluation of the given term doesn't fail with a structural error. -noStructuralErrors :: UPLC.Term Name DefaultUni DefaultFun () -> IO () +noStructuralErrors :: UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> IO () noStructuralErrors term = -- Throw on a structural evaluation error and succeed on both an operational evaluation error and -- evaluation success. diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests/Lib.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests/Lib.hs index 81336af95a5..542358615c7 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests/Lib.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/StrictLetRec/Tests/Lib.hs @@ -11,7 +11,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (runReaderT) import Data.Text (Text) import Data.Text.IO qualified as Text -import PlutusCore (Name, SrcSpan, latestVersion) +import PlutusCore (DefaultBuiltinPattern, Name, SrcSpan, latestVersion) import PlutusCore.Compiler qualified as TPLC import PlutusCore.Core qualified as TPLC import PlutusCore.Default (DefaultFun, DefaultUni) @@ -66,7 +66,7 @@ pirTermAsProgram = PIR.Program () latestVersion evalPirProgramWithTracesOrFail :: MonadFail m => PIR.Program PIR.TyName PIR.Name DefaultUni DefaultFun () - -> m (EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()), [Text]) + -> m (EvaluationResult (UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()), [Text]) evalPirProgramWithTracesOrFail pirProgram = do plcProgram <- compilePirProgramOrFail pirProgram evaluateUplcProgramWithTraces <$> compileTplcProgramOrFail plcProgram @@ -88,7 +88,7 @@ compilePirProgramOrFail pirProgram = do compileTplcProgramOrFail :: MonadFail m => TPLC.Program PIR.TyName PIR.Name DefaultUni DefaultFun () - -> m (UPLC.Program Name DefaultUni DefaultFun ()) + -> m (UPLC.Program Name DefaultUni DefaultFun DefaultBuiltinPattern ()) compileTplcProgramOrFail plcProgram = handlePirErrorByFailing @SrcSpan =<< do TPLC.compileProgram plcProgram @@ -97,8 +97,8 @@ compileTplcProgramOrFail plcProgram = & runExceptT evaluateUplcProgramWithTraces - :: UPLC.Program Name DefaultUni DefaultFun () - -> (EvaluationResult (UPLC.Term Name DefaultUni DefaultFun ()), [Text]) + :: UPLC.Program Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> (EvaluationResult (UPLC.Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()), [Text]) evaluateUplcProgramWithTraces uplcProg = first unsafeSplitStructuralOperational $ evaluateCek logEmitter machineParameters (uplcProg ^. UPLC.progTerm) @@ -109,7 +109,7 @@ evaluateUplcProgramWithTraces uplcProg = machineParameters :: DefaultMachineParameters machineParameters = - MachineParameters def $ mkMachineVariantParameters def costModel + MachineParameters def def $ mkMachineVariantParameters def costModel defaultCompilationCtx :: Either diff --git a/plutus-executables/executables/plc/Main.hs b/plutus-executables/executables/plc/Main.hs index 87cf1605394..e8c5368ba3b 100644 --- a/plutus-executables/executables/plc/Main.hs +++ b/plutus-executables/executables/plc/Main.hs @@ -263,7 +263,8 @@ runPlcPrintExample = runPrintExample getPlcExamples runErase :: EraseOptions -> IO () runErase (EraseOptions inp ifmt outp ofmt mode) = do typedProg <- (readProgram ifmt inp :: IO (PlcProg PLC.SrcSpan)) - let untypedProg = void $ PLC.eraseProgram typedProg + let untypedProg :: UplcProg () + untypedProg = void $ PLC.eraseProgram typedProg case ofmt of Textual -> writePrettyToOutput outp mode untypedProg Flat flatMode -> writeFlat outp flatMode untypedProg diff --git a/plutus-executables/executables/uplc/Main.hs b/plutus-executables/executables/uplc/Main.hs index 9e1aa0b9ee3..55905972885 100644 --- a/plutus-executables/executables/uplc/Main.hs +++ b/plutus-executables/executables/uplc/Main.hs @@ -106,7 +106,8 @@ data BudgetMode data SomeBudgetMode = forall cost. (Eq cost, NFData cost, PrintBudgetState cost) => - SomeBudgetMode (Cek.ExBudgetMode cost PLC.DefaultUni PLC.DefaultFun) + SomeBudgetMode + (Cek.ExBudgetMode cost PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern) data EvalOptions = EvalOptions @@ -492,10 +493,10 @@ optimiseProgram :: forall m name a . (UPLC.HasUnique name UPLC.TermUnique, Monad m, Ord name, Typeable name) => UPLC.OptimizeOpts name a - -> UPLC.Program name UPLC.DefaultUni UPLC.DefaultFun a + -> UPLC.Program name UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern a -> m - ( UPLC.Program name UPLC.DefaultUni UPLC.DefaultFun a - , UPLC.OptimizerTrace name UPLC.DefaultUni UPLC.DefaultFun a + ( UPLC.Program name UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern a + , UPLC.OptimizerTrace name UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern a ) optimiseProgram opts prog = PLC.runQuoteT $ do renamed <- PLC.rename prog @@ -504,11 +505,16 @@ optimiseProgram opts prog = PLC.runQuoteT $ do UPLC.optimizeProgramWithTrace opts defaultBuiltinSemanticsVariant renamed execCertifier - :: UPLC.OptimizerTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a + :: UPLC.OptimizerTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern a -> CertName -> CertifierOutput -> [ ( Maybe - (Cek.CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + ( Cek.CekEvaluationException + UPLC.NamedDeBruijn + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + ) , ExBudget ) ] @@ -836,9 +842,9 @@ instance D.Breakpointable DAnn MaybeBreakpoint where -- Peel off one layer handleDbg - :: Cek.ThrowableBuiltins uni fun - => D.CekTrans uni fun DAnn RealWorld - -> D.DebugF uni fun DAnn MaybeBreakpoint (Repl.InputT IO ()) + :: (Cek.ThrowableBuiltins uni fun, Pretty pat, Typeable pat) + => D.CekTrans uni fun pat DAnn RealWorld + -> D.DebugF uni fun pat DAnn MaybeBreakpoint (Repl.InputT IO ()) -> Repl.InputT IO () handleDbg cekTrans = \case D.StepF prevState k -> do diff --git a/plutus-executables/plutus/AnyProgram/Compile.hs b/plutus-executables/plutus/AnyProgram/Compile.hs index f6638e39cfd..df3bf458739 100644 --- a/plutus-executables/plutus/AnyProgram/Compile.hs +++ b/plutus-executables/plutus/AnyProgram/Compile.hs @@ -180,9 +180,11 @@ pirTypecheck sngA p = PLC.runQuoteT $ do plcToUplcViaName :: (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m) => SNaming n - -> (PLC.Program PLC.TyName PLC.Name uni fun a -> m (UPLC.Program PLC.Name uni fun a)) + -> ( PLC.Program PLC.TyName PLC.Name uni fun a + -> m (UPLC.Program PLC.Name uni fun pat a) + ) -> PLC.Program (FromNameTy n) (FromName n) uni fun a - -> m (UPLC.Program (FromName n) uni fun a) + -> m (UPLC.Program (FromName n) uni fun pat a) plcToUplcViaName sngN act = case sngN of SName -> act SNamedDeBruijn -> @@ -211,10 +213,10 @@ plcToName sngN act = case sngN of uplcViaName :: (PLC.MonadQuote m, MonadError (PIR.Error uni fun ann) m) - => (UPLC.Program PLC.Name uni fun a -> m (UPLC.Program PLC.Name uni fun a)) + => (UPLC.Program PLC.Name uni fun pat a -> m (UPLC.Program PLC.Name uni fun pat a)) -> SNaming n - -> UPLC.Program (FromName n) uni fun a - -> m (UPLC.Program (FromName n) uni fun a) + -> UPLC.Program (FromName n) uni fun pat a + -> m (UPLC.Program (FromName n) uni fun pat a) uplcViaName act sngN = case sngN of SName -> act SNamedDeBruijn -> @@ -247,8 +249,20 @@ uplcOptimise , MonadError (PIR.Error DefaultUni DefaultFun a) m ) => SNaming n1 - -> UPLC.UnrestrictedProgram (FromName n1) DefaultUni DefaultFun a - -> m (UPLC.UnrestrictedProgram (FromName n1) DefaultUni DefaultFun a) + -> UPLC.UnrestrictedProgram + (FromName n1) + DefaultUni + DefaultFun + DefaultBuiltinPattern + a + -> m + ( UPLC.UnrestrictedProgram + (FromName n1) + DefaultUni + DefaultFun + DefaultBuiltinPattern + a + ) uplcOptimise = case _optimiseLvl ?opts of NoOptimise -> const pure -- short-circuit to avoid renaming @@ -264,11 +278,11 @@ uplcOptimise = -- | We do not have a typechecker for uplc, but we could pretend that scopecheck is a "typechecker" uplcTypecheck - :: forall sN sA uni fun m + :: forall sN sA uni fun pat m . MonadError (PLC.Error uni fun (FromAnn sA)) m => SNaming sN -> SAnn sA - -> UPLC.UnrestrictedProgram (FromName sN) uni fun (FromAnn sA) + -> UPLC.UnrestrictedProgram (FromName sN) uni fun pat (FromAnn sA) -> m () uplcTypecheck sngN sngA ast = case sngN of SName -> @@ -314,16 +328,16 @@ uplcToOutName :: MonadError FreeVariableError m => SNaming s1 -> SNaming s2 - -> UPLC.UnrestrictedProgram (FromName s1) uni fun ann - -> m (UPLC.UnrestrictedProgram (FromName s2) uni fun ann) + -> UPLC.UnrestrictedProgram (FromName s1) uni fun pat ann + -> m (UPLC.UnrestrictedProgram (FromName s2) uni fun pat ann) uplcToOutName = fmap _Wrapped . uplcToOutName' uplcToOutName' :: MonadError FreeVariableError m => SNaming s1 -> SNaming s2 - -> UPLC.Program (FromName s1) uni fun ann - -> m (UPLC.Program (FromName s2) uni fun ann) + -> UPLC.Program (FromName s1) uni fun pat ann + -> m (UPLC.Program (FromName s2) uni fun pat ann) uplcToOutName' sng1 ((sng1 %~) -> Proved Refl) = pure uplcToOutName' SName SNamedDeBruijn = UPLC.progTerm UPLC.deBruijnTerm uplcToOutName' SNamedDeBruijn SName = PLC.runQuoteT . UPLC.progTerm UPLC.unDeBruijnTerm diff --git a/plutus-executables/plutus/AnyProgram/Run.hs b/plutus-executables/plutus/AnyProgram/Run.hs index a11c04f0ecd..857eab46d21 100644 --- a/plutus-executables/plutus/AnyProgram/Run.hs +++ b/plutus-executables/plutus/AnyProgram/Run.hs @@ -62,7 +62,7 @@ runPlc (PLC.Program _ _ t) -- TODO: add a semantic variant here to get the right machine parameters runUplc :: (?opts :: Opts, Typeable a) - => UPLC.UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun a -> IO () + => UPLC.UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern a -> IO () runUplc (UPLC.UnrestrictedProgram (UPLC.Program _ _ t)) = case (\(UPLC.CekReport res cost logs) -> (UPLC.cekResultToEither res, cost, logs)) $ UPLC.runCekDeBruijn defaultCekParametersForTesting exBudgetMode logEmitter t of @@ -89,6 +89,6 @@ runUplc (UPLC.UnrestrictedProgram (UPLC.Program _ _ t)) = -- See Note [Budgeting implementation for the debugger] coerceMode :: Coercible cost ExBudget - => ExBudgetMode cost DefaultUni DefaultFun - -> ExBudgetMode ExBudget DefaultUni DefaultFun + => ExBudgetMode cost DefaultUni DefaultFun DefaultBuiltinPattern + -> ExBudgetMode ExBudget DefaultUni DefaultFun DefaultBuiltinPattern coerceMode = coerce diff --git a/plutus-executables/plutus/AnyProgram/With.hs b/plutus-executables/plutus/AnyProgram/With.hs index d64e066be0a..e5370ceaa37 100644 --- a/plutus-executables/plutus/AnyProgram/With.hs +++ b/plutus-executables/plutus/AnyProgram/With.hs @@ -92,7 +92,14 @@ withLangGeneral ) , ( forall name ann . (constrBinder (UPLC.Binder name), constrName name, constrAnn ann) - => constr (UPLC.UnrestrictedProgram name UPLC.DefaultUni UPLC.DefaultFun ann) + => constr + ( UPLC.UnrestrictedProgram + name + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + ann + ) ) ) => SLang s -> (constr (FromLang s) => r) -> r @@ -134,7 +141,14 @@ withLang ) , ( forall name ann . (constr (UPLC.Binder name), constr name, constr ann) - => constr (UPLC.UnrestrictedProgram name UPLC.DefaultUni UPLC.DefaultFun ann) + => constr + ( UPLC.UnrestrictedProgram + name + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + ann + ) ) ) => SLang s -> (constr (FromLang s) => r) -> r diff --git a/plutus-executables/plutus/Debugger/TUI/Main.hs b/plutus-executables/plutus/Debugger/TUI/Main.hs index 6170b89d4dc..34434b41d46 100644 --- a/plutus-executables/plutus/Debugger/TUI/Main.hs +++ b/plutus-executables/plutus/Debugger/TUI/Main.hs @@ -79,7 +79,10 @@ debuggerAttrMap = main :: (?opts :: Opts) - => SNaming n -> SAnn a -> UPLC.Program (FromName n) DefaultUni DefaultFun (FromAnn a) -> IO () + => SNaming n + -> SAnn a + -> UPLC.Program (FromName n) DefaultUni DefaultFun DefaultBuiltinPattern (FromAnn a) + -> IO () main sn sa prog = do -- turn it to ast with names progN <- either (fail . show @FreeVariableError) pure $ uplcToOutName' sn SName prog @@ -168,7 +171,7 @@ driverThread . (uni ~ DefaultUni, fun ~ DefaultFun, ann ~ DAnn) => MVar (D.Cmd Breakpoints) -> B.BChan CustomBrickEvent - -> Program Name uni fun ann + -> Program Name uni fun DefaultBuiltinPattern ann -> Maybe ExBudget -> IO () driverThread driverMailbox brickMailbox prog mbudget = do @@ -195,8 +198,8 @@ driverThread driverMailbox brickMailbox prog mbudget = do -- See Note [Budgeting implementation for the debugger] coerceMode :: Coercible cost ExBudget - => ExBudgetMode cost uni fun - -> ExBudgetMode ExBudget uni fun + => ExBudgetMode cost uni fun DefaultBuiltinPattern + -> ExBudgetMode ExBudget uni fun DefaultBuiltinPattern coerceMode = coerce -- Peels off one Free monad layer @@ -204,8 +207,10 @@ driverThread driverMailbox brickMailbox prog mbudget = do -- into a let block and avoid passing exbudgetinfo as parameter handle :: s ~ RealWorld - => (D.CekTrans uni fun ann s, ExBudgetInfo ExBudget uni fun s) - -> D.DebugF uni fun ann Breakpoints (IO ()) + => ( D.CekTrans uni fun DefaultBuiltinPattern ann s + , ExBudgetInfo ExBudget uni fun DefaultBuiltinPattern s + ) + -> D.DebugF uni fun DefaultBuiltinPattern ann Breakpoints (IO ()) -> IO () handle (cekTrans, exBudgetInfo) = \case D.StepF prevState k -> do @@ -233,11 +238,12 @@ driverThread driverMailbox brickMailbox prog mbudget = do handleLog = B.writeBChan brickMailbox . DriverLogEvent - readBudgetData :: ExBudgetInfo ExBudget uni fun RealWorld -> IO BudgetData + readBudgetData + :: ExBudgetInfo ExBudget uni fun DefaultBuiltinPattern RealWorld -> IO BudgetData readBudgetData (ExBudgetInfo _ final cumulative) = stToIO (BudgetData <$> cumulative <*> (for mbudget $ const final)) - brickEmitter :: EmitterMode uni fun + brickEmitter :: EmitterMode uni fun DefaultBuiltinPattern brickEmitter = EmitterMode $ \_ -> do -- the simplest solution relies on unsafeIOToPrim (here, unsafeIOToST) let emitter logs = for_ logs (unsafeIOToPrim . B.writeBChan brickMailbox . CekEmitEvent) diff --git a/plutus-executables/plutus/Debugger/TUI/Types.hs b/plutus-executables/plutus/Debugger/TUI/Types.hs index ffc5c615505..8920ea549cb 100644 --- a/plutus-executables/plutus/Debugger/TUI/Types.hs +++ b/plutus-executables/plutus/Debugger/TUI/Types.hs @@ -51,13 +51,15 @@ makeLenses ''BudgetData data CustomBrickEvent = {-| the driver passes a new cek state to the brick client this should mean that the brick client should update its tui -} - UpdateClientEvent BudgetData (CekState DefaultUni DefaultFun DAnn) + UpdateClientEvent BudgetData (CekState DefaultUni DefaultFun DefaultBuiltinPattern DAnn) | -- | the driver logged some text, the brick client can decide to show it in the tui DriverLogEvent Text | -- | the underlying cek machine emitted some text (using a trace or other builtin) CekEmitEvent Text | -- | the underlying cek machine errored (either by call to Error, builtin or type failure) - CekErrorEvent BudgetData (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun) + CekErrorEvent + BudgetData + (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern) data KeyBindingsMode = KeyBindingsShown | KeyBindingsHidden deriving stock (Eq, Ord, Show) diff --git a/plutus-executables/plutus/Types.hs b/plutus-executables/plutus/Types.hs index 2ca02593cb5..0f1c33a05cf 100644 --- a/plutus-executables/plutus/Types.hs +++ b/plutus-executables/plutus/Types.hs @@ -143,7 +143,8 @@ mkSomeFile ft fn = type family FromLang (lang :: Lang) = result | result -> lang where FromLang ('Pir n a) = PIR.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a) FromLang ('Plc n a) = PLC.Program (FromNameTy n) (FromName n) DefaultUni DefaultFun (FromAnn a) - FromLang ('Uplc n a) = UPLC.UnrestrictedProgram (FromName n) DefaultUni DefaultFun (FromAnn a) + FromLang ('Uplc n a) = + UPLC.UnrestrictedProgram (FromName n) DefaultUni DefaultFun DefaultBuiltinPattern (FromAnn a) FromLang 'Data = PLC.Data type family FromName (naming :: Naming) = result | result -> naming where diff --git a/plutus-executables/test/certifier/Test/Certifier/Executable.hs b/plutus-executables/test/certifier/Test/Certifier/Executable.hs index 97e1165f1ac..f7067817009 100644 --- a/plutus-executables/test/certifier/Test/Certifier/Executable.hs +++ b/plutus-executables/test/certifier/Test/Certifier/Executable.hs @@ -20,12 +20,12 @@ import Test.Tasty.HUnit unoptimised UPLC is fed to the optimiser with the certifier turned on, which will then call the Agda decision procedures for each of the phases. -} -loadUplc :: FilePath -> IO (Term Name DefaultUni DefaultFun ()) +loadUplc :: FilePath -> IO (Term Name DefaultUni DefaultFun DefaultBuiltinPattern ()) loadUplc path = UPLC._progTerm . void . snd <$> parseInput (FileInput path) simplify - :: Term Name DefaultUni DefaultFun () - -> OptimizerTrace Name DefaultUni DefaultFun () + :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> OptimizerTrace Name DefaultUni DefaultFun DefaultBuiltinPattern () simplify = runQuote . fmap snd @@ -38,7 +38,7 @@ loadAndMakeCert :: String -> IO FilePath loadAndMakeCert name = makeCert name =<< loadUplc (fixedPath "UPLC" name ++ ".uplc") -makeCert :: String -> Term Name DefaultUni DefaultFun () -> IO FilePath +makeCert :: String -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> IO FilePath makeCert name term = do time <- systemNanoseconds <$> getSystemTime let certDir = name <> "-" <> show time @@ -90,7 +90,8 @@ srcTests = , "builtinUnparse" ] -makeExampleTests :: [(String, Term Name DefaultUni DefaultFun ())] -> [TestTree] +makeExampleTests + :: [(String, Term Name DefaultUni DefaultFun DefaultBuiltinPattern ())] -> [TestTree] makeExampleTests = map (\(name, term) -> testCase name (makeCertAndCleanup name term)) where makeCertAndCleanup name term = makeCert name term >>= removeDirectoryRecursive @@ -103,7 +104,7 @@ makeSerialisationExampleTests :: [ String ] -> [ TestTree] makeSerialisationExampleTests = map (\testname -> testCase testname (agdaExampleCert testname)) -} -executableTests :: [(String, Term Name DefaultUni DefaultFun ())] -> TestTree +executableTests :: [(String, Term Name DefaultUni DefaultFun DefaultBuiltinPattern ())] -> TestTree executableTests examples = testGroup "certifier executable tests" diff --git a/plutus-ledger-api/exe/analyse-script-events/Main.hs b/plutus-ledger-api/exe/analyse-script-events/Main.hs index 7febdcef630..b75ec1e0fbd 100644 --- a/plutus-ledger-api/exe/analyse-script-events/Main.hs +++ b/plutus-ledger-api/exe/analyse-script-events/Main.hs @@ -299,7 +299,7 @@ analyseDatum _ctx _params ev = do l -> printf "* Unexpected number of %s script arguments: %d" (show ledgerLanguage) (length l) -- Print statistics about Data objects in a Term -analyseTermDataObjects :: Term NamedDeBruijn DefaultUni DefaultFun () -> IO () +analyseTermDataObjects :: Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () -> IO () analyseTermDataObjects = go where go = @@ -317,12 +317,14 @@ analyseTermDataObjects = go Error _ -> pure () UPLC.Constr _ _ ts -> mapM_ go ts Case _ t1 t2 -> go t1 >> mapM_ go t2 + Match _ scrutinee alternatives -> go scrutinee >> mapM_ (go . snd) alternatives -- Counting builtins type BuiltinCounts = P.MutablePrimArray (PrimState IO) Int -countBuiltinsInTerm :: BuiltinCounts -> Term NamedDeBruijn DefaultUni DefaultFun () -> IO () +countBuiltinsInTerm + :: BuiltinCounts -> Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () -> IO () countBuiltinsInTerm counts = go where go = \case @@ -336,6 +338,7 @@ countBuiltinsInTerm counts = go Error _ -> pure () UPLC.Constr _ _ ts -> mapM_ go ts Case _ t1 t2 -> go t1 >> mapM_ go t2 + Match _ scrutinee alternatives -> go scrutinee >> mapM_ (go . snd) alternatives incrCount i = do c <- P.readPrimArray counts i P.writePrimArray counts i (c + 1) @@ -439,7 +442,8 @@ analyseCosts ctx _ ev = (fromSatInt cpu, fromSatInt mem) -- Extract the script from an evaluation event and apply some analysis function -analyseUnappliedScript :: (Term NamedDeBruijn DefaultUni DefaultFun () -> IO ()) -> EventAnalyser +analyseUnappliedScript + :: (Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () -> IO ()) -> EventAnalyser analyseUnappliedScript analyse _ctx diff --git a/plutus-ledger-api/executables/src/PlutusCore/Executable/AstIO.hs b/plutus-ledger-api/executables/src/PlutusCore/Executable/AstIO.hs index b9a3f84ca2d..e122d1fdd09 100644 --- a/plutus-ledger-api/executables/src/PlutusCore/Executable/AstIO.hs +++ b/plutus-ledger-api/executables/src/PlutusCore/Executable/AstIO.hs @@ -61,16 +61,20 @@ import Data.Text.IO qualified as T import PlutusCore.Flat (Flat, flat, unflat) import System.FilePath (takeExtension) -type UplcProgDB ann = UPLC.Program PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ann -type UplcProgNDB ann = UPLC.Program PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun ann +type UplcProgDB ann = + UPLC.Program PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ann +type UplcProgNDB ann = + UPLC.Program PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ann type PlcProgDB ann = PLC.Program PLC.TyDeBruijn PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ann type PlcProgNDB ann = PLC.Program PLC.NamedTyDeBruijn PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun ann -- For the plutus-metatheory tests -type UplcTermDB ann = UPLC.Term PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ann -type UplcTermNDB ann = UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun ann +type UplcTermDB ann = + UPLC.Term PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ann +type UplcTermNDB ann = + UPLC.Term PLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ann type PlcTermDB ann = PLC.Term PLC.TyDeBruijn PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ann type PlcTermNDB ann = diff --git a/plutus-ledger-api/executables/src/PlutusCore/Executable/Common.hs b/plutus-ledger-api/executables/src/PlutusCore/Executable/Common.hs index 213c8a75657..43c17fa5632 100644 --- a/plutus-ledger-api/executables/src/PlutusCore/Executable/Common.hs +++ b/plutus-ledger-api/executables/src/PlutusCore/Executable/Common.hs @@ -182,6 +182,7 @@ printBudgetStateTally term model (Cek.CekExTally costs) = do putStrLn "" putStrLn $ "startup " ++ (budgetToString $ getSpent Cek.BStartup) putStrLn $ "compute " ++ budgetToString totalComputeCost + putStrLn $ "patterns " ++ budgetToString totalPatternCost putStrLn $ "AST nodes " ++ printf "%15d" (UPLC.unAstSize $ UPLC.termAstSize term) putStrLn "" case model of @@ -219,6 +220,7 @@ printBudgetStateTally term model (Cek.CekExTally costs) = do totalComputeCost = -- For unitCekCosts this will be the total number of compute steps foldMap (getSpent . Cek.BStep) allStepKinds + totalPatternCost = getSpent Cek.BPattern budgetToString (ExBudget (ExCPU cpu) (ExMemory mem)) = case model of -- Not %d: doesn't work when CostingInteger is SatInt. @@ -231,11 +233,12 @@ printBudgetStateTally term model (Cek.CekExTally costs) = do builtinsAndCosts = List.foldl getBuiltinCost [] (H.toList costs) totalBuiltinCosts = mconcat (map snd builtinsAndCosts) getCPU b = let ExCPU b' = exBudgetCPU b in fromSatInt b' :: Double - totalCost = getSpent Cek.BStartup <> totalComputeCost <> totalBuiltinCosts :: ExBudget + totalCost = + getSpent Cek.BStartup <> totalComputeCost <> totalPatternCost <> totalBuiltinCosts class PrintBudgetState cost where printBudgetState - :: UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun () + :: UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> CekModel -> cost -> IO () @@ -419,7 +422,7 @@ data SomeTypedExample = SomeTypeExample TypeExample | SomeTypedTermExample Typed newtype UntypedTermExample = UntypedTermExample - (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) + (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ()) newtype SomeUntypedExample = SomeUntypedTermExample UntypedTermExample data SomeExample = SomeTypedExample SomeTypedExample | SomeUntypedExample SomeUntypedExample diff --git a/plutus-ledger-api/executables/src/PlutusCore/Executable/Eval.hs b/plutus-ledger-api/executables/src/PlutusCore/Executable/Eval.hs index 1da05024ae2..f39bfa75c86 100644 --- a/plutus-ledger-api/executables/src/PlutusCore/Executable/Eval.hs +++ b/plutus-ledger-api/executables/src/PlutusCore/Executable/Eval.hs @@ -21,10 +21,10 @@ import Data.Functor (void) evalCounting :: EvaluationContext -> MajorProtocolVersion - -> UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun () + -> UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () -> ( Either - (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) - (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) + (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern) + (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern ()) , ExBudget ) evalCounting evalCtx pv term = @@ -43,7 +43,8 @@ mkDefaultEvalCtx semvar = either (error . show) id $ mkDynEvaluationContext PlutusV3 - (\_ -> PLC.CaserBuiltin PLC.caseBuiltin) + (\_ -> PLC.availableCaserBuiltin) + (\_ -> PLC.availableMatcherBuiltin) [semvar] (const semvar) p @@ -54,11 +55,11 @@ mkDefaultEvalCtx semvar = in counting mode. Returns @(Maybe error, budget)@. -} evalOptimizerTrace :: EvaluationContext - -> OptimizerTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a - -> [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()] + -> OptimizerTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern a + -> [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern ()] -- ^ Arguments to apply to each AST before evaluation -> [ ( Maybe - (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern) , ExBudget ) ] @@ -66,7 +67,8 @@ evalOptimizerTrace evalCtx trace args = first (either Just (const Nothing)) . evalCounting evalCtx newestPV <$> appliedTerms where - appliedTerms :: [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()] + appliedTerms + :: [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern ()] appliedTerms = ( \ast -> F.foldl' @@ -86,10 +88,10 @@ at the most recent protocol version with restrictingEnormous budget mode (no budget tracking overhead). Suitable for timing. -} evaluateCekLikeInProd :: EvaluationContext - -> UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun () + -> UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () -> Either - (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) - (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) + (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern) + (UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern ()) evaluateCekLikeInProd evalCtx term = cekResultToEither . _cekReportResult $ evaluateTerm restrictingEnormous newestPV Quiet evalCtx term @@ -98,12 +100,12 @@ evaluateCekLikeInProd evalCtx term = Returns @(Maybe error, budget)@. -} evalCountingWithArgs :: EvaluationContext - -> UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () + -> UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () -- ^ Main program - -> [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ()] + -> [UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern ()] -- ^ Arguments -> ( Maybe - (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern) , ExBudget ) evalCountingWithArgs evalCtx term args = diff --git a/plutus-ledger-api/executables/src/PlutusCore/Executable/OptimizerReport.hs b/plutus-ledger-api/executables/src/PlutusCore/Executable/OptimizerReport.hs index 5a8e78c7ff1..bbc37f7517d 100644 --- a/plutus-ledger-api/executables/src/PlutusCore/Executable/OptimizerReport.hs +++ b/plutus-ledger-api/executables/src/PlutusCore/Executable/OptimizerReport.hs @@ -36,7 +36,7 @@ type OptimizerReport = [ReportEntry] -- FIXME: we need a lot of `reverse` here because `OptimizerTrace` contains the passes -- in reverse order. buildReport - :: OptimizerTrace UPLC.Name uni fun a + :: OptimizerTrace UPLC.Name uni fun pat a -> [(Maybe err, ExBudget)] -> OptimizerReport buildReport trace (reverse -> costs) = diff --git a/plutus-ledger-api/executables/src/PlutusCore/Executable/Types.hs b/plutus-ledger-api/executables/src/PlutusCore/Executable/Types.hs index 7239dd533ca..438819a8848 100644 --- a/plutus-ledger-api/executables/src/PlutusCore/Executable/Types.hs +++ b/plutus-ledger-api/executables/src/PlutusCore/Executable/Types.hs @@ -30,11 +30,11 @@ type PlcTerm = -- | UPLC program type. type UplcProg = - UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun + UPLC.Program PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern -- | UPLC term type. type UplcTerm = - UPLC.Term UPLC.Name PLC.DefaultUni PLC.DefaultFun + UPLC.Term UPLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern ---------------- Types for commands and arguments ---------------- diff --git a/plutus-ledger-api/test/Spec/Data/Eval.hs b/plutus-ledger-api/test/Spec/Data/Eval.hs index 4cbab65e740..6bf9fcf84a0 100644 --- a/plutus-ledger-api/test/Spec/Data/Eval.hs +++ b/plutus-ledger-api/test/Spec/Data/Eval.hs @@ -37,7 +37,7 @@ import Test.Tasty.HUnit -- See Note [Direct UPLC code] -type T = Term DeBruijn DefaultUni DefaultFun () +type T = Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () {-| Evaluates scripts as they will be evaluated on-chain, by using the evaluation function we provide for the ledger. Notably, this goes via serialising and deserialising the program, so we can see any errors that might arise from that. -} diff --git a/plutus-ledger-api/test/Spec/Data/Versions.hs b/plutus-ledger-api/test/Spec/Data/Versions.hs index fe4f906fb78..67773635679 100644 --- a/plutus-ledger-api/test/Spec/Data/Versions.hs +++ b/plutus-ledger-api/test/Spec/Data/Versions.hs @@ -59,13 +59,16 @@ showPV (MajorProtocolVersion pv) = errorScript :: SerialisedScript errorScript = serialiseUPLC $ UPLC.Program () PLC.plcVersion100 $ UPLC.Error () -v110script :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +v110script + :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () v110script = UPLC.Program () PLC.plcVersion110 $ UPLC.Constr () 0 mempty -badConstrScript :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +badConstrScript + :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () badConstrScript = UPLC.Program () PLC.plcVersion100 $ UPLC.Constr () 0 mempty -badCaseScript :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +badCaseScript + :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () badCaseScript = UPLC.Program () PLC.plcVersion100 $ UPLC.Case () (UPLC.Error ()) mempty {- Given a UPLC term, serialise it then deserialise it for use in a particular @@ -79,8 +82,8 @@ badCaseScript = UPLC.Program () PLC.plcVersion100 $ UPLC.Case () (UPLC.Error ()) mkTestTerm :: PlutusLedgerLanguage -> MajorProtocolVersion - -> UPLC.Program DeBruijn DefaultUni DefaultFun () - -> Either ScriptDecodeError (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) + -> UPLC.Program DeBruijn DefaultUni DefaultFun UPLC.DefaultBuiltinPattern () + -> Either ScriptDecodeError (UPLC.Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) mkTestTerm ll pv prog = case deserialiseScript ll pv $ serialiseUPLC prog of Right s -> diff --git a/plutus-ledger-api/test/Spec/Eval.hs b/plutus-ledger-api/test/Spec/Eval.hs index 7e823579de0..3e4ad80ee1e 100644 --- a/plutus-ledger-api/test/Spec/Eval.hs +++ b/plutus-ledger-api/test/Spec/Eval.hs @@ -43,7 +43,7 @@ Because this is part of our API, we have to be careful not to change the behavio In particular, we test the online part (API module). -} -type T = Term DeBruijn DefaultUni DefaultFun () +type T = Term DeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () {-| Evaluates scripts as they will be evaluated on-chain, by using the evaluation function we provide for the ledger. Notably, this goes via serialising and deserialising the program, so we can see any errors that might arise from that. -} diff --git a/plutus-ledger-api/test/Spec/Versions.hs b/plutus-ledger-api/test/Spec/Versions.hs index ceb229acfcb..281a814ffe5 100644 --- a/plutus-ledger-api/test/Spec/Versions.hs +++ b/plutus-ledger-api/test/Spec/Versions.hs @@ -59,17 +59,21 @@ showPV (MajorProtocolVersion pv) = errorScript :: SerialisedScript errorScript = serialiseUPLC $ UPLC.Program () PLC.plcVersion100 $ UPLC.Error () -v100script :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +v100script + :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () v100script = UPLC.Program () PLC.plcVersion100 $ UPLC.Constant () (PLC.Some (PLC.ValueOf PLC.DefaultUniUnit ())) -v110script :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +v110script + :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () v110script = UPLC.Program () PLC.plcVersion110 $ UPLC.Constr () 0 mempty -badConstrScript :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +badConstrScript + :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () badConstrScript = UPLC.Program () PLC.plcVersion100 $ UPLC.Constr () 0 mempty -badCaseScript :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +badCaseScript + :: UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () badCaseScript = UPLC.Program () PLC.plcVersion100 $ UPLC.Case () (UPLC.Error ()) mempty {- Given a UPLC term, serialise it then deserialise it for use in a particular @@ -83,8 +87,8 @@ badCaseScript = UPLC.Program () PLC.plcVersion100 $ UPLC.Case () (UPLC.Error ()) mkTestTerm :: PlutusLedgerLanguage -> MajorProtocolVersion - -> UPLC.Program DeBruijn DefaultUni DefaultFun () - -> Either ScriptDecodeError (UPLC.Term NamedDeBruijn DefaultUni DefaultFun ()) + -> UPLC.Program DeBruijn DefaultUni DefaultFun UPLC.DefaultBuiltinPattern () + -> Either ScriptDecodeError (UPLC.Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()) mkTestTerm ll pv prog = case deserialiseScript ll pv $ serialiseUPLC prog of Right s -> diff --git a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Scripts.hs b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Scripts.hs index ba841b99093..e1c034886d0 100644 --- a/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Scripts.hs +++ b/plutus-ledger-api/testlib/PlutusLedgerApi/Test/Scripts.hs @@ -15,7 +15,7 @@ import UntypedPlutusCore qualified as UPLC uplcToScriptForEvaluation :: PlutusLedgerLanguage -> MajorProtocolVersion - -> UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () + -> UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern () -> Either ScriptDecodeError ScriptForEvaluation uplcToScriptForEvaluation ll pv = deserialiseScript ll pv . serialiseUPLC diff --git a/plutus-metatheory/src/Certifier.hs b/plutus-metatheory/src/Certifier.hs index 507675a00e3..6c27169fa5d 100644 --- a/plutus-metatheory/src/Certifier.hs +++ b/plutus-metatheory/src/Certifier.hs @@ -86,13 +86,13 @@ runCertifier = runExceptT -- | Run the Agda certifier on the simplification trace, if requested mkCertifier - :: OptimizerTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a + :: OptimizerTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern a -- ^ The trace produced by the simplification process -> CertName -- ^ The name of the certificate to be produced -> CertifierOutput -> [ ( Maybe - (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern) , ExBudget ) ] diff --git a/plutus-metatheory/src/Evaluator/Program.lagda.md b/plutus-metatheory/src/Evaluator/Program.lagda.md index 77d6c61dce0..d2d98482f97 100644 --- a/plutus-metatheory/src/Evaluator/Program.lagda.md +++ b/plutus-metatheory/src/Evaluator/Program.lagda.md @@ -96,8 +96,8 @@ postulate {-# COMPILE GHC convP = convP #-} {-# COMPILE GHC deBruijnify = \ (Program ann ver tm) -> second (void . Program ann ver) . runExcept $ deBruijnTerm tm #-} -{-# COMPILE GHC ProgramNU = type U.Program Name DefaultUni DefaultFun PlutusCore.SrcSpan #-} -{-# COMPILE GHC ProgramU = type U.Program NamedDeBruijn DefaultUni DefaultFun () #-} +{-# COMPILE GHC ProgramNU = type U.Program Name DefaultUni DefaultFun DefaultBuiltinPattern PlutusCore.SrcSpan #-} +{-# COMPILE GHC ProgramU = type U.Program NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () #-} {-# COMPILE GHC deBruijnifyU = \ (U.Program ann ver tm) -> second (void . U.Program ann ver) . runExcept $ U.deBruijnTerm tm #-} {-# COMPILE GHC convPU = U.convP #-} @@ -231,4 +231,3 @@ typeCheckProgramN namedprog = do -} return (prettyPrintTy (unshifterTy Z (extricateScopeTy (extricateNf⋆ A)))) ``` - diff --git a/plutus-metatheory/src/Evaluator/Term.lagda.md b/plutus-metatheory/src/Evaluator/Term.lagda.md index 8ddfc7ca1c9..64b4c0ab90e 100644 --- a/plutus-metatheory/src/Evaluator/Term.lagda.md +++ b/plutus-metatheory/src/Evaluator/Term.lagda.md @@ -84,8 +84,8 @@ postulate {-# COMPILE GHC Type = type PlutusCore.Type NamedTyDeBruijn DefaultUni () #-} {-# COMPILE GHC TermN = type PlutusCore.Term TyName Name DefaultUni DefaultFun PlutusCore.SrcSpan #-} {-# COMPILE GHC TypeN = type PlutusCore.Type TyName DefaultUni PlutusCore.SrcSpan #-} -{-# COMPILE GHC TermNU = type U.Term Name DefaultUni DefaultFun PlutusCore.SrcSpan #-} -{-# COMPILE GHC TermU = type U.Term NamedDeBruijn DefaultUni DefaultFun () #-} +{-# COMPILE GHC TermNU = type U.Term Name DefaultUni DefaultFun DefaultBuiltinPattern PlutusCore.SrcSpan #-} +{-# COMPILE GHC TermU = type U.Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () #-} postulate parseTm : String → Either ParseError TermN diff --git a/plutus-metatheory/src/FFI/AgdaUnparse.hs b/plutus-metatheory/src/FFI/AgdaUnparse.hs index c6729c9f8f9..4d771102c6f 100644 --- a/plutus-metatheory/src/FFI/AgdaUnparse.hs +++ b/plutus-metatheory/src/FFI/AgdaUnparse.hs @@ -95,6 +95,7 @@ instance AgdaUnparse Hints.Inline where Hints.InlError -> "error" Hints.InlConstr ts -> parens ("constr" <+> agdaUnparse ts) Hints.InlCase t ts -> parens ("case" <+> agdaUnparse t <+> agdaUnparse ts) + Hints.InlMatch _ _ -> error "UPLC 1.2 'match' hints are not yet supported by the Agda certifier" Hints.InlExpand t -> parens ("expand" <+> agdaUnparse t) Hints.InlDrop t -> parens (agdaUnparse t <+> "·↓") diff --git a/plutus-metatheory/src/FFI/OptimizerTrace.hs b/plutus-metatheory/src/FFI/OptimizerTrace.hs index ad0561db2e2..ec6ba1168b1 100644 --- a/plutus-metatheory/src/FFI/OptimizerTrace.hs +++ b/plutus-metatheory/src/FFI/OptimizerTrace.hs @@ -27,12 +27,18 @@ import Data.Text qualified as T type Trace a = NonEmptySep (OptStage, Hints) a mkFfiOptimizerTrace - :: OptimizerTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a + :: OptimizerTrace UPLC.Name UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern a -> Trace FFI.UTerm mkFfiOptimizerTrace (OptimizerTrace simplNonEmptySep) = go (reverse simplNonEmptySep) where go - :: [Optimization UPLC.Name UPLC.DefaultUni UPLC.DefaultFun a] + :: [ Optimization + UPLC.Name + UPLC.DefaultUni + UPLC.DefaultFun + UPLC.DefaultBuiltinPattern + a + ] -> Trace FFI.UTerm go [] = error "Empty trace" go [Optimization before stage hints after] = @@ -52,7 +58,8 @@ mkFfiOptimizerTrace (OptimizerTrace simplNonEmptySep) = go (reverse simplNonEmpt Left (err :: UPLC.FreeVariableError) -> error $ show err toEvalResult - :: Maybe (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + :: Maybe + (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern) -> ExBudget -> EvalResult toEvalResult res budget = case res of diff --git a/plutus-metatheory/src/FFI/Untyped.hs b/plutus-metatheory/src/FFI/Untyped.hs index 11dff97b0ba..568b0b88b02 100644 --- a/plutus-metatheory/src/FFI/Untyped.hs +++ b/plutus-metatheory/src/FFI/Untyped.hs @@ -32,10 +32,10 @@ data UTerm unIndex :: Index -> Integer unIndex (Index n) = toInteger n -convP :: Program NamedDeBruijn DefaultUni DefaultFun a -> UTerm +convP :: Program NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern a -> UTerm convP (Program _ _ t) = conv t -conv :: Term NamedDeBruijn DefaultUni DefaultFun a -> UTerm +conv :: Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern a -> UTerm conv (Var _ x) = UVar (unIndex (ndbnIndex x) - 1) conv (LamAbs _ _ t) = ULambda (conv t) conv (Apply _ t u) = UApp (conv t) (conv u) @@ -46,11 +46,12 @@ conv (Delay _ t) = UDelay (conv t) conv (Force _ t) = UForce (conv t) conv (Constr _ i es) = UConstr (toInteger i) (toList (fmap conv es)) conv (Case _ arg cs) = UCase (conv arg) (toList (fmap conv cs)) +conv Match {} = error "UPLC 1.2 'match' is not yet supported by the Agda metatheory" tmname :: Int -> String tmname i = 'x' : show i -uconv :: Int -> UTerm -> Term NamedDeBruijn DefaultUni DefaultFun () +uconv :: Int -> UTerm -> Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () uconv i (UVar x) = Var () diff --git a/plutus-metatheory/src/MAlonzo/Code/Certifier.hs b/plutus-metatheory/src/MAlonzo/Code/Certifier.hs index 901c2d7c80a..9f2b4e889c6 100644 --- a/plutus-metatheory/src/MAlonzo/Code/Certifier.hs +++ b/plutus-metatheory/src/MAlonzo/Code/Certifier.hs @@ -30,12 +30,12 @@ import qualified MAlonzo.Code.VerifiedCompilation.Trace -- Certifier.runCertifier d_runCertifier_2 :: - MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.RawU.T_Untyped_208 -> MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.T_Error_2 @@ -61,29 +61,29 @@ d_runCertifier_2 v0 MAlonzo.Code.Agda.Builtin.Sigma.C__'44'__32 (coe v1) (coe v2)))))) -- Certifier.runCertifierMain runCertifierMain :: - MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.RawU.T_Untyped_208 -> MAlonzo.Code.Agda.Builtin.List.T_List_10 - () MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_122 -> + () MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_124 -> MAlonzo.Code.Agda.Builtin.Maybe.T_Maybe_10 () (MAlonzo.Code.Utils.T__'215'__436 Bool MAlonzo.Code.Agda.Builtin.String.T_String_6) runCertifierMain = coe d_runCertifierMain_10 d_runCertifierMain_10 :: - MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.RawU.T_Untyped_208 -> - [MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_122] -> + [MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_124] -> Maybe (MAlonzo.Code.Utils.T__'215'__436 Bool MAlonzo.Code.Agda.Builtin.String.T_String_6) diff --git a/plutus-metatheory/src/MAlonzo/Code/CertifierReport.hs b/plutus-metatheory/src/MAlonzo/Code/CertifierReport.hs index dea2d0e132c..1325fc8854a 100644 --- a/plutus-metatheory/src/MAlonzo/Code/CertifierReport.hs +++ b/plutus-metatheory/src/MAlonzo/Code/CertifierReport.hs @@ -670,11 +670,11 @@ d_termSize'7510''695'_216 v0 v1 _ -> MAlonzo.RTE.mazUnreachableError -- CertifierReport.showEvalResult d_showEvalResult_238 :: - MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_122 -> + MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_124 -> MAlonzo.Code.Agda.Builtin.String.T_String_6 d_showEvalResult_238 v0 = case coe v0 of - MAlonzo.Code.VerifiedCompilation.Trace.C_success_124 v1 v2 + MAlonzo.Code.VerifiedCompilation.Trace.C_success_126 v1 v2 -> coe MAlonzo.Code.Data.String.Base.d__'43''43'__20 (d_'8649'__2 (coe ("Execution Cost: CPU = " :: Data.Text.Text))) @@ -685,7 +685,7 @@ d_showEvalResult_238 v0 MAlonzo.Code.Data.String.Base.d__'43''43'__20 (", MEM = " :: Data.Text.Text) (coe MAlonzo.Code.Data.Nat.Show.d_show_56 v2))) - MAlonzo.Code.VerifiedCompilation.Trace.C_failure_126 v1 v2 v3 + MAlonzo.Code.VerifiedCompilation.Trace.C_failure_128 v1 v2 v3 -> coe MAlonzo.Code.Data.String.Base.d__'43''43'__20 (d_'8649'__2 (coe ("Evaluation FAILED: " :: Data.Text.Text))) @@ -706,7 +706,7 @@ d_showEvalResult_238 v0 _ -> MAlonzo.RTE.mazUnreachableError -- CertifierReport.showCostPair d_showCostPair_250 :: - [MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_122] -> + [MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_124] -> MAlonzo.Code.Agda.Builtin.String.T_String_6 d_showCostPair_250 v0 = let v1 = "" :: Data.Text.Text in @@ -740,19 +740,19 @@ du_tail_258 v0 -- CertifierReport.reportPasses d_reportPasses_268 :: Integer -> - MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.Untyped.T__'8866'_14 -> AgdaAny -> - [MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_122] -> + [MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_124] -> MAlonzo.Code.Agda.Builtin.String.T_String_6 d_reportPasses_268 v0 v1 v2 v3 = case coe v1 of - MAlonzo.Code.VerifiedCompilation.Trace.C_cons_96 v4 v5 v6 + MAlonzo.Code.VerifiedCompilation.Trace.C_cons_98 v4 v5 v6 -> case coe v5 of MAlonzo.Code.Utils.C__'44'__450 v7 v8 -> case coe v2 of @@ -802,7 +802,7 @@ d_reportPasses_268 v0 v1 v2 v3 (d_termSize_212 (coe (0 :: Integer)) (coe - MAlonzo.Code.VerifiedCompilation.Trace.d_head_112 + MAlonzo.Code.VerifiedCompilation.Trace.d_head_114 (coe v6)))) (coe MAlonzo.Code.Data.String.Base.d__'43''43'__20 @@ -821,7 +821,7 @@ d_reportPasses_268 v0 v1 v2 v3 (d_showSites_204 (coe v4) (coe - MAlonzo.Code.VerifiedCompilation.Trace.d_head_112 + MAlonzo.Code.VerifiedCompilation.Trace.d_head_114 (coe v6)) (coe v7) (coe v9)) (coe @@ -841,7 +841,7 @@ d_reportPasses_268 v0 v1 v2 v3 v3)))))))))))))))))))) _ -> MAlonzo.RTE.mazUnreachableError _ -> MAlonzo.RTE.mazUnreachableError - MAlonzo.Code.VerifiedCompilation.Trace.C_singleton_98 v4 + MAlonzo.Code.VerifiedCompilation.Trace.C_singleton_100 v4 -> coe ("" :: Data.Text.Text) _ -> MAlonzo.RTE.mazUnreachableError -- CertifierReport.reportFailure @@ -896,7 +896,7 @@ d_makeReport_290 :: MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.T_Error_2 MAlonzo.Code.Agda.Builtin.Sigma.T_Σ_14 -> - [MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_122] -> + [MAlonzo.Code.VerifiedCompilation.Trace.T_EvalResult_124] -> MAlonzo.Code.Agda.Builtin.String.T_String_6 d_makeReport_290 v0 v1 = coe diff --git a/plutus-metatheory/src/MAlonzo/Code/Evaluator/Program.hs b/plutus-metatheory/src/MAlonzo/Code/Evaluator/Program.hs index 5e9e90e33c5..5e912853219 100644 --- a/plutus-metatheory/src/MAlonzo/Code/Evaluator/Program.hs +++ b/plutus-metatheory/src/MAlonzo/Code/Evaluator/Program.hs @@ -94,13 +94,13 @@ d_deBruijnify_24 = \ (Program ann ver tm) -> second (void . Program ann ver) . runExcept $ deBruijnTerm tm -- Evaluator.Program.ProgramNU type T_ProgramNU_26 = - U.Program Name DefaultUni DefaultFun PlutusCore.SrcSpan + U.Program Name DefaultUni DefaultFun DefaultBuiltinPattern PlutusCore.SrcSpan d_ProgramNU_26 = error "MAlonzo Runtime Error: postulate evaluated: Evaluator.Program.ProgramNU" -- Evaluator.Program.ProgramU type T_ProgramU_28 = - U.Program NamedDeBruijn DefaultUni DefaultFun () + U.Program NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () d_ProgramU_28 = error "MAlonzo Runtime Error: postulate evaluated: Evaluator.Program.ProgramU" diff --git a/plutus-metatheory/src/MAlonzo/Code/Evaluator/Term.hs b/plutus-metatheory/src/MAlonzo/Code/Evaluator/Term.hs index bbb9460db1d..18399f2032a 100644 --- a/plutus-metatheory/src/MAlonzo/Code/Evaluator/Term.hs +++ b/plutus-metatheory/src/MAlonzo/Code/Evaluator/Term.hs @@ -81,12 +81,13 @@ d_TypeN_20 "MAlonzo Runtime Error: postulate evaluated: Evaluator.Term.TypeN" -- Evaluator.Term.TermNU type T_TermNU_22 = - U.Term Name DefaultUni DefaultFun PlutusCore.SrcSpan + U.Term Name DefaultUni DefaultFun DefaultBuiltinPattern PlutusCore.SrcSpan d_TermNU_22 = error "MAlonzo Runtime Error: postulate evaluated: Evaluator.Term.TermNU" -- Evaluator.Term.TermU -type T_TermU_24 = U.Term NamedDeBruijn DefaultUni DefaultFun () +type T_TermU_24 = + U.Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () d_TermU_24 = error "MAlonzo Runtime Error: postulate evaluated: Evaluator.Term.TermU" diff --git a/plutus-metatheory/src/MAlonzo/Code/VerifiedCompilation.hs b/plutus-metatheory/src/MAlonzo/Code/VerifiedCompilation.hs index a94fa43dc19..07d8f048fa5 100644 --- a/plutus-metatheory/src/MAlonzo/Code/VerifiedCompilation.hs +++ b/plutus-metatheory/src/MAlonzo/Code/VerifiedCompilation.hs @@ -71,7 +71,7 @@ d_certifyPass_26 :: MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12 -> - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80 -> + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82 -> MAlonzo.Code.Untyped.T__'8866'_14 -> MAlonzo.Code.Untyped.T__'8866'_14 -> MAlonzo.Code.VerifiedCompilation.Certificate.T_CertResult_12 @@ -104,13 +104,13 @@ d_certifyPass_26 v0 v1 (coe (0 :: Integer))) MAlonzo.Code.VerifiedCompilation.Trace.C_inlineT_20 -> case coe v1 of - MAlonzo.Code.VerifiedCompilation.Trace.C_inline_82 v3 + MAlonzo.Code.VerifiedCompilation.Trace.C_inline_84 v3 -> coe MAlonzo.Code.VerifiedCompilation.Certificate.du_checker_168 (coe MAlonzo.Code.VerifiedCompilation.UInline.d_top'45'check_718 (coe v3)) - MAlonzo.Code.VerifiedCompilation.Trace.C_none_84 + MAlonzo.Code.VerifiedCompilation.Trace.C_none_86 -> coe MAlonzo.Code.VerifiedCompilation.Certificate.C_abort_32 (coe MAlonzo.Code.VerifiedCompilation.Trace.d_InlineT_38) @@ -143,34 +143,34 @@ d_certifyPass_26 v0 v1 _ -> MAlonzo.RTE.mazUnreachableError -- VerifiedCompilation.Certificate d_Certificate_34 :: - MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.Untyped.T__'8866'_14 -> () d_Certificate_34 = erased -- VerifiedCompilation.certify d_certify_46 :: - MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.Untyped.T__'8866'_14 -> MAlonzo.Code.Utils.T_Either_6 T_Error_2 AgdaAny d_certify_46 v0 = case coe v0 of - MAlonzo.Code.VerifiedCompilation.Trace.C_cons_96 v1 v2 v3 + MAlonzo.Code.VerifiedCompilation.Trace.C_cons_98 v1 v2 v3 -> case coe v2 of MAlonzo.Code.Utils.C__'44'__450 v4 v5 -> let v6 = coe d_certifyPass_26 v4 v5 v1 - (MAlonzo.Code.VerifiedCompilation.Trace.d_head_112 (coe v3)) in + (MAlonzo.Code.VerifiedCompilation.Trace.d_head_114 (coe v3)) in coe (case coe v6 of MAlonzo.Code.VerifiedCompilation.Certificate.C_proof_18 v7 @@ -189,19 +189,19 @@ d_certify_46 v0 -> coe MAlonzo.Code.Utils.C_inj'8321'_12 (coe C_abort_10 (coe v9)) _ -> MAlonzo.RTE.mazUnreachableError) _ -> MAlonzo.RTE.mazUnreachableError - MAlonzo.Code.VerifiedCompilation.Trace.C_singleton_98 v1 + MAlonzo.Code.VerifiedCompilation.Trace.C_singleton_100 v1 -> coe MAlonzo.Code.Utils.C_inj'8322'_14 (coe MAlonzo.Code.Agda.Builtin.Unit.C_tt_8) _ -> MAlonzo.RTE.mazUnreachableError -- VerifiedCompilation.cert d_cert_96 :: - MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.Untyped.T__'8866'_14 -> MAlonzo.Code.Utils.T_Either_6 T_Error_2 AgdaAny -> AgdaAny -> AgdaAny @@ -223,24 +223,24 @@ d_checkScope_100 v0 (coe MAlonzo.Code.Untyped.d_scopeCheckU0_288 (coe v0)) -- VerifiedCompilation.checkScopeᵗ d_checkScope'7511'_102 :: - MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.RawU.T_Untyped_208 -> Maybe - (MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_90 + (MAlonzo.Code.VerifiedCompilation.Trace.T_NonEmptySep_92 (MAlonzo.Code.Utils.T__'215'__436 (MAlonzo.Code.Utils.T_Either_6 MAlonzo.Code.VerifiedCompilation.Trace.T_UncertifiedOptTag_4 MAlonzo.Code.VerifiedCompilation.Trace.T_CertifiedOptTag_12) - MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_80) + MAlonzo.Code.VerifiedCompilation.Trace.T_Hints_82) MAlonzo.Code.Untyped.T__'8866'_14) d_checkScope'7511'_102 v0 = case coe v0 of - MAlonzo.Code.VerifiedCompilation.Trace.C_cons_96 v1 v2 v3 + MAlonzo.Code.VerifiedCompilation.Trace.C_cons_98 v1 v2 v3 -> coe seq (coe v2) (coe @@ -256,9 +256,9 @@ d_checkScope'7511'_102 v0 coe MAlonzo.Code.Agda.Builtin.Maybe.C_just_16 (coe - MAlonzo.Code.VerifiedCompilation.Trace.C_cons_96 (coe v4) + MAlonzo.Code.VerifiedCompilation.Trace.C_cons_98 (coe v4) (coe v2) (coe v5))))))) - MAlonzo.Code.VerifiedCompilation.Trace.C_singleton_98 v1 + MAlonzo.Code.VerifiedCompilation.Trace.C_singleton_100 v1 -> coe MAlonzo.Code.Data.Maybe.Base.du__'62''62''61'__72 (coe d_checkScope_100 (coe v1)) @@ -267,5 +267,5 @@ d_checkScope'7511'_102 v0 coe MAlonzo.Code.Agda.Builtin.Maybe.C_just_16 (coe - MAlonzo.Code.VerifiedCompilation.Trace.C_singleton_98 (coe v2)))) + MAlonzo.Code.VerifiedCompilation.Trace.C_singleton_100 (coe v2)))) _ -> MAlonzo.RTE.mazUnreachableError diff --git a/plutus-metatheory/src/MAlonzo/Code/VerifiedCompilation/Trace.hs b/plutus-metatheory/src/MAlonzo/Code/VerifiedCompilation/Trace.hs index da8ebbcb61a..de1cfa9b109 100644 --- a/plutus-metatheory/src/MAlonzo/Code/VerifiedCompilation/Trace.hs +++ b/plutus-metatheory/src/MAlonzo/Code/VerifiedCompilation/Trace.hs @@ -164,6 +164,7 @@ pattern C_builtin_72 = Hints.InlBuiltin pattern C_error_74 = Hints.InlError pattern C_constr_76 a0 = Hints.InlConstr a0 pattern C_case_78 a0 a1 = Hints.InlCase a0 a1 +pattern C_matchHint_80 a0 a1 = Hints.InlMatch a0 a1 check_var_56 :: T_InlineHints_54 check_var_56 = Hints.InlVar check_expand_58 :: T_InlineHints_54 -> T_InlineHints_54 @@ -194,6 +195,11 @@ check_case_78 :: MAlonzo.Code.Agda.Builtin.List.T_List_10 () T_InlineHints_54 -> T_InlineHints_54 check_case_78 = Hints.InlCase +check_matchHint_80 :: + T_InlineHints_54 -> + MAlonzo.Code.Agda.Builtin.List.T_List_10 () T_InlineHints_54 -> + T_InlineHints_54 +check_matchHint_80 = Hints.InlMatch cover_InlineHints_54 :: Hints.Inline -> () cover_InlineHints_54 x = case x of @@ -209,61 +215,62 @@ cover_InlineHints_54 x Hints.InlError -> () Hints.InlConstr _ -> () Hints.InlCase _ _ -> () + Hints.InlMatch _ _ -> () -- VerifiedCompilation.Trace.Hints -d_Hints_80 = () -type T_Hints_80 = Hints.Hints -pattern C_inline_82 a0 = Hints.Inline a0 -pattern C_none_84 = Hints.NoHints -check_inline_82 :: T_InlineHints_54 -> T_Hints_80 -check_inline_82 = Hints.Inline -check_none_84 :: T_Hints_80 -check_none_84 = Hints.NoHints -cover_Hints_80 :: Hints.Hints -> () -cover_Hints_80 x +d_Hints_82 = () +type T_Hints_82 = Hints.Hints +pattern C_inline_84 a0 = Hints.Inline a0 +pattern C_none_86 = Hints.NoHints +check_inline_84 :: T_InlineHints_54 -> T_Hints_82 +check_inline_84 = Hints.Inline +check_none_86 :: T_Hints_82 +check_none_86 = Hints.NoHints +cover_Hints_82 :: Hints.Hints -> () +cover_Hints_82 x = case x of Hints.Inline _ -> () Hints.NoHints -> () -- VerifiedCompilation.Trace.NonEmptySep -d_NonEmptySep_90 a0 a1 = () -type T_NonEmptySep_90 a0 a1 = NES.NonEmptySep a0 a1 -pattern C_cons_96 a0 a1 a2 = NES.Cons a0 a1 a2 -pattern C_singleton_98 a0 = NES.Singleton a0 -check_cons_96 :: +d_NonEmptySep_92 a0 a1 = () +type T_NonEmptySep_92 a0 a1 = NES.NonEmptySep a0 a1 +pattern C_cons_98 a0 a1 a2 = NES.Cons a0 a1 a2 +pattern C_singleton_100 a0 = NES.Singleton a0 +check_cons_98 :: forall xS. forall xA. - xA -> xS -> T_NonEmptySep_90 xS xA -> T_NonEmptySep_90 xS xA -check_cons_96 = NES.Cons -check_singleton_98 :: - forall xS. forall xA. xA -> T_NonEmptySep_90 xS xA -check_singleton_98 = NES.Singleton -cover_NonEmptySep_90 :: NES.NonEmptySep a1 a2 -> () -cover_NonEmptySep_90 x + xA -> xS -> T_NonEmptySep_92 xS xA -> T_NonEmptySep_92 xS xA +check_cons_98 = NES.Cons +check_singleton_100 :: + forall xS. forall xA. xA -> T_NonEmptySep_92 xS xA +check_singleton_100 = NES.Singleton +cover_NonEmptySep_92 :: NES.NonEmptySep a1 a2 -> () +cover_NonEmptySep_92 x = case x of NES.Cons _ _ _ -> () NES.Singleton _ -> () -- VerifiedCompilation.Trace.head -d_head_112 :: T_NonEmptySep_90 AgdaAny AgdaAny -> AgdaAny -d_head_112 v0 +d_head_114 :: T_NonEmptySep_92 AgdaAny AgdaAny -> AgdaAny +d_head_114 v0 = case coe v0 of - C_cons_96 v1 v2 v3 -> coe v1 - C_singleton_98 v1 -> coe v1 + C_cons_98 v1 v2 v3 -> coe v1 + C_singleton_100 v1 -> coe v1 _ -> MAlonzo.RTE.mazUnreachableError -- VerifiedCompilation.Trace.Trace -d_Trace_118 :: () -> () -d_Trace_118 = erased +d_Trace_120 :: () -> () +d_Trace_120 = erased -- VerifiedCompilation.Trace.EvalResult -d_EvalResult_122 = () -type T_EvalResult_122 = EvalResult -pattern C_success_124 a0 a1 = EvalSuccess a0 a1 -pattern C_failure_126 a0 a1 a2 = EvalFailure a0 a1 a2 -check_success_124 :: Integer -> Integer -> T_EvalResult_122 -check_success_124 = EvalSuccess -check_failure_126 :: +d_EvalResult_124 = () +type T_EvalResult_124 = EvalResult +pattern C_success_126 a0 a1 = EvalSuccess a0 a1 +pattern C_failure_128 a0 a1 a2 = EvalFailure a0 a1 a2 +check_success_126 :: Integer -> Integer -> T_EvalResult_124 +check_success_126 = EvalSuccess +check_failure_128 :: MAlonzo.Code.Agda.Builtin.String.T_String_6 -> - Integer -> Integer -> T_EvalResult_122 -check_failure_126 = EvalFailure -cover_EvalResult_122 :: EvalResult -> () -cover_EvalResult_122 x + Integer -> Integer -> T_EvalResult_124 +check_failure_128 = EvalFailure +cover_EvalResult_124 :: EvalResult -> () +cover_EvalResult_124 x = case x of EvalSuccess _ _ -> () EvalFailure _ _ _ -> () diff --git a/plutus-metatheory/src/VerifiedCompilation/Trace.lagda.md b/plutus-metatheory/src/VerifiedCompilation/Trace.lagda.md index 64d1eff30c7..79382fab26f 100644 --- a/plutus-metatheory/src/VerifiedCompilation/Trace.lagda.md +++ b/plutus-metatheory/src/VerifiedCompilation/Trace.lagda.md @@ -110,6 +110,7 @@ data InlineHints : Set where error : InlineHints constr : List InlineHints → InlineHints case : InlineHints → List InlineHints → InlineHints + matchHint : InlineHints → List InlineHints → InlineHints data Hints : Set where inline : InlineHints → Hints @@ -117,7 +118,7 @@ data Hints : Set where {-# FOREIGN GHC import UntypedPlutusCore.Transform.Certify.Trace #-} {-# FOREIGN GHC import qualified UntypedPlutusCore.Transform.Certify.Hints as Hints #-} -{-# COMPILE GHC InlineHints = data Hints.Inline (Hints.InlVar | Hints.InlExpand | Hints.InlLam | Hints.InlApply | Hints.InlDrop | Hints.InlForce | Hints.InlDelay | Hints.InlCon | Hints.InlBuiltin | Hints.InlError | Hints.InlConstr | Hints.InlCase) #-} +{-# COMPILE GHC InlineHints = data Hints.Inline (Hints.InlVar | Hints.InlExpand | Hints.InlLam | Hints.InlApply | Hints.InlDrop | Hints.InlForce | Hints.InlDelay | Hints.InlCon | Hints.InlBuiltin | Hints.InlError | Hints.InlConstr | Hints.InlCase | Hints.InlMatch) #-} {-# COMPILE GHC Hints = data Hints.Hints (Hints.Inline | Hints.NoHints) #-} ``` diff --git a/plutus-metatheory/test/certifier-report/Test/Certifier/Report.hs b/plutus-metatheory/test/certifier-report/Test/Certifier/Report.hs index 28fadca1589..3f5696afba1 100644 --- a/plutus-metatheory/test/certifier-report/Test/Certifier/Report.hs +++ b/plutus-metatheory/test/certifier-report/Test/Certifier/Report.hs @@ -31,7 +31,7 @@ import System.IO.Extra import Test.Tasty import Test.Tasty.Golden -loadFrom :: FilePath -> IO (OptimizerTrace Name DefaultUni DefaultFun ()) +loadFrom :: FilePath -> IO (OptimizerTrace Name DefaultUni DefaultFun DefaultBuiltinPattern ()) loadFrom name = do root <- getDataDir prog <- @@ -53,10 +53,10 @@ loadFrom name = do pure . runQuote $ snd <$> simplify term simplify - :: Term Name DefaultUni DefaultFun () + :: Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> Quote - ( Term Name DefaultUni DefaultFun () - , OptimizerTrace Name DefaultUni DefaultFun () + ( Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + , OptimizerTrace Name DefaultUni DefaultFun DefaultBuiltinPattern () ) simplify = runOptimizerT @@ -71,9 +71,10 @@ evalCtx = mkDefaultEvalCtx def {-# OPAQUE evalCtx #-} evalTrace - :: OptimizerTrace Name DefaultUni DefaultFun () - -> [Term NamedDeBruijn DefaultUni DefaultFun ()] - -> [ ( Maybe (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun) + :: OptimizerTrace Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> [Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()] + -> [ ( Maybe + (CekEvaluationException UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern) , ExBudget ) ] @@ -81,7 +82,7 @@ evalTrace trace args = first (either Just (const Nothing)) . evalCounting evalCtx newestPV <$> appliedTerms where - appliedTerms :: [Term NamedDeBruijn DefaultUni DefaultFun ()] + appliedTerms :: [Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern ()] appliedTerms = ( \ast -> F.foldl' diff --git a/plutus-metatheory/test/certifier/Test/Certifier/AST.hs b/plutus-metatheory/test/certifier/Test/Certifier/AST.hs index 2762f00b763..3b949f864ac 100644 --- a/plutus-metatheory/test/certifier/Test/Certifier/AST.hs +++ b/plutus-metatheory/test/certifier/Test/Certifier/AST.hs @@ -14,9 +14,9 @@ import Test.Tasty.HUnit mkMockTracePair :: OptStage - -> Term Name DefaultUni DefaultFun () - -> Term Name DefaultUni DefaultFun () - -> OptimizerTrace Name DefaultUni DefaultFun () + -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () + -> OptimizerTrace Name DefaultUni DefaultFun DefaultBuiltinPattern () mkMockTracePair stage before' after' = OptimizerTrace { optimizerTrace = @@ -30,7 +30,7 @@ mkMockTracePair stage before' after' = } runCertifierWithMockTrace - :: OptimizerTrace Name DefaultUni DefaultFun () + :: OptimizerTrace Name DefaultUni DefaultFun DefaultBuiltinPattern () -> IO Bool runCertifierWithMockTrace trace = do let rawAgdaTrace = mkFfiOptimizerTrace trace @@ -42,8 +42,8 @@ runCertifierWithMockTrace trace = do testSuccess :: String -> OptStage - -> Term Name PLC.DefaultUni PLC.DefaultFun () - -> Term Name PLC.DefaultUni PLC.DefaultFun () + -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> TestTree testSuccess testName st bf af = testCase testName $ do @@ -56,8 +56,8 @@ testSuccess testName st bf af = testFailure :: String -> OptStage - -> Term Name PLC.DefaultUni PLC.DefaultFun () - -> Term Name PLC.DefaultUni PLC.DefaultFun () + -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + -> Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> TestTree testFailure testName st bf af = testCase testName $ do @@ -71,8 +71,8 @@ testFailure testName st bf af = testSuccessItem :: ( String , OptStage - , Term Name PLC.DefaultUni PLC.DefaultFun () - , Term Name PLC.DefaultUni PLC.DefaultFun () + , Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + , Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ) -> TestTree testSuccessItem (name, stage, before, after) = testSuccess name stage before after @@ -80,8 +80,8 @@ testSuccessItem (name, stage, before, after) = testSuccess name stage before aft testFailureItem :: ( String , OptStage - , Term Name PLC.DefaultUni PLC.DefaultFun () - , Term Name PLC.DefaultUni PLC.DefaultFun () + , Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + , Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ) -> TestTree testFailureItem (name, stage, before, after) = testFailure name stage before after diff --git a/plutus-metatheory/test/certifier/Test/Certifier/AST/ForceDelay.hs b/plutus-metatheory/test/certifier/Test/Certifier/AST/ForceDelay.hs index 743397babf2..67535aaf206 100644 --- a/plutus-metatheory/test/certifier/Test/Certifier/AST/ForceDelay.hs +++ b/plutus-metatheory/test/certifier/Test/Certifier/AST/ForceDelay.hs @@ -29,7 +29,7 @@ import Test.Certifier.AST (testFailureItem, testSuccessItem) -- (force (ƛ (delay (con integer 1)) · (con integer 2))) -- ==> (ƛ (con integer 1) · (con integer 2)) -- Constructors positive: [0,2,3,4] -simpleSuccessBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +simpleSuccessBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () simpleSuccessBefore = runQuote $ do x <- freshName "x" return @@ -46,7 +46,7 @@ simpleSuccessBefore = runQuote $ do ) ) -simpleSuccessAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +simpleSuccessAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () simpleSuccessAfter = runQuote $ do x <- freshName "x" return @@ -64,7 +64,7 @@ simpleSuccessAfter = runQuote $ do -- ==> -- ((ƛ ((ƛ (con Two)) · (con Three))) · (con One)) -- Constructors positive: [0,1,2,3,5] -nestedBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +nestedBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () nestedBefore = runQuote $ do x <- freshName "x" y <- freshName "y" @@ -99,7 +99,7 @@ nestedBefore = runQuote $ do ) ) -nestedAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +nestedAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () nestedAfter = runQuote $ do x <- freshName "x" y <- freshName "y" @@ -137,7 +137,7 @@ nestedAfter = runQuote $ do -- (con integer 2) -- ] -- Constructors positive: [6] -ifThenElseSuccessBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +ifThenElseSuccessBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ifThenElseSuccessBefore = ( Force () @@ -156,7 +156,7 @@ ifThenElseSuccessBefore = ) ) -ifThenElseSuccessAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +ifThenElseSuccessAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ifThenElseSuccessAfter = ( Apply () @@ -177,16 +177,16 @@ ifThenElseSuccessAfter = -- Just lose a force for no reason -- Constructors violated: [0] -simpleForceBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +simpleForceBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () simpleForceBreakBefore = (Force () (mkConstant () (1 :: Integer))) -simpleForceBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +simpleForceBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () simpleForceBreakAfter = (mkConstant () (1 :: Integer)) -- Extra delay removed. -- Constructors [0,1,4] -- Constructors violated: [1] -simpleFailBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +simpleFailBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () simpleFailBefore = ( Force () @@ -196,12 +196,12 @@ simpleFailBefore = ) ) -simpleFailAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +simpleFailAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () simpleFailAfter = (mkConstant () (1 :: Integer)) -- Traverse an application when you shouldn't -- no matching lambda -- Constructors violated: [2] -simpleAppBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +simpleAppBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () simpleAppBreakBefore = ( Force () @@ -212,7 +212,7 @@ simpleAppBreakBefore = ) ) -simpleAppBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +simpleAppBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () simpleAppBreakAfter = ( Apply () @@ -222,7 +222,7 @@ simpleAppBreakAfter = -- Traverse an application when you shouldn't -- broken applied term -- Constructors violated: [2,0] -appTermBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +appTermBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () appTermBreakBefore = runQuote $ do x <- freshName "x" return @@ -232,7 +232,7 @@ appTermBreakBefore = runQuote $ do (Force () (mkConstant () (2 :: Integer))) ) -appTermBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +appTermBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () appTermBreakAfter = runQuote $ do x <- freshName "x" return @@ -244,7 +244,7 @@ appTermBreakAfter = runQuote $ do -- Traverse a lambda when you shouldn't -- no applied term -- Constructors violated: [3] -lambdaBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +lambdaBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () lambdaBreakBefore = runQuote $ do x <- freshName "x" return @@ -253,17 +253,17 @@ lambdaBreakBefore = runQuote $ do (LamAbs () x (Delay () (mkConstant () (1 :: Integer)))) ) -lambdaBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +lambdaBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () lambdaBreakAfter = runQuote $ do x <- freshName "x" return (LamAbs () x (mkConstant () (1 :: Integer))) -- Valid force-delay, but invalid sub-tree change. -- Constructors violated: [4] -lastDelayBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +lastDelayBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () lastDelayBreakBefore = (Force () (Delay () (mkConstant () (1 :: Integer)))) -lastDelayBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +lastDelayBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () lastDelayBreakAfter = (mkConstant () (2 :: Integer)) -- Valid force-delay, but invalid sub-tree change after an abstraction. @@ -271,7 +271,7 @@ lastDelayBreakAfter = (mkConstant () (2 :: Integer)) -- =|=> -- ((ƛ (con-integer 2)) · (con-integer 3))) -- Constructors violated: [5] -lastAbsBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun () +lastAbsBreakBefore :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () lastAbsBreakBefore = runQuote $ do x <- freshName "x" return @@ -286,7 +286,7 @@ lastAbsBreakBefore = runQuote $ do ) ) ) -lastAbsBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun () +lastAbsBreakAfter :: Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () lastAbsBreakAfter = runQuote $ do x <- freshName "x" return @@ -299,8 +299,8 @@ lastAbsBreakAfter = runQuote $ do successItems :: [ ( String , OptStage - , Term Name PLC.DefaultUni PLC.DefaultFun () - , Term Name PLC.DefaultUni PLC.DefaultFun () + , Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + , Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ) ] successItems = @@ -326,8 +326,8 @@ successItems = failItems :: [ ( String , OptStage - , Term Name PLC.DefaultUni PLC.DefaultFun () - , Term Name PLC.DefaultUni PLC.DefaultFun () + , Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + , Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ) ] failItems = diff --git a/plutus-metatheory/test/certifier/Test/Certifier/Optimizer.hs b/plutus-metatheory/test/certifier/Test/Certifier/Optimizer.hs index 40dc412724f..281f3e34389 100644 --- a/plutus-metatheory/test/certifier/Test/Certifier/Optimizer.hs +++ b/plutus-metatheory/test/certifier/Test/Certifier/Optimizer.hs @@ -9,6 +9,7 @@ import Transform.Simplify.Lib (testCse, testOptimize) import Transform.Simplify.Spec (testCseInputs, testSimplifyInputs) import UntypedPlutusCore ( CseWhichSubterms (..) + , DefaultBuiltinPattern , DefaultFun , DefaultUni , Name @@ -17,16 +18,16 @@ import UntypedPlutusCore ) type SimplifierFunc = - Term Name PLC.DefaultUni PLC.DefaultFun () + Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () -> PLC.Quote - ( Term Name PLC.DefaultUni PLC.DefaultFun () - , OptimizerTrace Name PLC.DefaultUni PLC.DefaultFun () + ( Term Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () + , OptimizerTrace Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern () ) mkUPLCTest :: SimplifierFunc -> String - -> Term Name DefaultUni DefaultFun () + -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> TestTree mkUPLCTest simplifierFunc name input = testCase name $ @@ -41,14 +42,14 @@ mkUPLCTest simplifierFunc name input = mkUPLCSimplifierTest :: String - -> Term Name DefaultUni DefaultFun () + -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> TestTree mkUPLCSimplifierTest = mkUPLCTest testOptimize mkUPLCCseTest :: CseWhichSubterms -> String - -> Term Name DefaultUni DefaultFun () + -> Term Name DefaultUni DefaultFun DefaultBuiltinPattern () -> TestTree mkUPLCCseTest which = mkUPLCTest (testCse which) diff --git a/plutus-tx-plugin/src/PlutusTx/PLCTypes.hs b/plutus-tx-plugin/src/PlutusTx/PLCTypes.hs index af5626826e1..266bfe5fc17 100644 --- a/plutus-tx-plugin/src/PlutusTx/PLCTypes.hs +++ b/plutus-tx-plugin/src/PlutusTx/PLCTypes.hs @@ -13,5 +13,7 @@ type PLCProgram uni fun = PLC.Program PLC.TyName PLC.Name uni fun () type PLCVar uni = PLC.VarDecl PLC.TyName PLC.Name uni Ann type PLCTyVar = PLC.TyVarDecl PLC.TyName Ann -type UPLCProgram uni fun = UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans -type UPLCTerm uni fun = UPLC.Term UPLC.NamedDeBruijn uni fun SrcSpans +type UPLCProgram uni fun = + UPLC.Program UPLC.NamedDeBruijn uni fun UPLC.DefaultBuiltinPattern SrcSpans +type UPLCTerm uni fun = + UPLC.Term UPLC.NamedDeBruijn uni fun UPLC.DefaultBuiltinPattern SrcSpans diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin/Common.hs b/plutus-tx-plugin/src/PlutusTx/Plugin/Common.hs index 950001ec717..6bc8f5bd713 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin/Common.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin/Common.hs @@ -896,7 +896,7 @@ generateCertificate :: String -> String -> PluginOptions - -> OptimizerTrace PLC.Name PLC.DefaultUni PLC.DefaultFun a + -> OptimizerTrace PLC.Name PLC.DefaultUni PLC.DefaultFun PLC.DefaultBuiltinPattern a -> String -> IO () generateCertificate packageName moduleName opts simplTrace certifyPath = do diff --git a/plutus-tx-plugin/test-ledger-api/Spec/ScriptSize.hs b/plutus-tx-plugin/test-ledger-api/Spec/ScriptSize.hs index 707342d4eb8..0188ed63cc0 100644 --- a/plutus-tx-plugin/test-ledger-api/Spec/ScriptSize.hs +++ b/plutus-tx-plugin/test-ledger-api/Spec/ScriptSize.hs @@ -13,7 +13,7 @@ import Prelude qualified as Haskell import Control.Lens ((&), (^.)) import Data.ByteString.Short qualified as SBS -import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun, DefaultUni) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParametersForTesting) import PlutusCore.StdLib.Data.Unit (unitval) import PlutusLedgerApi.V2 qualified as V2 @@ -200,7 +200,7 @@ dummyScriptContext = (Haskell.Just (V3.Datum (V3.toBuiltinData expected))) } -assertResult :: NTerm DefaultUni DefaultFun () -> CompiledCode a -> Assertion +assertResult :: NTerm DefaultUni DefaultFun DefaultBuiltinPattern () -> CompiledCode a -> Assertion assertResult expectedResult code = do let plc = getPlc code ^. progTerm tidy = cekResultToEither . _cekReportResult diff --git a/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs b/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs index 92175a52622..305b56f24e9 100644 --- a/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs +++ b/plutus-tx-plugin/test/ByteStringLiterals/Spec.hs @@ -29,7 +29,13 @@ import PlutusTx.Builtins.HasOpaque import PlutusTx.TH (compile) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import UntypedPlutusCore (DefaultFun, NamedDeBruijn, Program (_progTerm), Term (Constant)) +import UntypedPlutusCore + ( DefaultBuiltinPattern + , DefaultFun + , NamedDeBruijn + , Program (_progTerm) + , Term (Constant) + ) tests :: TestTree tests = @@ -247,10 +253,10 @@ test_CompileBuiltinByteStringLiteral_stringToBuiltinByteStringHex = ||] ) -term :: CompiledCode a -> Term NamedDeBruijn DefaultUni DefaultFun () +term :: CompiledCode a -> Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () term = _progTerm . getPlcNoAnn -expectedUplc :: Term NamedDeBruijn DefaultUni DefaultFun () +expectedUplc :: Term NamedDeBruijn DefaultUni DefaultFun DefaultBuiltinPattern () expectedUplc = Constant () $ someValue @ByteString diff --git a/plutus-tx-plugin/test/CallTrace/Lib.hs b/plutus-tx-plugin/test/CallTrace/Lib.hs index 032913ede60..2a764284de0 100644 --- a/plutus-tx-plugin/test/CallTrace/Lib.hs +++ b/plutus-tx-plugin/test/CallTrace/Lib.hs @@ -21,7 +21,7 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.Internal qualified as UPLC import PlutusTx.Test (prettyBudget, prettyCodeSize) goldenEvalCekTraceWithEmitter - :: UPLC.EmitterMode UPLC.DefaultUni UPLC.DefaultFun + :: UPLC.EmitterMode UPLC.DefaultUni UPLC.DefaultFun UPLC.DefaultBuiltinPattern -> TestName -> CompiledCode a -> TestNested diff --git a/plutus-tx-plugin/test/ShortCircuit/Spec.hs b/plutus-tx-plugin/test/ShortCircuit/Spec.hs index 5e9f7813713..af3d0bfd3f9 100644 --- a/plutus-tx-plugin/test/ShortCircuit/Spec.hs +++ b/plutus-tx-plugin/test/ShortCircuit/Spec.hs @@ -11,7 +11,7 @@ import ShortCircuit.WithGHCOptimisations qualified as WithOptimisations import ShortCircuit.WithoutGHCOptimisations qualified as WithoutOptimisations import Control.Lens ((&)) -import PlutusCore.Default (DefaultFun, DefaultUni, someValue) +import PlutusCore.Default (DefaultBuiltinPattern, DefaultFun, DefaultUni, someValue) import PlutusTx.Code (CompiledCode, unsafeApplyCode) import PlutusTx.Lift (liftCodeDef) import PlutusTx.TH (compile) @@ -45,7 +45,7 @@ tests = ---------------------------------------------------------------------------------------------------- -- Helpers ----------------------------------------------------------------------------------------- -assertResult :: NTerm DefaultUni DefaultFun () -> CompiledCode a -> Assertion +assertResult :: NTerm DefaultUni DefaultFun DefaultBuiltinPattern () -> CompiledCode a -> Assertion assertResult expected code = case evalResult (evaluateCompiledCode code) of Left ex -> assertFailure $ show ex @@ -57,8 +57,8 @@ false' = liftCodeDef False true' :: CompiledCode Bool true' = liftCodeDef True -termFalse :: NTerm DefaultUni DefaultFun () +termFalse :: NTerm DefaultUni DefaultFun DefaultBuiltinPattern () termFalse = Constant () $ someValue False -termTrue :: NTerm DefaultUni DefaultFun () +termTrue :: NTerm DefaultUni DefaultFun DefaultBuiltinPattern () termTrue = Constant () $ someValue True From cda7604868677f62fa0cc42bd7b6910e2ab4c1cd Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Thu, 16 Jul 2026 08:54:48 -0500 Subject: [PATCH 4/4] test: add Match conformance coverage --- plutus-conformance/README.md | 2 +- plutus-conformance/agda/Spec.hs | 14 +++++++-- .../capture-unsupported-string.uplc | 6 ++++ ...re-unsupported-string.uplc.budget.expected | 2 ++ .../capture-unsupported-string.uplc.expected | 1 + .../first-match-wins/first-match-wins.uplc | 6 ++++ .../first-match-wins.uplc.budget.expected | 2 ++ .../first-match-wins.uplc.expected | 1 + .../wildcard-fallback/wildcard-fallback.uplc | 6 ++++ .../wildcard-fallback.uplc.budget.expected | 2 ++ .../wildcard-fallback.uplc.expected | 1 + .../constr-tag-arity/constr-tag-arity.uplc | 12 +++++++ .../constr-tag-arity.uplc.budget.expected | 2 ++ .../constr-tag-arity.uplc.expected | 1 + .../empty-containers/empty-containers.uplc | 8 +++++ .../empty-containers.uplc.budget.expected | 2 ++ .../empty-containers.uplc.expected | 1 + .../nested-capture-order-reset.uplc | 31 +++++++++++++++++++ ...d-capture-order-reset.uplc.budget.expected | 2 ++ .../nested-capture-order-reset.uplc.expected | 7 +++++ .../data/shape-only-i-b/shape-only-i-b.uplc | 6 ++++ .../shape-only-i-b.uplc.budget.expected | 2 ++ .../shape-only-i-b.uplc.expected | 1 + .../error-scrutinee/error-scrutinee.uplc | 5 +++ .../error-scrutinee.uplc.budget.expected | 1 + .../error-scrutinee.uplc.expected | 1 + .../term/match/failure/no-match/no-match.uplc | 5 +++ .../no-match/no-match.uplc.budget.expected | 1 + .../failure/no-match/no-match.uplc.expected | 1 + .../nonfunctional-handler.uplc | 5 +++ ...nonfunctional-handler.uplc.budget.expected | 1 + .../nonfunctional-handler.uplc.expected | 1 + .../uplc-constr-scrutinee.uplc | 5 +++ ...uplc-constr-scrutinee.uplc.budget.expected | 1 + .../uplc-constr-scrutinee.uplc.expected | 1 + .../zero-alternatives/zero-alternatives.uplc | 3 ++ .../zero-alternatives.uplc.budget.expected | 1 + .../zero-alternatives.uplc.expected | 1 + .../match/scalar/bool-exact/bool-exact.uplc | 5 +++ .../bool-exact.uplc.budget.expected | 2 ++ .../bool-exact/bool-exact.uplc.expected | 1 + .../bytestring-exact/bytestring-exact.uplc | 8 +++++ .../bytestring-exact.uplc.budget.expected | 2 ++ .../bytestring-exact.uplc.expected | 1 + .../integer-ordered/integer-ordered.uplc | 7 +++++ .../integer-ordered.uplc.budget.expected | 2 ++ .../integer-ordered.uplc.expected | 1 + .../match/scalar/unit-exact/unit-exact.uplc | 4 +++ .../unit-exact.uplc.budget.expected | 2 ++ .../unit-exact/unit-exact.uplc.expected | 1 + .../empty-list-exact/empty-list-exact.uplc | 6 ++++ .../empty-list-exact.uplc.budget.expected | 2 ++ .../empty-list-exact.uplc.expected | 1 + .../list-exact-arity/list-exact-arity.uplc | 12 +++++++ .../list-exact-arity.uplc.budget.expected | 2 ++ .../list-exact-arity.uplc.expected | 1 + .../nested-pair-list/nested-pair-list.uplc | 8 +++++ .../nested-pair-list.uplc.budget.expected | 2 ++ .../nested-pair-list.uplc.expected | 3 ++ .../before-version-1.2.0.uplc | 5 +++ .../before-version-1.2.0.uplc.budget.expected | 1 + .../before-version-1.2.0.uplc.expected | 1 + .../syntax/int64-overflow/int64-overflow.uplc | 5 +++ .../int64-overflow.uplc.budget.expected | 1 + .../int64-overflow.uplc.expected | 1 + .../int64-underflow/int64-underflow.uplc | 5 +++ .../int64-underflow.uplc.budget.expected | 1 + .../int64-underflow.uplc.expected | 1 + .../negative-data-tag/negative-data-tag.uplc | 5 +++ .../negative-data-tag.uplc.budget.expected | 1 + .../negative-data-tag.uplc.expected | 1 + .../word64-tag-overflow.uplc | 5 +++ .../word64-tag-overflow.uplc.budget.expected | 1 + .../word64-tag-overflow.uplc.expected | 1 + 74 files changed, 256 insertions(+), 3 deletions(-) create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc.budget.expected create mode 100644 plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc.expected diff --git a/plutus-conformance/README.md b/plutus-conformance/README.md index e7b16f04d44..31838a29347 100644 --- a/plutus-conformance/README.md +++ b/plutus-conformance/README.md @@ -73,7 +73,7 @@ In the library we provide a function named `runUplcEvalTests` with the following ```haskell import UntypedPlutusCore.Core.Type qualified as UPLC -type UplcProg = UPLC.Program Name DefaultUni DefaultFun () +type UplcProg = UPLC.Program Name DefaultUni DefaultFun DefaultBuiltinPattern () type UplcEvaluatorFun res = UplcProg -> Maybe res diff --git a/plutus-conformance/agda/Spec.hs b/plutus-conformance/agda/Spec.hs index 93b0ef69217..67e6958b02b 100644 --- a/plutus-conformance/agda/Spec.hs +++ b/plutus-conformance/agda/Spec.hs @@ -53,6 +53,7 @@ import Data.Aeson , fromJSON , toJSON ) +import Data.List (isPrefixOf) -- This type corresponds to Cost.Raw.RawCostModel in plutus-metaheory. type RawCostModel = (CekMachineCosts, BuiltinCostMap) @@ -423,9 +424,18 @@ failingBudgetTests = ] -- Run the tests: see Note [Evaluation with and without costing] above. +-- Agda does not yet model Match. Keep exercising parser rejection cases, but do not invoke +-- the Agda evaluator for well-formed Match programs until the metatheory supports the node. +unsupportedMatchTest :: FilePath -> Bool +unsupportedMatchTest path = + matchTestPrefix `isPrefixOf` path && not (matchSyntaxPrefix `isPrefixOf` path) + where + matchTestPrefix = "test-cases/uplc/evaluation/term/match/" + matchSyntaxPrefix = matchTestPrefix <> "syntax/" + main :: IO () main = runUplcEvalTests (agdaEvalUplcProg WithCosting) - (flip elem failingEvaluationTests) - (flip elem failingBudgetTests) + (\path -> unsupportedMatchTest path || path `elem` failingEvaluationTests) + (\path -> unsupportedMatchTest path || path `elem` failingBudgetTests) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc new file mode 100644 index 00000000000..c12d9bee77d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc @@ -0,0 +1,6 @@ +-- String has no scalar pattern of its own, but bind accepts every built-in constant. +(program 1.2.0 + (match (con string "opaque") + (pattern (integer 0) (error)) + (pattern (bind) (lam captured captured))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc.budget.expected new file mode 100644 index 00000000000..b1b744c72a4 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 298100 +| mem: 900}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc.expected new file mode 100644 index 00000000000..b8125542931 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/capture-unsupported-string/capture-unsupported-string.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con string "opaque")) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc new file mode 100644 index 00000000000..e6032050d73 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc @@ -0,0 +1,6 @@ +-- The later exact alternative must not supersede an earlier overlapping wildcard. +(program 1.2.0 + (match (con integer 42) + (pattern (wildcard) (con integer 1)) + (pattern (integer 42) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc.budget.expected new file mode 100644 index 00000000000..93bb11d6bd3 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 244600 +| mem: 500}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc.expected new file mode 100644 index 00000000000..2aa41724bf1 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/first-match-wins/first-match-wins.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 1)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc new file mode 100644 index 00000000000..7a0843f8ef5 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc @@ -0,0 +1,6 @@ +(program 1.2.0 + (match (con integer 9) + (pattern (integer 7) (error)) + (pattern (integer 8) (error)) + (pattern (wildcard) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc.budget.expected new file mode 100644 index 00000000000..bf2e2d70935 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 309600 +| mem: 700}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc.expected new file mode 100644 index 00000000000..1118ccc135d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/control/wildcard-fallback/wildcard-fallback.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 42)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc new file mode 100644 index 00000000000..c5d0507dc8e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc @@ -0,0 +1,12 @@ +-- Data.Constr checks both its Word64 tag and exact field arity before exposing fields. +(program 1.2.0 + (match (con data (Constr 18446744073709551615 [I 1, I 2, I 3])) + (pattern (data-constr 18446744073709551614) (error)) + (pattern + (data-constr 18446744073709551615 (wildcard) (wildcard)) + (error)) + (pattern + (data-constr 18446744073709551615 (wildcard) (bind) (wildcard)) + (lam middle middle)) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc.budget.expected new file mode 100644 index 00000000000..03b9f2026f4 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 468100 +| mem: 1300}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc.expected new file mode 100644 index 00000000000..96da08479f8 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/constr-tag-arity/constr-tag-arity.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con data (I 2))) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc new file mode 100644 index 00000000000..67a8bebf324 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc @@ -0,0 +1,8 @@ +-- Empty Data.List and Data.Map patterns match their corresponding empty containers exactly. +(program 1.2.0 + (match (con data (Constr 0 [List [], Map []])) + (pattern + (data-constr 0 (data-list) (data-map)) + (con integer 42)) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc.budget.expected new file mode 100644 index 00000000000..60991315f54 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 299600 +| mem: 620}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc.expected new file mode 100644 index 00000000000..1118ccc135d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/empty-containers/empty-containers.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 42)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc new file mode 100644 index 00000000000..dd952edc73c --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc @@ -0,0 +1,31 @@ +-- Exercise nested Data.List/Map/Pair/I/B matching. The first alternative captures twice and then +-- fails on map width; the chosen alternative must start with a fresh capture sequence. +(program 1.2.0 + (match + (con data + (Constr 9 + [ List [I 11, I 22] + , Map [(I 1, B #aa)] + , B #bb + ])) + (pattern + (data-constr 9 + (data-list (data-i (bind)) (bind)) + (data-map) + (wildcard)) + (lam abandoned1 (lam abandoned2 (error)))) + (pattern + (data-constr 9 + (data-list (data-i (bind)) (bind)) + (data-map + (pair + (data-i (integer 1)) + (data-b (bind)))) + (data-b (bind))) + (lam first + (lam second + (lam third + (lam fourth + (constr 0 first second third fourth)))))) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc.budget.expected new file mode 100644 index 00000000000..b6e05f0fbe6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 902600 +| mem: 3620}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc.expected new file mode 100644 index 00000000000..61c5259ecc0 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/nested-capture-order-reset/nested-capture-order-reset.uplc.expected @@ -0,0 +1,7 @@ +(program 1.2.0 + (constr 0 + (con integer 11) + (con data (I 22)) + (con bytestring #aa) + (con bytestring #bb)) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc new file mode 100644 index 00000000000..73d383443b4 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc @@ -0,0 +1,6 @@ +-- Data.I and Data.B without child patterns inspect only the Data constructor shape. +(program 1.2.0 + (match (con data (List [I 9223372036854775808, B #deadbeef])) + (pattern (data-list (data-i) (data-b)) (con integer 42)) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc.budget.expected new file mode 100644 index 00000000000..60991315f54 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 299600 +| mem: 620}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc.expected new file mode 100644 index 00000000000..1118ccc135d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/data/shape-only-i-b/shape-only-i-b.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 42)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc new file mode 100644 index 00000000000..2dbb146d4c7 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc @@ -0,0 +1,5 @@ +-- The scrutinee is evaluated before any alternative is inspected. +(program 1.2.0 + (match (error) + (pattern (wildcard) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc.budget.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc.budget.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/error-scrutinee/error-scrutinee.uplc.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc new file mode 100644 index 00000000000..c26cb07ce2f --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc @@ -0,0 +1,5 @@ +-- String has no scalar pattern and there is no fallback alternative. +(program 1.2.0 + (match (con string "opaque") + (pattern (integer 0) (con integer 0))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc.budget.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc.budget.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/no-match/no-match.uplc.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc new file mode 100644 index 00000000000..05ad8d3e05f --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc @@ -0,0 +1,5 @@ +-- A capture is implicitly applied to its selected handler, so a constant handler is invalid. +(program 1.2.0 + (match (con integer 1) + (pattern (bind) (con integer 0))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc.budget.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc.budget.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/nonfunctional-handler/nonfunctional-handler.uplc.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc new file mode 100644 index 00000000000..ed184c2f1b3 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc @@ -0,0 +1,5 @@ +-- Match is built-in-only; UPLC Constr values continue to use Case. +(program 1.2.0 + (match (constr 0 (con integer 1)) + (pattern (wildcard) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc.budget.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc.budget.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/uplc-constr-scrutinee/uplc-constr-scrutinee.uplc.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc new file mode 100644 index 00000000000..e3542c6640a --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc @@ -0,0 +1,3 @@ +(program 1.2.0 + (match (con integer 0)) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc.budget.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc.budget.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc.expected new file mode 100644 index 00000000000..ccc477ffed6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/failure/zero-alternatives/zero-alternatives.uplc.expected @@ -0,0 +1 @@ +evaluation failure \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc new file mode 100644 index 00000000000..a37b449c65e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc @@ -0,0 +1,5 @@ +(program 1.2.0 + (match (con bool True) + (pattern (bool False) (error)) + (pattern (bool True) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc.budget.expected new file mode 100644 index 00000000000..e9d1366645a --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 277100 +| mem: 600}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc.expected new file mode 100644 index 00000000000..1118ccc135d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bool-exact/bool-exact.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 42)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc new file mode 100644 index 00000000000..9f0ebbecc9e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc @@ -0,0 +1,8 @@ +-- Reject a different length and equal-length unequal contents before selecting the exact bytestring. +(program 1.2.0 + (match (con bytestring #abcd) + (pattern (bytestring #ab) (error)) + (pattern (bytestring #abce) (error)) + (pattern (bytestring #abcd) (con integer 42)) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc.budget.expected new file mode 100644 index 00000000000..7081c1d7eee --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 314600 +| mem: 900}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc.expected new file mode 100644 index 00000000000..1118ccc135d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/bytestring-exact/bytestring-exact.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 42)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc new file mode 100644 index 00000000000..c9ea7965cae --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc @@ -0,0 +1,7 @@ +-- Both signed Int64 endpoints are valid patterns, and alternatives are ordered. +(program 1.2.0 + (match (con integer 9223372036854775807) + (pattern (integer -9223372036854775808) (error)) + (pattern (integer 9223372036854775807) (con integer 42)) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc.budget.expected new file mode 100644 index 00000000000..e9d1366645a --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 277100 +| mem: 600}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc.expected new file mode 100644 index 00000000000..1118ccc135d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/integer-ordered/integer-ordered.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 42)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc new file mode 100644 index 00000000000..49b7cf6e88f --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc @@ -0,0 +1,4 @@ +(program 1.2.0 + (match (con unit ()) + (pattern (unit) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc.budget.expected new file mode 100644 index 00000000000..93bb11d6bd3 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 244600 +| mem: 500}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc.expected new file mode 100644 index 00000000000..1118ccc135d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/scalar/unit-exact/unit-exact.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 42)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc new file mode 100644 index 00000000000..f1da0641114 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc @@ -0,0 +1,6 @@ +-- A childless list pattern is exact: it matches the empty list. +(program 1.2.0 + (match (con (list integer) []) + (pattern (list) (con integer 42)) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc.budget.expected new file mode 100644 index 00000000000..93bb11d6bd3 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 244600 +| mem: 500}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc.expected new file mode 100644 index 00000000000..1118ccc135d --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/empty-list-exact/empty-list-exact.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 42)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc new file mode 100644 index 00000000000..655a6688836 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc @@ -0,0 +1,12 @@ +-- Exact list patterns reject both fewer and more children. Captures from failed alternatives reset. +(program 1.2.0 + (match (con (list integer) [1, 2, 3]) + (pattern (list (bind) (wildcard)) (lam abandoned (error))) + (pattern + (list (bind) (wildcard) (wildcard) (wildcard)) + (lam abandoned (error))) + (pattern + (list (wildcard) (bind) (wildcard)) + (lam middle middle)) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc.budget.expected new file mode 100644 index 00000000000..93db458eeac --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 560600 +| mem: 1880}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc.expected new file mode 100644 index 00000000000..06034d09872 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/list-exact-arity/list-exact-arity.uplc.expected @@ -0,0 +1 @@ +(program 1.2.0 (con integer 2)) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc new file mode 100644 index 00000000000..38fbfbe0bf6 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc @@ -0,0 +1,8 @@ +-- Captures are applied depth-first and left-to-right through a pair and nested list. +(program 1.2.0 + (match (con (pair integer (list bytestring)) (7, [#aa, #bb])) + (pattern + (pair (bind) (list (wildcard) (bind))) + (lam left (lam right (constr 0 left right)))) + (pattern (wildcard) (error))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc.budget.expected new file mode 100644 index 00000000000..4d34ce16ff0 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc.budget.expected @@ -0,0 +1,2 @@ +({cpu: 428600 +| mem: 1540}) \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc.expected new file mode 100644 index 00000000000..d859f50d833 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/structural/nested-pair-list/nested-pair-list.uplc.expected @@ -0,0 +1,3 @@ +(program 1.2.0 + (constr 0 (con integer 7) (con bytestring #bb)) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc new file mode 100644 index 00000000000..e626c11ece0 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc @@ -0,0 +1,5 @@ +-- Match is rejected by the textual parser before UPLC 1.2.0. +(program 1.1.0 + (match (con integer 0) + (pattern (wildcard) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc.budget.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc.budget.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/before-version-1.2.0/before-version-1.2.0.uplc.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc new file mode 100644 index 00000000000..445baeebe1a --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc @@ -0,0 +1,5 @@ +-- Integer pattern payloads are restricted to signed Int64. +(program 1.2.0 + (match (con integer 9223372036854775808) + (pattern (integer 9223372036854775808) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc.budget.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc.budget.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-overflow/int64-overflow.uplc.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc new file mode 100644 index 00000000000..b554a14bf65 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc @@ -0,0 +1,5 @@ +-- Integer pattern payloads below signed Int64 are rejected. +(program 1.2.0 + (match (con integer -9223372036854775809) + (pattern (integer -9223372036854775809) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc.budget.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc.budget.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/int64-underflow/int64-underflow.uplc.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc new file mode 100644 index 00000000000..31360dc1ff0 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc @@ -0,0 +1,5 @@ +-- Data.Constr pattern tags cannot be negative. +(program 1.2.0 + (match (con data (Constr 0 [])) + (pattern (data-constr -1) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc.budget.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc.budget.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/negative-data-tag/negative-data-tag.uplc.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc new file mode 100644 index 00000000000..06e3d0a5b11 --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc @@ -0,0 +1,5 @@ +-- Data.Constr pattern tags are restricted to unsigned Word64. +(program 1.2.0 + (match (con data (Constr 0 [])) + (pattern (data-constr 18446744073709551616) (con integer 42))) +) diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc.budget.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc.budget.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc.budget.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file diff --git a/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc.expected b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc.expected new file mode 100644 index 00000000000..fd56948990e --- /dev/null +++ b/plutus-conformance/test-cases/uplc/evaluation/term/match/syntax/word64-tag-overflow/word64-tag-overflow.uplc.expected @@ -0,0 +1 @@ +parse error \ No newline at end of file