[Experiment] Let/Bind

plutus-core/plutus-core.cabal

@@ -240,6 +240,7 @@ library
     PlutusCore.Builtin.KnownKind
     PlutusCore.Builtin.KnownType
     PlutusCore.Builtin.KnownTypeAst
+    PlutusCore.Builtin.Let
     PlutusCore.Builtin.Meaning
     PlutusCore.Builtin.Polymorphism
     PlutusCore.Builtin.Result

plutus-core/plutus-core/src/PlutusCore/Builtin.hs

@@ -9,6 +9,7 @@ import PlutusCore.Builtin.HasConstant as Export
 import PlutusCore.Builtin.KnownKind as Export
 import PlutusCore.Builtin.KnownType as Export
 import PlutusCore.Builtin.KnownTypeAst as Export
+import PlutusCore.Builtin.Let as Export
 import PlutusCore.Builtin.Meaning as Export
 import PlutusCore.Builtin.Polymorphism as Export
 import PlutusCore.Builtin.Result as Export

plutus-core/plutus-core/src/PlutusCore/Builtin/Let.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module PlutusCore.Builtin.Let where
+
+import PlutusCore.Builtin.KnownType (Spine)
+import PlutusCore.Core.Type (Type, UniOf)
+import PlutusCore.Name.Unique (TyName)
+
+import Control.DeepSeq (NFData (..), rwhnf)
+import Data.Default.Class (Default (..))
+import Data.Text (Text)
+import Data.Vector (Vector)
+import NoThunks.Class
+import Text.PrettyBy (display)
+import Universe
+
+
+class LetBuiltin uni where
+    -- | Given a constant with its type tag and a vector of branches, choose the appropriate branch
+    -- or fail if the constant doesn't correspond to any of the branches (or casing on constants of
+    -- this type isn't supported at all).
+    letBuiltin
+        :: Some (ValueOf uni)
+        -> Either Text [Some (ValueOf uni)]
+
+data LeterBuiltin uni = LeterBuiltin
+    { unLeterBuiltin :: !(Some (ValueOf uni) -> Either Text [Some (ValueOf uni)])
+    }
+
+instance NFData (LeterBuiltin uni) where
+    rnf = rwhnf
+
+deriving via OnlyCheckWhnfNamed "PlutusCore.Builtin.Case.LeterBuiltin" (LeterBuiltin uni)
+    instance NoThunks (LeterBuiltin uni)
+
+instance LetBuiltin uni => Default (LeterBuiltin uni) where
+    def = LeterBuiltin letBuiltin
+
+unavailableLeterBuiltin :: Int -> LeterBuiltin uni
+unavailableLeterBuiltin ver =
+    LeterBuiltin $ \_ -> Left $
+        "'let' TODO " <> display ver

plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs

@@ -50,7 +50,7 @@ import PlutusCore.Core.Type (Type (..))
 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 (Data (Constr))
 import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally (..),
                                                     NumBytesCostedAsNumWords (..))
 import PlutusCore.Pretty.Extra (juxtRenderContext)
@@ -651,11 +651,28 @@ instance CaseBuiltin DefaultUni where
               case x of
                 (l, r) -> Right $ headSpine (branches Vector.! 0) [someValueOf tyL l, someValueOf tyR r]
             | otherwise -> Left $ outOfBoundsErr someVal branches
+        DefaultUniData ->
+          case x of
+            Constr ix ds
+              | 0 <= ix && ix < toInteger len ->
+                Right $
+                  headSpine
+                    (branches Vector.! (fromIntegral ix))
+                    (someValueOf DefaultUniData <$> ds)
+              | otherwise -> Left $ outOfBoundsErr someVal branches
+            _ -> Left "Only 'Constr' constructor can be cased"
         _ -> Left $ display uni <> " isn't supported in 'case'"
       where
         !len = Vector.length branches
     {-# INLINE caseBuiltin #-}
 
+instance LetBuiltin DefaultUni where
+  letBuiltin _someVal@(Some (ValueOf uni x)) =
+    case uni of
+      DefaultUniList ty      -> Right $ someValueOf ty <$> x
+      DefaultUniPair tyL tyR -> Right [someValueOf tyL $ fst x, someValueOf tyR $ snd x]
+      _                      -> Left $ display uni <> "no"
+
 {- 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'

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs

@@ -149,19 +149,19 @@ faster than the used in production. Also see Note [noinline for saving on
 ticks]. -}
 defaultCekParametersA :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann)
 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)
 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)
 defaultCekParametersC =
