Skip to content

Commit 8e9a7d9

Browse files
SeungheonOhSeungheonOh
authored
[OPTIMIZATION] Combine Either Text (HeadSpine ...) into HeadSpine (#7452)
* Combine `Either Text (HeadSpine ...)` into `HeadSpine` * Try lazy error on `HeadSpine`
1 parent f96714c commit 8e9a7d9

File tree

9 files changed

+56
-47
lines changed

9 files changed

+56
-47
lines changed

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@
55

66
module PlutusCore.Builtin.Case where
77

8-
import PlutusCore.Builtin.KnownType (HeadSpine)
8+
import PlutusCore.Builtin.KnownType (HeadSpine (..))
99
import PlutusCore.Core.Type (Type, UniOf)
1010
import PlutusCore.Name.Unique (TyName)
1111

@@ -36,15 +36,15 @@ class CaseBuiltin uni where
3636
:: UniOf term ~ uni
3737
=> Some (ValueOf uni)
3838
-> Vector term
39-
-> Either Text (HeadSpine term (Some (ValueOf uni)))
39+
-> HeadSpine Text term (Some (ValueOf uni))
4040

4141
-- See Note [DO NOT newtype-wrap functions].
4242
-- | A @data@ version of 'CaseBuiltin'. we parameterize the evaluator by a 'CaserBuiltin' so that
4343
-- the caller can choose whether to use the 'caseBuiltin' method or the always failing caser (the
4444
-- latter is required for earlier protocol versions when we didn't support casing on builtins).
4545
data CaserBuiltin uni = CaserBuiltin
4646
{ unCaserBuiltin
47-
:: !(forall term. UniOf term ~ uni => Some (ValueOf uni) -> Vector term -> Either Text (HeadSpine term (Some (ValueOf uni))))
47+
:: !(forall term. UniOf term ~ uni => Some (ValueOf uni) -> Vector term -> HeadSpine Text term (Some (ValueOf uni)))
4848
}
4949

5050
instance NFData (CaserBuiltin uni) where
@@ -58,5 +58,5 @@ instance CaseBuiltin uni => Default (CaserBuiltin uni) where
5858

5959
unavailableCaserBuiltin :: Int -> CaserBuiltin uni
6060
unavailableCaserBuiltin ver =
61-
CaserBuiltin $ \_ _ -> Left $
61+
CaserBuiltin $ \_ _ -> HeadError $
6262
"'case' on values of built-in types is not supported in protocol version " <> display ver

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

Lines changed: 15 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -335,20 +335,22 @@ data Spine a
335335
-- it's empty -- and the no-spine case is by far the most common one, hence we want to optimize it).
336336
--
337337
-- Used in built-in functions returning function applications such as 'CaseList'.
338-
data HeadSpine a b
338+
data HeadSpine err a b
339339
= HeadOnly a
340340
| HeadSpine a (Spine b)
341+
| HeadError ~err
341342
deriving stock (Show, Eq, Functor)
342343

343344
-- | @HeadSpine@ but the type of head and spine is same
344-
type MonoHeadSpine a = HeadSpine a a
345+
type MonoHeadSpine err a = HeadSpine err a a
345346

346-
instance Bifunctor HeadSpine where
347+
instance Bifunctor (HeadSpine err) where
348+
bimap _ _ (HeadError x) = HeadError x
347349
bimap headF _ (HeadOnly a) = HeadOnly $ headF a
348350
bimap headF spineF (HeadSpine a b) = HeadSpine (headF a) (spineF <$> b)
349351

350352
-- | Construct @HeadSpine@ from head and list.
351-
headSpine :: a -> [b] -> HeadSpine a b
353+
headSpine :: a -> [b] -> HeadSpine err a b
352354
headSpine h [] = HeadOnly h
353355
headSpine h (x:xs) =
354356
-- It's critical to use 'foldr' here, so that deforestation kicks in.
@@ -374,12 +376,17 @@ deriving via PrettyCommon (Spine a)
374376
-- z
375377
-- >>> pretty (HeadSpine 'f' (SpineCons 'x' $ SpineLast 'y'))
376378
-- f `applyN` [x, y]
377-
instance (Pretty a, Pretty b) => Pretty (HeadSpine a b) where
379+
instance (Pretty err, Pretty a, Pretty b) => Pretty (HeadSpine err a b) where
380+
pretty (HeadError x) = "HeadError" <+> pretty x
378381
pretty (HeadOnly x) = pretty x
379382
pretty (HeadSpine f xs) = pretty f <+> "`applyN`" <+> pretty xs
380-
instance (PrettyBy config a, PrettyBy config b) => DefaultPrettyBy config (HeadSpine a b)
381-
deriving via PrettyCommon (HeadSpine a b)
382-
instance PrettyDefaultBy config (HeadSpine a b) => PrettyBy config (HeadSpine a b)
383+
instance (PrettyBy config err, PrettyBy config a, PrettyBy config (Spine b)) =>
384+
DefaultPrettyBy config (HeadSpine err a b) where
385+
defaultPrettyBy config (HeadError x) = "HeadError" <+> prettyBy config x
386+
defaultPrettyBy config (HeadOnly x) = prettyBy config x
387+
defaultPrettyBy config (HeadSpine f xs) = prettyBy config f <+> "`applyN`" <+> prettyBy config xs
388+
deriving via PrettyCommon (HeadSpine err a b)
389+
instance PrettyDefaultBy config (HeadSpine err a b) => PrettyBy config (HeadSpine err a b)
383390

384391
-- See Note [Performance of ReadKnownIn and MakeKnownIn instances].
385392
class uni ~ UniOf val => MakeKnownIn uni val a where

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

Lines changed: 15 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -703,34 +703,34 @@ instance AnnotateCaseBuiltin DefaultUni where
703703
instance CaseBuiltin DefaultUni where
704704
caseBuiltin someVal@(Some (ValueOf uni x)) branches = case uni of
705705
DefaultUniUnit
706-
| 1 == len -> Right $ HeadOnly $ branches Vector.! 0
707-
| otherwise -> Left $ outOfBoundsErr someVal branches
706+
| 1 == len -> HeadOnly $ branches Vector.! 0
707+
| otherwise -> HeadError $ outOfBoundsErr someVal branches
708708
DefaultUniBool -> case x of
709709
-- We allow there to be only one branch as long as the scrutinee is 'False'.
710710
-- This is strictly to save size by not having the 'True' branch if it was gonna be
711711
-- 'Error' anyway.
712-
False | len == 1 || len == 2 -> Right $ HeadOnly $ branches Vector.! 0
713-
True | len == 2 -> Right $ HeadOnly $ branches Vector.! 1
714-
_ -> Left $ outOfBoundsErr someVal branches
712+
False | len == 1 || len == 2 -> HeadOnly $ branches Vector.! 0
713+
True | len == 2 -> HeadOnly $ branches Vector.! 1
714+
_ -> HeadError $ outOfBoundsErr someVal branches
715715
DefaultUniInteger
716-
| 0 <= x && x < toInteger len -> Right $ HeadOnly $ branches Vector.! fromInteger x
717-
| otherwise -> Left $ outOfBoundsErr someVal branches
716+
| 0 <= x && x < toInteger len -> HeadOnly $ branches Vector.! fromInteger x
717+
| otherwise -> HeadError $ outOfBoundsErr someVal branches
718718
DefaultUniList ty
719719
| len == 1 ->
720720
case x of
721-
[] -> Left "Expected non-empty list, got empty list for casing list"
722-
(y : ys) -> Right $ headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys]
721+
[] -> HeadError "Expected non-empty list, got empty list for casing list"
722+
(y : ys) -> headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys]
723723
| len == 2 ->
724724
case x of
725-
[] -> Right $ HeadOnly $ branches Vector.! 1
726-
(y : ys) -> Right $ headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys]
727-
| otherwise -> Left $ outOfBoundsErr someVal branches
725+
[] -> HeadOnly $ branches Vector.! 1
726+
(y : ys) -> headSpine (branches Vector.! 0) [someValueOf ty y, someValueOf uni ys]
727+
| otherwise -> HeadError $ outOfBoundsErr someVal branches
728728
DefaultUniPair tyL tyR
729729
| len == 1 ->
730730
case x of
731-
(l, r) -> Right $ headSpine (branches Vector.! 0) [someValueOf tyL l, someValueOf tyR r]
732-
| otherwise -> Left $ outOfBoundsErr someVal branches
733-
_ -> Left $ display uni <> " isn't supported in 'case'"
731+
(l, r) -> headSpine (branches Vector.! 0) [someValueOf tyL l, someValueOf tyR r]
732+
| otherwise -> HeadError $ outOfBoundsErr someVal branches
733+
_ -> HeadError $ display uni <> " isn't supported in 'case'"
734734
where
735735
!len = Vector.length branches
736736
{-# INLINE caseBuiltin #-}

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -245,10 +245,10 @@ FrameCase cs : stack <| e = case e of
245245
VCon val -> do
246246
caser <- asks ckCaserBuiltin
247247
case unCaserBuiltin caser val $ Vector.fromList cs of
248-
Left err ->
248+
HeadError err ->
249249
throwErrorWithCause (OperationalError $ CkCaseBuiltinError err) $ ckValueToTerm e
250-
Right (HeadOnly fX) -> stack |> fX
251-
Right (HeadSpine f xs) -> transferConstantSpine xs stack |> f
250+
HeadOnly fX -> stack |> fX
251+
HeadSpine f xs -> transferConstantSpine xs stack |> f
252252
_ -> throwErrorWithCause (StructuralError NonConstrScrutinizedMachineError) $ ckValueToTerm e
253253

254254
transferConstantSpine :: Spine (Some (ValueOf uni)) -> Context uni fun -> Context uni fun

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

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -340,11 +340,13 @@ mkFreshTermLet aT a = do
340340
pure (var mempty genName, termLet mempty (Def (VarDecl mempty genName aT) a))
341341

342342
-- | 'apply' the head of the application to the arguments iteratively.
343-
headSpineToTerm :: TermLike term tyname name uni fun => ann -> MonoHeadSpine (term ann) -> term ann
344-
headSpineToTerm _ (HeadOnly t) = t
345-
headSpineToTerm ann (HeadSpine t ts) = foldl (apply ann) t ts
343+
headSpineToTerm :: TermLike term tyname name uni fun => ann -> MonoHeadSpine err (term ann) -> Either err (term ann)
344+
headSpineToTerm _ (HeadError e) = Left e
345+
headSpineToTerm _ (HeadOnly t) = Right t
346+
headSpineToTerm ann (HeadSpine t ts) = Right $ foldl (apply ann) t ts
346347

347348
-- | @headSpineToTerm@ but without annotation.
348-
headSpineToTermNoAnn :: TermLike term tyname name uni fun => MonoHeadSpine (term ()) -> term ()
349-
headSpineToTermNoAnn (HeadOnly t) = t
350-
headSpineToTermNoAnn (HeadSpine t ts) = foldl (apply ()) t ts
349+
headSpineToTermNoAnn :: TermLike term tyname name uni fun => MonoHeadSpine err (term ()) -> Either err (term ())
350+
headSpineToTermNoAnn (HeadError e) = Left e
351+
headSpineToTermNoAnn (HeadOnly t) = Right t
352+
headSpineToTermNoAnn (HeadSpine t ts) = Right $ foldl (apply ()) t ts

‎plutus-core/plutus-ir/src/PlutusIR/Transform/CaseReduce.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ processTerm = \case
3939
-- structural error into an operational one, which would be unfortunate, so instead we decided
4040
-- not to fully optimize such scripts, since they aren't valid anyway.
4141
Case ann _ (Constr _ _ i args) cs | Just c <- cs ^? wix i -> mkIterApp c ((ann,) <$> args)
42-
Case ann _ (Constant _ con) cs | Right fXs <- caseBuiltin con (fromList cs) ->
43-
headSpineToTerm ann (second (Constant ann) fXs)
42+
Case ann _ (Constant _ con) cs
43+
| Right t <- headSpineToTerm ann (second (Constant ann) (caseBuiltin con (fromList cs))) -> t
44+
4445
t -> t

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -902,9 +902,9 @@ enterComputeCek = computeCek
902902
Nothing -> throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e
903903
-- Proceed with caser when expression given is not Constr.
904904
VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of
905-
Left err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e
906-
Right (HeadOnly fX) -> computeCek ctx env fX
907-
Right (HeadSpine f xs) -> computeCek (FrameAwaitFunConN xs ctx) env f
905+
HeadError err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e
906+
HeadOnly fX -> computeCek ctx env fX
907+
HeadSpine f xs -> computeCek (FrameAwaitFunConN xs ctx) env f
908908
_ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e
909909

910910
-- | @force@ a term and proceed.

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -215,9 +215,9 @@ returnCek (FrameCases ann env cs ctx) e = case e of
215215
MultiStack rest -> computeCek (FrameAwaitFunValueN ann rest ctx) env t
216216
Nothing -> throwErrorDischarged (StructuralError $ MissingCaseBranchMachineError i) e
217217
VCon val -> case unCaserBuiltin ?cekCaserBuiltin val cs of
218-
Left err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e
219-
Right (HeadOnly fX) -> pure $ Computing ctx env fX
220-
Right (HeadSpine f xs) -> pure $ Computing (FrameAwaitFunConN ann xs ctx) env f
218+
HeadError err -> throwErrorDischarged (OperationalError $ CekCaseBuiltinError err) e
219+
HeadOnly fX -> pure $ Computing ctx env fX
220+
HeadSpine f xs -> pure $ Computing (FrameAwaitFunConN ann xs ctx) env f
221221
_ -> throwErrorDischarged (StructuralError NonConstrScrutinizedMachineError) e
222222

223223
-- | @force@ a term and proceed.

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

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,6 @@ processTerm = \case
3030
-- not to fully optimize such scripts, since they aren't valid anyway.
3131
Case ann (Constr _ i args) cs | Just c <- (V.!?) cs (fromIntegral i) ->
3232
mkIterApp c ((ann,) <$> args)
33-
Case ann (Constant _ con) cs | Right fXs <- caseBuiltin con cs ->
34-
headSpineToTerm ann (second (Constant ann) fXs)
35-
33+
Case ann (Constant _ con) cs
34+
| Right t <- headSpineToTerm ann (second (Constant ann) (caseBuiltin con cs)) -> t
3635
t -> t

0 commit comments

Comments
 (0)