[Evaluation] [Performance] Use the strict 'List' for 'Constr'

plutus-core/plutus-core.cabal

@@ -332,6 +332,7 @@ library
     , semigroups                  >=0.19.1
     , serialise
     , some
+    , strict-base
     , template-haskell
     , text
     , th-compat

plutus-core/plutus-core/src/PlutusCore/Compiler/Erase.hs

@@ -1,6 +1,7 @@
 module PlutusCore.Compiler.Erase (eraseTerm, eraseProgram) where
 
 import Data.Vector (fromList)
+import GHC.IsList qualified as GHC
 import PlutusCore.Core
 import PlutusCore.Name.Unique
 import UntypedPlutusCore.Core qualified as UPLC
@@ -24,8 +25,8 @@ eraseTerm (TyInst ann term _)      = UPLC.Force ann (eraseTerm term)
 eraseTerm (Unwrap _ term)          = eraseTerm term
 eraseTerm (IWrap _ _ _ term)       = eraseTerm term
 eraseTerm (Error ann _)            = UPLC.Error ann
-eraseTerm (Constr ann _ i args)    = UPLC.Constr ann i (fmap eraseTerm args)
-eraseTerm (Case ann _ arg cs)      = UPLC.Case ann (eraseTerm arg) (fromList $ fmap eraseTerm cs)
+eraseTerm (Constr ann _ i args)    = UPLC.Constr ann i (GHC.fromList $ map eraseTerm args)
+eraseTerm (Case ann _ arg cs)      = UPLC.Case ann (eraseTerm arg) (fromList $ map eraseTerm cs)
 
 eraseProgram :: HasUnique name TermUnique
              => Program tyname name uni fun ann

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

@@ -99,7 +99,7 @@ eqTermM (Error ann1) (Error ann2) = eqM ann1 ann2
 eqTermM (Constr ann1 i1 args1) (Constr ann2 i2 args2) = do
     eqM ann1 ann2
     eqM i1 i2
-    case zipExact args1 args2 of
+    case zipExact (toList args1) (toList args2) of
         Just ps -> for_ ps $ \(t1, t2) -> eqTermM t1 t2
         Nothing -> empty
 eqTermM (Case ann1 a1 cs1) (Case ann2 a2 cs2) = do

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

@@ -24,6 +24,7 @@ import Flat
 import Flat.Decoder
 import Flat.Encoder
 import Flat.Encoder.Strict (sizeListWith)
