[OPTIMIZATION] Revert HeadSpine

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

@@ -21,7 +21,6 @@ module PlutusCore.Builtin.KnownType
     , KnownBuiltinType
     , BuiltinResult (..)
     , ReadKnownM
-    , Spine (..)
     , HeadSpine (..)
     , headSpine
     , MonoHeadSpine
@@ -47,11 +46,9 @@ import PlutusCore.Pretty
 import Control.Monad.Except
 import Data.Bifunctor
 import Data.Either.Extras
-import Data.Functor.Identity
 import Data.String
 import GHC.Exts (inline, oneShot)
 import GHC.TypeLits
-import Prettyprinter
 import Text.PrettyBy.Internal
 import Universe
 
@@ -282,13 +279,6 @@ readKnownConstant val = asConstant val >>= oneShot \case
             Nothing   -> throwError $ BuiltinUnliftingEvaluationError $ typeMismatchError uniExp uniAct
 {-# INLINE readKnownConstant #-}
 
--- | A non-empty spine. Isomorphic to 'NonEmpty', except is strict and is defined as a single
--- recursive data type.
-data Spine a
-    = SpineLast a
-    | SpineCons a (Spine a)
-    deriving stock (Show, Eq, Foldable, Functor)
-
 -- | The head-spine form of an iterated application. Provides O(1) access to the head of the
 -- application. @NonEmpty a ~ HeadSpine a a@, except is strict and the no-spine case is made a separate
 -- constructor for performance reasons (it only takes a single pattern match to access the head when
@@ -297,47 +287,30 @@ data Spine a
 --
 -- Used in built-in functions returning function applications such as 'CaseList'.
 data HeadSpine a b
-    = HeadOnly a
-    | HeadSpine a (Spine b)
+    = Head a
+    | Snoc (HeadSpine a b) b
     deriving stock (Show, Eq, Functor)
 
 -- | @HeadSpine@ but the type of head and spine is same
 type MonoHeadSpine a = HeadSpine a a
 
 instance Bifunctor HeadSpine where
-  bimap headF _ (HeadOnly a)         = HeadOnly $ headF a
-  bimap headF spineF (HeadSpine a b) = HeadSpine (headF a) (spineF <$> b)
+    bimap f g = go where
+        go (Head x)    = Head (f x)
+        go (Snoc ys y) = Snoc (go ys) (g y)
+    {-# INLINE bimap #-}
 
 -- | Construct @HeadSpine@ from head and list.
 headSpine :: a -> [b] -> HeadSpine a b
-headSpine h [] = HeadOnly h
-headSpine h (x:xs) =
-  -- It's critical to use 'foldr' here, so that deforestation kicks in.
-  -- See Note [Definition of foldl'] in "GHC.List" and related Notes around for an explanation
-  -- of the trick.
-  HeadSpine h $ foldr (\x2 r x1 -> SpineCons x1 $ r x2) SpineLast xs x
+-- It's critical to use 'foldl' here, so that deforestation kicks in.
+-- See Note [Definition of foldl'] in "GHC.List" and related Notes around for an explanation
+-- of the trick.
+headSpine = foldl Snoc . Head
 {-# INLINE headSpine #-}
 
--- |
---
--- >>> import Text.Pretty
--- >>> pretty (SpineCons 'a' $ SpineLast 'b')
--- [a, b]
-instance Pretty a => Pretty (Spine a) where pretty = pretty . map Identity . toList
-instance PrettyBy config a => DefaultPrettyBy config (Spine a)
-deriving via PrettyCommon (Spine a)
-    instance PrettyDefaultBy config (Spine a) => PrettyBy config (Spine a)
-
--- |
---
--- >>> import Text.Pretty
--- >>> pretty (HeadOnly 'z')
--- z
--- >>> pretty (HeadSpine 'f' (SpineCons 'x' $ SpineLast 'y'))
--- f `applyN` [x, y]
 instance (Pretty a, Pretty b) => Pretty (HeadSpine a b) where
-    pretty (HeadOnly x)     = pretty x
-    pretty (HeadSpine f xs) = pretty f <+> "`applyN`" <+> pretty xs
+    pretty _ = ""
+
 instance (PrettyBy config a, PrettyBy config b) => DefaultPrettyBy config (HeadSpine a b)
 deriving via PrettyCommon (HeadSpine a b)
     instance PrettyDefaultBy config (HeadSpine a b) => PrettyBy config (HeadSpine a b)

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

@@ -1,3 +1,4 @@
+
 {-# OPTIONS -fno-warn-missing-pattern-synonym-signatures #-}
 -- on 9.2.4 this is the flag that suppresses the above warning
 {-# OPTIONS -Wno-missing-signatures #-}
@@ -552,11 +553,11 @@ instance CaseBuiltin DefaultUni where
             -- We allow there to be only one branch as long as the scrutinee is 'False'.
             -- This is strictly to save size by not having the 'True' branch if it was gonna be
             -- 'Error' anyway.
-            False | len == 1 || len == 2 -> Right $ HeadOnly $ branches Vector.! 0
-            True  |             len == 2 -> Right $ HeadOnly $ branches Vector.! 1
+            False | len == 1 || len == 2 -> Right $ Head $ branches Vector.! 0
+            True  |             len == 2 -> Right $ Head $ branches Vector.! 1
             _                            -> Left  $ outOfBoundsErr someVal branches
         DefaultUniInteger
-            | 0 <= x && x < toInteger len -> Right $ HeadOnly $ branches Vector.! fromInteger x
+            | 0 <= x && x < toInteger len -> Right $ Head $ branches Vector.! fromInteger x
             | otherwise                   -> Left  $ outOfBoundsErr someVal branches
         DefaultUniList ty
             | len == 1 ->
@@ -565,7 +566,7 @@ instance CaseBuiltin DefaultUni where
                 (y : ys) -> Right $ headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys]
             | len == 2 ->
               case x of
-                []       -> Right $ HeadOnly $ branches Vector.! 1
+                []       -> Right $ Head $ branches Vector.! 1
                 (y : ys) -> Right $ headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys]
             | otherwise            -> Left $ outOfBoundsErr someVal branches
         _ -> Left $ display uni <> " isn't supported in 'case'"

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

@@ -247,13 +247,12 @@ FrameCase cs : stack <| e = case e of
         case unCaserBuiltin caser val $ Vector.fromList cs of
             Left err  ->
                 throwErrorWithCause (OperationalError $ CkCaseBuiltinError err) $ ckValueToTerm e
-            Right (HeadOnly fX) -> stack |> fX
-            Right (HeadSpine f xs) -> transferConstantSpine xs stack |> f
+            Right hSp ->
+                let go stack' (Head f)    = stack' |> f
+                    go stack' (Snoc xs x) = go (FrameAwaitFunValue (VCon x) : stack') xs
+                in go stack hSp
     _ -> throwErrorWithCause (StructuralError NonConstrScrutinizedMachineError) $ ckValueToTerm e
 
-transferConstantSpine :: Spine (Some (ValueOf uni)) -> Context uni fun -> Context uni fun
-transferConstantSpine args ctx = foldr ((:) . FrameAwaitFunValue . VCon) ctx args
-
 -- | Take a possibly partial builtin application and
 --
 -- - either create a 'CkValue' by evaluating the application if it's saturated (emitting logs, if

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

@@ -341,10 +341,10 @@ mkFreshTermLet aT a = do
 
 -- | 'apply' the head of the application to the arguments iteratively.
 headSpineToTerm :: TermLike term tyname name uni fun => ann -> MonoHeadSpine (term ann) -> term ann
-headSpineToTerm _ (HeadOnly t)       = t
-headSpineToTerm ann (HeadSpine t ts) = foldl (apply ann) t ts
+headSpineToTerm _   (Head f)    = f
+headSpineToTerm ann (Snoc ys y) = apply ann (headSpineToTerm ann ys) y
 
 -- | @headSpineToTerm@ but without annotation.
 headSpineToTermNoAnn :: TermLike term tyname name uni fun => MonoHeadSpine (term ()) -> term ()
-headSpineToTermNoAnn (HeadOnly t)     = t
-headSpineToTermNoAnn (HeadSpine t ts) = foldl (apply ()) t ts
+headSpineToTermNoAnn (Head f)    = f
+headSpineToTermNoAnn (Snoc ys y) = apply () (headSpineToTermNoAnn ys) y

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

@@ -707,14 +707,6 @@ But in case of 'Spine' the builtins machinery directly produces values, not term
 directly to the head of the application. Which is why 'transferSpine' is a right fold.
 -}
 
--- | Transfers a 'Spine' of constant values onto the stack. The first argument will be at the top of the stack.
-transferConstantSpine
-    :: Spine (Some (ValueOf uni))
-    -> Context uni fun ann
-    -> Context uni fun ann
-transferConstantSpine args ctx = foldr (FrameAwaitFunValue . VCon) ctx args
-{-# INLINE transferConstantSpine #-}
-
 runCekM
     :: forall cost uni fun ann
     . ThrowableBuiltins uni fun
@@ -876,8 +868,10 @@ enterComputeCek = computeCek
         -- Proceed with caser when expression given is not Constr.
         VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of
             Left err          -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e
-            Right (HeadOnly fX) -> computeCek ctx env fX
-            Right (HeadSpine f xs) -> computeCek (transferConstantSpine xs ctx) env f
+            Right hSp ->
+                let go ctx' (Head f)    = computeCek ctx' env f
+                    go ctx' (Snoc xs x) = go (FrameAwaitFunValue (VCon x) ctx') xs
+                in go ctx hSp
         _ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e
 
     -- | @force@ a term and proceed.

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

@@ -106,11 +106,6 @@ data Context uni fun ann
 deriving stock instance (GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni)
     => Show (Context uni fun ann)
 
--- | Transfers a 'Spine' of contant values onto the stack. The first argument will be at the top of the stack.
-transferConstantSpine :: ann -> Spine (Some (ValueOf uni)) -> Context uni fun ann -> Context uni fun ann
-transferConstantSpine ann args ctx =
-  foldr (FrameAwaitFunValue ann . VCon) ctx args
-
 computeCek
     :: forall uni fun ann s
     . (ThrowableBuiltins uni fun, GivenCekReqs uni fun ann s)
@@ -217,9 +212,11 @@ returnCek (FrameCases ann env cs ctx) e = case e of
               in computeCek ctx' env t
         Nothing -> throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e
     VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of
-        Left err  -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e
-        Right (HeadOnly fX) -> pure $ Computing ctx env fX
-        Right (HeadSpine f xs) -> pure $ Computing (transferConstantSpine ann xs ctx) env f
+        Left err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e
+        Right hSp ->
+            let go ctx' (Head f)    = computeCek ctx' env f
+                go ctx' (Snoc xs x) = go (FrameAwaitFunValue ann (VCon x) ctx') xs
+            in go ctx hSp
     _ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e
 
 -- | @force@ a term and proceed.