-    MachineParameters def $
+    MachineParameters def def $
         noinline mkMachineVariantParameters DefaultFunSemanticsVariantC cekCostModelVariantC
 
 {- Note [noinline for saving on ticks]
@@ -360,6 +360,6 @@ unitCostBuiltinCostModel = BuiltinCostModelBase
 unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts DefaultFun (CekValue DefaultUni DefaultFun ann)
 unitCekParameters =
     -- See Note [noinline for saving on ticks].
-    MachineParameters def $
+    MachineParameters def def $
         noinline mkMachineVariantParameters def $
             CostModel unitCekMachineCosts unitCostBuiltinCostModel

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs

@@ -55,6 +55,7 @@ The @val@ type will be 'CekValue' when we're using this with the CEK machine.
 data MachineParameters machineCosts fun val =
     MachineParameters {
       machineCaserBuiltin      :: CaserBuiltin (UniOf val)
+    , machineLeterBuiltin      :: LeterBuiltin (UniOf val)
     , machineVariantParameters :: MachineVariantParameters machineCosts fun val
     }
     deriving stock Generic
@@ -67,8 +68,8 @@ instance (NoThunks machinecosts, Bounded fun, Enum fun) => NoThunks (MachineVari
       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 ]
+  wNoThunks ctx (MachineParameters caser leter varPars) =
+      allNoThunks [ noThunks ctx caser, noThunks ctx leter, noThunks ctx varPars ]
 
 {- Note [The CostingPart constraint in mkMachineVariantParameters]
 Discharging the @CostingPart uni fun ~ builtincosts@ constraint in 'mkMachineParameters' causes GHC

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Analysis/Definitions.hs

@@ -16,6 +16,7 @@ import PlutusCore.Name.Unique (HasUnique, TermUnique (TermUnique), Unique (Uniqu
 import Control.Lens (forMOf_)
 import Control.Monad.State (MonadState, execStateT)
 import Control.Monad.Writer (MonadWriter, WriterT (runWriterT))
+import Data.Foldable (traverse_)
 
 -- | Given a UPLC term, add all of its term definitions and usages, including its subterms,
 -- to a global map.
@@ -40,6 +41,8 @@ handleTerm = \case
         addUsage n ann TermScope
     LamAbs ann n _ ->
         addDef n ann TermScope
+    Let ann ns _ ->
+        traverse_ (\n -> addDef n ann TermScope) ns
     _               -> pure ()
 
 runTermDefs

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    | 10   | 4         |
 
 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).
@@ -114,16 +114,18 @@ encodeTerm
     => Term name uni fun ann
     -> Encoding
 encodeTerm = \case
-    Var      ann n      -> encodeTermTag 0 <> encode ann <> encode n
-    Delay    ann t      -> encodeTermTag 1 <> encode ann <> encodeTerm t
-    LamAbs   ann n t    -> encodeTermTag 2 <> encode ann <> encode (Binder n) <> encodeTerm t
-    Apply    ann t t'   -> encodeTermTag 3 <> encode ann <> encodeTerm t <> encodeTerm t'
-    Constant ann c      -> encodeTermTag 4 <> encode ann <> encode c
-    Force    ann t      -> encodeTermTag 5 <> encode ann <> encodeTerm t
-    Error    ann        -> encodeTermTag 6 <> encode ann
-    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)
+    Var      ann n      -> encodeTermTag 0  <> encode ann <> encode n
+    Delay    ann t      -> encodeTermTag 1  <> encode ann <> encodeTerm t
+    LamAbs   ann n t    -> encodeTermTag 2  <> encode ann <> encode (Binder n) <> encodeTerm t
+    Apply    ann t t'   -> encodeTermTag 3  <> encode ann <> encodeTerm t <> encodeTerm t'
+    Constant ann c      -> encodeTermTag 4  <> encode ann <> encode c
+    Force    ann t      -> encodeTermTag 5  <> encode ann <> encodeTerm t
+    Error    ann        -> encodeTermTag 6  <> encode ann
+    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)
+    Let      ann ns t   -> encodeTermTag 10 <> encode ann <> encode ns <> encodeTerm t
+    Bind     ann t bs   -> encodeTermTag 11 <> encode ann <> encodeTerm t <> encodeListWith encodeTerm bs
 
 decodeTerm
     :: forall name uni fun ann
@@ -161,6 +163,12 @@ decodeTerm version builtinPred = go
         handleTerm 9 = do
             unless (version >= PLC.plcVersion110) $ 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
+            -- TODO: fail when version is low
+            Let <$> decode <*> decode <*> go
+        handleTerm 11 = do
+            -- TODO: fail when version is low
+            Bind <$> decode <*> go <*> decodeListWith go
         handleTerm t = fail $ "Unknown term constructor tag: " ++ show t
 
 sizeTerm
@@ -189,6 +197,8 @@ 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'
+    Let      ann ns t   -> size ann $ size ns $ sizeTerm t sz'
+    Bind     ann t bs   -> size ann $ sizeTerm t $ sizeListWith sizeTerm bs sz'
 
 -- | An encoder for programs.
 --

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Classic.hs

@@ -50,6 +50,14 @@ instance (PrettyClassicBy configName name, PrettyUni uni, Pretty fun, Pretty ann
         Case ann arg cs ->
             sexp "case" (consAnnIf config ann
                 (prettyBy config arg : fmap (prettyBy config) (toList cs)))
+        Let ann names body ->
+          sexp "let" (consAnnIf config ann
+              [ parens' (sep $ prettyBy config <$> names)
+              , prettyBy config body
+              ])
+        Bind ann t binds ->
+          sexp "bind" (consAnnIf config ann
+              (prettyBy config t : (prettyBy config <$> binds)))
       where
         prettyTypeOf :: Some (ValueOf uni) -> Doc dann
         prettyTypeOf (Some (ValueOf uni _ )) = prettyBy juxtRenderContext $ SomeTypeIn uni

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs

@@ -12,6 +12,7 @@ module UntypedPlutusCore.Core.Instance.Pretty.Readable () where
 import PlutusCore.Pretty.PrettyConst
 import PlutusCore.Pretty.Readable
 import PlutusPrelude
+import Prettyprinter.Custom (parens')
 import UntypedPlutusCore.Core.Type
 
 import Prettyprinter
@@ -53,6 +54,10 @@ instance
     Constr _ i es -> iterAppDocM $ \_ prettyArg ->
       ("constr" <+> prettyArg i) :| [prettyArg es]
     Case _ arg cs -> iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg arg, prettyArg (toList cs)]
+    Let _ ns t -> iterAppDocM $ \_ prettyArg ->
+      "let" :| [parens' (sep $ prettyArg <$> ns), prettyArg t]
+    Bind _ t bs -> iterAppDocM $ \_ prettyArg ->
+      "bind" :| [prettyArg t, prettyArg bs]
 
 instance
   (PrettyReadableBy configName (Term name uni fun a)) =>

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Scoping.hs

@@ -50,6 +50,10 @@ instance name ~ Name => EstablishScoping (Term name uni fun) where
         -- that none of the transformations leak variables outside of the branch they're bound in.
         pure . referenceOutOfScope branchBounds $
             Case NotAName aScoped . Vector.fromList $ map referenceInBranch esScopedPoked
+    establishScoping (Let _ _ns _t) = error "no"
+    establishScoping (Bind _ _t _bs) = error "no"
+    -- TODO: Current scope checking uses `NameAnn` which only allows a single name to be annotated.
+    -- It's hard to support `Let` and `Bind` which binds multiple names at once
 
 instance name ~ Name => EstablishScoping (Program name uni fun) where
     establishScoping (Program _ ver term) = Program NotAName ver <$> establishScoping term
@@ -65,6 +69,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 (Let _ _ns _t)         = error "no"
+    collectScopeInfo (Bind _ _t _bs)        = error "no"
 
 instance name ~ Name => CollectScopeInfo (Program name uni fun) where
     collectScopeInfo (Program _ _ term) = collectScopeInfo term

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Plated.hs

@@ -32,6 +32,8 @@ termConstants f term0 = case term0 of
     Builtin{}        -> pure term0
     Constr{}         -> pure term0
     Case{}           -> pure term0
+    Let{}            -> pure term0
+    Bind{}           -> 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
@@ -55,16 +57,18 @@ termUniques f = \case
 -- | Get all the direct child 'Term's of the given 'Term'.
 termSubterms :: Traversal' (Term name uni fun ann) (Term name uni fun ann)
 termSubterms f = \case
-    LamAbs ann n t    -> LamAbs ann n <$> f t
-    Apply ann t1 t2   -> Apply ann <$> f t1 <*> f t2
-    Delay ann t       -> Delay ann <$> f t
-    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
-    e@Error {}        -> pure e
-    v@Var {}          -> pure v
-    c@Constant {}     -> pure c
-    b@Builtin {}      -> pure b
+    LamAbs ann n t     -> LamAbs ann n <$> f t
+    Apply ann t1 t2    -> Apply ann <$> f t1 <*> f t2
+    Delay ann t        -> Delay ann <$> f t
+    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
+    Let ann names body -> Let ann names <$> f body
+    Bind ann t binds   -> Bind ann <$> f t <*> traverse f binds
+    e@Error {}         -> pure e
+    v@Var {}           -> pure v
+    c@Constant {}      -> pure c
+    b@Builtin {}       -> pure b
 {-# INLINE termSubterms #-}
 
 -- | Get all the transitive child 'Constant's of the given 'Term'.

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs

@@ -101,6 +101,8 @@ data Term name uni fun ann
     | Constr !ann !Word64 ![Term name uni fun ann]
     -- See Note [Supported case-expressions].
     | Case !ann !(Term name uni fun ann) !(Vector (Term name uni fun ann))
+    | Let !ann ![name] !(Term name uni fun ann)
+    | Bind !ann !(Term name uni fun ann) ![Term name uni fun ann]
     deriving stock (Functor, Generic)
 
 deriving stock instance (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni)
@@ -168,6 +170,8 @@ termAnn (Force ann _)    = ann
 termAnn (Error ann)      = ann
 termAnn (Constr ann _ _) = ann
 termAnn (Case ann _ _)   = ann
+termAnn (Let ann _ _)    = ann
+termAnn (Bind ann _ _)   = ann
 
 bindFunM
     :: Monad m
@@ -185,6 +189,8 @@ bindFunM f = go where
     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 (Let ann name body)    = Let ann name <$> go body
+    go (Bind ann fun arg)     = Bind ann <$> go fun <*> traverse go arg
 
 bindFun
     :: (ann -> fun -> Term name uni fun' ann)

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/DeBruijn.hs

@@ -93,6 +93,15 @@ deBruijnTermWithM h = go
        Constant ann con -> pure $ Constant ann con
        Builtin ann bn -> pure $ Builtin ann bn
        Error ann -> pure $ Error ann
+       Let ann names body -> do
+         let
+           goNames acc [] = Let ann (acc []) <$> go body
+           goNames acc (n:ns) = declareUnique n $ do
+             n' <- nameToDeBruijn h n
+             withScope $ do
+               goNames (acc . (n':)) ns
+         goNames id names
+       Bind ann t binds -> Bind ann <$> go t <*> traverse go binds
 
 -- | Takes a "handler" function to execute when encountering free variables.
 unDeBruijnTermWithM
@@ -121,3 +130,12 @@ unDeBruijnTermWithM h = go
         Constant ann con -> pure $ Constant ann con
         Builtin ann bn -> pure $ Builtin ann bn
         Error ann -> pure $ Error ann
+        Let ann names body -> do
+          let
+            goNames acc [] = Let ann (acc []) <$> go body
+            goNames acc (n:ns) = declareBinder $ do
+              n' <- deBruijnToName h $ set index deBruijnInitIndex n
+              withScope $ do
+                goNames (acc . (n':)) ns
+          goNames id names
+        Bind ann t binds -> Bind ann <$> go t <*> traverse go binds