+import GHC.IsList qualified as GHC
 import Universe
 
 {-
@@ -122,7 +123,7 @@ encodeTerm = \case
     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
+    Constr   ann i es   -> encodeTermTag 8 <> encode ann <> encode i <> encodeListWith encodeTerm (GHC.toList es)
     Case     ann arg cs -> encodeTermTag 9 <> encode ann <> encodeTerm arg <> encodeListWith encodeTerm (V.toList cs)
 
 decodeTerm
@@ -157,7 +158,7 @@ decodeTerm version builtinPred = go
                 Just e  -> fail e
         handleTerm 8 = do
             unless (version >= PLC.plcVersion110) $ fail $ "'constr' is not allowed before version 1.1.0, this program has version: " ++ (show $ pretty version)
-            Constr   <$> decode <*> decode <*> decodeListWith go
+            Constr   <$> decode <*> decode <*> (GHC.fromList <$> decodeListWith 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)

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

@@ -46,7 +46,7 @@ instance (PrettyClassicBy configName name, PrettyUni uni, Pretty fun, Pretty ann
             sexp "force" (consAnnIf config ann
                 [prettyBy config term])
         Constr ann i es ->
-            sexp "constr" (consAnnIf config ann (pretty i : fmap (prettyBy config) es))
+            sexp "constr" (consAnnIf config ann (pretty i : fmap (prettyBy config) (toList es)))
         Case ann arg cs ->
             sexp "case" (consAnnIf config ann
                 (prettyBy config arg : fmap (prettyBy config) (toList cs)))

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

@@ -51,7 +51,7 @@ instance
     -- Always rendering the tag on the same line for more compact output, it's just a tiny integer
     -- anyway.
     Constr _ i es -> iterAppDocM $ \_ prettyArg ->
-      ("constr" <+> prettyArg i) :| [prettyArg es]
+      ("constr" <+> prettyArg i) :| [prettyArg (toList es)]
     Case _ arg cs -> iterAppDocM $ \_ prettyArg -> "case" :| [prettyArg arg, prettyArg (toList cs)]
 
 instance

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

@@ -28,8 +28,11 @@ module UntypedPlutusCore.Core.Type
 import Control.Lens
 import PlutusPrelude
 
+import Data.Hashable
+import Data.Strict.List
 import Data.Vector
 import Data.Word
+import GHC.IsList qualified as GHC
 import PlutusCore.Builtin qualified as TPLC
 import PlutusCore.Core qualified as TPLC
 import PlutusCore.MkPlc
@@ -85,10 +88,13 @@ data Term name uni fun ann
     -- TODO: worry about overflow, maybe use an Integer
     -- TODO: try spine-strict list or strict list or vector
     -- See Note [Constr tag type]
-    | Constr !ann !Word64 ![Term name uni fun ann]
+    | Constr !ann !Word64 !(List (Term name uni fun ann))
     | Case !ann !(Term name uni fun ann) !(Vector (Term name uni fun ann))
     deriving stock (Functor, Generic)
 
+deriving anyclass instance NFData a => NFData (List a)
+deriving anyclass instance Hashable a => Hashable (List a)
+
 deriving stock instance (Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni)
     => Show (Term name uni fun ann)
 
@@ -123,7 +129,7 @@ instance TermLike (Term name uni fun) TPLC.TyName name uni fun where
     unwrap   = const id
     iWrap    = \_ _ _ -> id
     error    = \ann _ -> Error ann
-    constr   = \ann _ i es -> Constr ann i es
+    constr   = \ann _ i es -> Constr ann i $ GHC.fromList es
     kase     = \ann _ arg cs -> Case ann arg (fromList cs)
 
 instance TPLC.HasConstant (Term name uni fun ()) where

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

@@ -11,6 +11,7 @@ module UntypedPlutusCore.Core.Zip
 import Control.Monad (void, when)
 import Control.Monad.Except (MonadError, throwError)
 import Data.Vector
+import GHC.IsList qualified as GHC
 import UntypedPlutusCore.Core.Instance.Eq ()
 import UntypedPlutusCore.Core.Type
 
@@ -60,7 +61,8 @@ tzipWith f term1 term2 = do
    go (Apply a1 t1a t1b) (Apply a2 t2a t2b) = Apply (f a1 a2) <$> go t1a t2a <*> go t1b t2b
    go (Force a1 t1) (Force a2 t2)           = Force (f a1 a2) <$> go t1 t2
    go (Delay a1 t1) (Delay a2 t2)           = Delay (f a1 a2) <$> go t1 t2
-   go (Constr a1 i1 ts1) (Constr a2 _i2 ts2) = Constr (f a1 a2) i1 <$> zipExactWithM go ts1 ts2
+   go (Constr a1 i1 ts1) (Constr a2 _i2 ts2) =
+       Constr (f a1 a2) i1 <$> (GHC.fromList <$> zipExactWithM go (GHC.toList ts1) (GHC.toList 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 _ _                                   =

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs

@@ -98,6 +98,7 @@ import Data.Hashable (Hashable)
 import Data.Kind qualified as GHC
 import Data.Proxy
 import Data.Semigroup (stimes)
+import Data.Strict.List (List (..))
 import Data.Text (Text)
 import Data.Vector qualified as V
 import Data.Word
@@ -565,9 +566,9 @@ dischargeCekValue = \case
     VBuiltin _ term _                    -> term
     VConstr i es                         -> Constr () i (fmap dischargeCekValue $ stack2list es)
       where
-        stack2list = go []
+        stack2list = go Nil
         go acc EmptyStack           = acc
-        go acc (ConsStack arg rest) = go (arg : acc) rest
+        go acc (ConsStack arg rest) = go (arg :! acc) rest
 
 instance (PrettyUni uni, Pretty fun) => PrettyBy PrettyConfigPlc (CekValue uni fun ann) where
     prettyBy cfg = prettyBy cfg . dischargeCekValue
@@ -598,7 +599,7 @@ data Context uni fun ann
     | FrameForce !(Context uni fun ann)
     -- ^ @(force _)@
     -- See Note [Accumulators for terms]
-    | FrameConstr !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann)
+    | FrameConstr !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 !(List (NTerm uni fun ann)) !(ArgStack uni fun ann) !(Context uni fun ann)
     -- ^ @(constr i V0 ... Vj-1 _ Nj ... Nn)@
     | FrameCases !(CekValEnv uni fun ann) !(V.Vector (NTerm uni fun ann)) !(Context uni fun ann)
     -- ^ @(case _ C0 .. Cn)@
@@ -727,8 +728,8 @@ enterComputeCek = computeCek
     computeCek !ctx !env (Constr _ i es) = do
         stepAndMaybeSpend BConstr
         case es of
-          (t : rest) -> computeCek (FrameConstr env i rest EmptyStack ctx) env t
-          []         -> returnCek ctx $ VConstr i EmptyStack
+          (t :! rest) -> computeCek (FrameConstr env i rest EmptyStack ctx) env t
+          Nil         -> returnCek ctx $ VConstr i EmptyStack
     -- s ; ρ ▻ case S C0 ... Cn  ↦  s , case _ (C0 ... Cn, ρ) ; ρ ▻ S
     computeCek !ctx !env (Case _ scrut cs) = do
         stepAndMaybeSpend BCase
@@ -771,8 +772,8 @@ enterComputeCek = computeCek
     returnCek (FrameConstr env i todo done ctx) e = do
         let done' = ConsStack e done
         case todo of
-          (next : todo') -> computeCek (FrameConstr env i todo' done' ctx) env next
-          []             -> returnCek ctx $ VConstr i done'
+          (next :! todo') -> computeCek (FrameConstr env i todo' done' ctx) env next
+          Nil             -> returnCek ctx $ VConstr i done'
     -- s , case _ (C0 ... CN, ρ) ◅ constr i V1 .. Vm  ↦  s , [_ V1 ... Vm] ; ρ ▻ Ci
     returnCek (FrameCases env cs ctx) e = case e of
         -- If the index is larger than the max bound of an Int, or negative, then it's a bad index

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs

@@ -60,6 +60,7 @@ import Control.Monad.Primitive
 import Data.Proxy
 import Data.RandomAccessList.Class qualified as Env
 import Data.Semigroup (stimes)
+import Data.Strict.List (List (..))
 import Data.Text (Text)
 import Data.Vector qualified as V
 import Data.Word (Word64)
@@ -99,7 +100,7 @@ data Context uni fun ann
     | FrameAwaitFunTerm ann !(CekValEnv uni fun ann) !(NTerm uni fun ann) !(Context uni fun ann) -- ^ @[_ N]@
     | FrameAwaitFunValue ann !(CekValue uni fun ann) !(Context uni fun ann)
     | FrameForce ann !(Context uni fun ann)                                               -- ^ @(force _)@
-    | FrameConstr ann !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 ![NTerm uni fun ann] !(ArgStack uni fun ann) !(Context uni fun ann)
+    | FrameConstr ann !(CekValEnv uni fun ann) {-# UNPACK #-} !Word64 !(List (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)
     | NoFrame
 
@@ -158,8 +159,8 @@ computeCek !ctx !_ (Builtin _ bn) = do
 computeCek !ctx !env (Constr ann i es) = do
     stepAndMaybeSpend BConstr
     pure $ case es of
-        (t : rest) -> Computing (FrameConstr ann env i rest EmptyStack ctx) env t
-        []         -> Returning ctx $ VConstr i EmptyStack
+        (t :! rest) -> Computing (FrameConstr ann env i rest EmptyStack ctx) env t
+        Nil         -> Returning ctx $ VConstr i EmptyStack
 -- s ; ρ ▻ case S C0 ... Cn  ↦  s , case _ (C0 ... Cn, ρ) ; ρ ▻ S
 computeCek !ctx !env (Case ann scrut cs) = do
     stepAndMaybeSpend BCase
@@ -196,8 +197,8 @@ returnCek (FrameAwaitFunValue ann arg ctx) fun =
 returnCek (FrameConstr ann env i todo done ctx) e = do
     let done' = ConsStack e done
     case todo of
-        (next : todo') -> computeCek (FrameConstr ann env i todo' done' ctx) env next
-        []             -> returnCek ctx $ VConstr i done'
+        (next :! todo') -> computeCek (FrameConstr ann env i todo' done' ctx) env next
+        Nil             -> returnCek ctx $ VConstr i done'
 -- s , case _ (C0 ... CN, ρ) ◅ constr i V1 .. Vm  ↦  s , [_ V1 ... Vm] ; ρ ▻ Ci
 returnCek (FrameCases ann env cs ctx) e = case e of
     -- If the index is larger than the max bound of an Int, or negative, then it's a bad index

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

@@ -29,6 +29,7 @@ import UntypedPlutusCore.Rename (Rename (rename))
 
 import Data.Text (Text)
 import Data.Vector qualified as V
+import GHC.IsList qualified as GHC
 import PlutusCore.Error (AsParserErrorBundle)
 import PlutusCore.MkPlc (mkIterApp)
 import PlutusCore.Parser hiding (parseProgram, parseTerm, program)
@@ -75,7 +76,9 @@ errorTerm = withSpan $ \sp ->
 constrTerm :: Parser PTerm
 constrTerm = withSpan $ \sp ->
     inParens $ do
-      res <- UPLC.Constr sp <$> (symbol "constr" *> lexeme Lex.decimal) <*> many term
+      res <- UPLC.Constr sp
+          <$> (symbol "constr" *> lexeme Lex.decimal)
+          <*> (GHC.fromList <$> many term)
       whenVersion (\v -> v < plcVersion110) $ fail "'constr' is not allowed before version 1.1.0"
       pure res
 

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/CaseReduce.hs

@@ -11,6 +11,7 @@ import UntypedPlutusCore.Transform.Simplifier (SimplifierStage (CaseReduce), Sim
 
 import Control.Lens (transformOf)
 import Data.Vector qualified as V
+import GHC.IsList qualified as GHC
 
 caseReduce
     :: Monad m
@@ -24,5 +25,5 @@ caseReduce term = do
 processTerm :: Term name uni fun a -> Term name uni fun a
 processTerm = \case
     Case ann (Constr _ i args) cs | Just c <- (V.!?) cs (fromIntegral i) ->
-                                    mkIterApp c ((ann,) <$> args)
+                                    mkIterApp c ((ann,) <$> GHC.toList args)
     t                                                     -> t

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs

@@ -410,7 +410,7 @@ costIsAcceptable = \case
   Apply{} -> False
   -- Inlining constructors of size 1 or 0 seems okay, but does result in doing
   -- the work for the elements at each use site.
-  Constr _ _ es -> case es of
+  Constr _ _ es -> case toList es of
     []  -> True
     [e] -> costIsAcceptable e
     _   -> False
@@ -434,7 +434,7 @@ sizeIsAcceptable inlineConstants = \case
   -- See Note [Differences from PIR inliner] 4
   LamAbs{} -> False
   -- Inlining constructors of size 1 or 0 seems okay
-  Constr _ _ es -> case es of
+  Constr _ _ es -> case toList es of
     []  -> True
     [e] -> sizeIsAcceptable inlineConstants e
     _   -> False

plutus-core/untyped-plutus-core/test/Analysis/Spec.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
 
 module Analysis.Spec where
 
@@ -20,15 +22,15 @@ goldenEvalOrder name tm =
 
 -- Should hit Unknown before trying to process the undefined. Shows
 -- that the computation is lazy
--- [ [ n m ] (constr 1 [undefined]) ]
+-- [ [ n m ] [undefined] ]
 dangerTerm :: Term Name PLC.DefaultUni PLC.DefaultFun ()
 dangerTerm = runQuote $ do
   n <- freshName "n"
   m <- freshName "m"
   -- The UPLC term type is strict, so it's hard to hide an undefined in there
-  -- Take advantage of the fact that it's still using lazy lists for constr
+  -- Take advantage of the fact that it's still using lazy lists as constant
   -- arguments for now.
-  pure $ Apply () (Apply () (Var () n) (Var () m)) (Constr () 1 [undefined])
+  pure $ Apply () (Apply () (Var () n) (Var () m)) (mkConstant @[Integer] () [undefined])
 
 letFun :: Term Name PLC.DefaultUni PLC.DefaultFun ()
 letFun = runQuote $ do

plutus-core/untyped-plutus-core/test/Generators.hs

@@ -29,6 +29,7 @@ import Control.Lens (view)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Vector qualified as V
+import GHC.IsList qualified as GHC
 
 import Hedgehog (annotate, annotateShow, failure, property, tripping, (===))
 import Hedgehog.Gen qualified as Gen
@@ -60,7 +61,7 @@ compareTerm (Force _ t ) (Force _ t')         = compareTerm t t'
 compareTerm (Delay _ t ) (Delay _ t')         = compareTerm t t'
 compareTerm (Constant _ x) (Constant _ y)     = x == y
 compareTerm (Builtin _ bi) (Builtin _ bi')    = bi == bi'
-compareTerm (Constr _ i es) (Constr _ i' es') = i == i' && maybe False (all (uncurry compareTerm)) (zipExact es es')
+compareTerm (Constr _ i es) (Constr _ i' es') = i == i' && maybe False (all (uncurry compareTerm)) (zipExact (GHC.toList es) (GHC.toList es'))
 compareTerm (Case _ arg cs) (Case _ arg' cs') = compareTerm arg arg' && maybe False (all (uncurry compareTerm)) (zipExact (V.toList cs) (V.toList cs'))
 compareTerm (Error _ ) (Error _ )             = True
 compareTerm _ _                               = False

plutus-core/untyped-plutus-core/test/Transform/CaseOfCase/Test.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
 

plutus-core/untyped-plutus-core/test/Transform/Simplify.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLists   #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
 
@@ -449,7 +450,7 @@ cseExpensive = plus arg arg'
   where
     plus a b = mkIterApp (Builtin () PLC.AddInteger) [((), a), ((), b)]
     con = mkConstant @Integer ()
-    mkArg = foldl1 plus . fmap (\i -> plus (con (2 * i)) (con (2 * i + 1)))
+    mkArg = foldl1 plus . map (\i -> plus (con (2 * i)) (con (2 * i + 1)))
     arg = mkArg [0 .. 200]
     arg' = mkArg [0 .. 200]
 

plutus-metatheory/src/Untyped.hs

@@ -11,6 +11,7 @@ import Data.ByteString as BS hiding (map)
 import Data.Text as T hiding (map)
 import Data.Word (Word64)
 import GHC.Exts (IsList (..))
+import GHC.IsList qualified as GHC
 import Universe
 
 -- Untyped (Raw) syntax
@@ -42,7 +43,7 @@ conv (Constant _ c)  = UCon c
 conv (Error _)       = UError
 conv (Delay _ t)     = UDelay (conv t)
 conv (Force _ t)     = UForce (conv t)
-conv (Constr _ i es) = UConstr (toInteger i) (toList (fmap conv es))
+conv (Constr _ i es) = UConstr (toInteger i) (map conv $ GHC.toList es)
 conv (Case _ arg cs) = UCase (conv arg) (toList (fmap conv cs))
 
 tmnames = ['a' .. 'z']
@@ -63,6 +64,6 @@ uconv i UError         = Error ()
 uconv i (UBuiltin b)   = Builtin () b
 uconv i (UDelay t)     = Delay () (uconv i t)
 uconv i (UForce t)     = Force () (uconv i t)
-uconv i (UConstr j xs) = Constr () (fromInteger j) (fmap (uconv i) xs)
+uconv i (UConstr j xs) = Constr () (fromInteger j) (GHC.fromList $ map (uconv i) xs)
 uconv i (UCase t xs)   = Case () (uconv i t) (fromList (fmap (uconv i) xs))