Improve performance of dealing with compact form of Value

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs

@@ -115,7 +115,6 @@ import Cardano.Ledger.TxIn (TxIn (..))
 import Cardano.Ledger.Val
   ( DecodeNonNegative,
     Val (..),
-    adaOnly,
     decodeMint,
     decodeNonNegative,
     encodeMint,
@@ -192,7 +191,7 @@ getAdaOnly ::
   Core.Value era ->
   Maybe (CompactForm Coin)
 getAdaOnly _ v = do
-  guard $ adaOnly v
+  guard $ isAdaOnly v
   toCompact $ coin v
 
 decodeAddress28 ::
@@ -274,20 +273,13 @@ viewCompactTxOut txOut = case txOut of
   TxOutCompactDH' addr val dh -> (addr, val, SJust dh)
   TxOut_AddrHash28_AdaOnly stakeRef addr28Extra adaVal
     | Just addr <- decodeAddress28 stakeRef addr28Extra ->
-      (compactAddr addr, toCompactValue adaVal, SNothing)
+      (compactAddr addr, injectCompact adaVal, SNothing)
     | otherwise -> error addressErrorMsg
   TxOut_AddrHash28_AdaOnly_DataHash32 stakeRef addr28Extra adaVal dataHash32
     | Just addr <- decodeAddress28 stakeRef addr28Extra,
       Just dh <- decodeDataHash32 dataHash32 ->
-      (compactAddr addr, toCompactValue adaVal, SJust dh)
+      (compactAddr addr, injectCompact adaVal, SJust dh)
     | otherwise -> error addressErrorMsg
-  where
-    toCompactValue :: CompactForm Coin -> CompactForm (Core.Value era)
-    toCompactValue ada =
-      fromMaybe (error "Failed to compact a `Coin` as `CompactForm (Core.Value era)`")
-        . toCompact
-        . inject
-        $ fromCompact ada
 
 viewTxOut ::
   forall era.
@@ -648,6 +640,7 @@ instance
 
 pattern TxOutCompact ::
   ( Era era,
+    Val (Core.Value era),
     HasCallStack
   ) =>
   CompactAddr (Crypto era) ->
@@ -657,10 +650,8 @@ pattern TxOutCompact addr vl <-
   (viewCompactTxOut -> (addr, vl, SNothing))
   where
     TxOutCompact cAddr cVal
-      | adaOnly value = TxOut (decompactAddr cAddr) value SNothing
+      | isAdaOnlyCompact cVal = TxOut (decompactAddr cAddr) (fromCompact cVal) SNothing
       | otherwise = TxOutCompact' cAddr cVal
-      where
-        value = fromCompact cVal
 
 pattern TxOutCompactDH ::
   forall era.
@@ -675,10 +666,8 @@ pattern TxOutCompactDH addr vl dh <-
   (viewCompactTxOut -> (addr, vl, SJust dh))
   where
     TxOutCompactDH cAddr cVal dh
-      | adaOnly value = TxOut (decompactAddr cAddr) value (SJust dh)
+      | isAdaOnlyCompact cVal = TxOut (decompactAddr cAddr) (fromCompact cVal) (SJust dh)
       | otherwise = TxOutCompactDH' cAddr cVal dh
-      where
-        value = fromCompact cVal
 
 {-# COMPLETE TxOutCompact, TxOutCompactDH #-}
 

eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs

@@ -58,7 +58,7 @@ import Cardano.Ledger.Shelley.UTxO (UTxO (..), balance)
 import Cardano.Ledger.ShelleyMA.AuxiliaryData as Mary (pattern AuxiliaryData)
 import Cardano.Ledger.ShelleyMA.Timelocks (Timelock (..))
 import Cardano.Ledger.TxIn (TxIn)
-import Cardano.Ledger.Val (Val (coin), adaOnly, (<+>), (<×>))
+import Cardano.Ledger.Val (Val (coin, isAdaOnly, (<+>), (<×>)))
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.Monad (replicateM)
 import qualified Data.ByteString.Char8 as BS
@@ -112,7 +112,7 @@ import Test.QuickCheck hiding ((><))
 
 -- | We are choosing new TxOut to pay fees, We want only Key locked addresss with Ada only values.
 vKeyLockedAdaOnly :: Mock c => Core.TxOut (AlonzoEra c) -> Bool
-vKeyLockedAdaOnly txout = vKeyLocked txout && adaOnly (getField @"value" txout)
+vKeyLockedAdaOnly txout = vKeyLocked txout && isAdaOnly (getField @"value" txout)
 
 phase2scripts3Arg :: forall c. Mock c => [TwoPhase3ArgInfo (AlonzoEra c)]
 phase2scripts3Arg =

eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs

@@ -129,7 +129,6 @@ import Cardano.Ledger.TxIn (TxIn (..))
 import Cardano.Ledger.Val
   ( DecodeNonNegative,
     Val (..),
-    adaOnly,
     decodeMint,
     decodeNonNegative,
     encodeMint,
@@ -335,10 +334,8 @@ pattern TxOutCompact addr vl <-
   (viewCompactTxOut -> (addr, vl, NoDatum, SNothing))
   where
     TxOutCompact cAddr cVal
-      | adaOnly value = TxOut (decompactAddr cAddr) value NoDatum SNothing
+      | isAdaOnlyCompact cVal = TxOut (decompactAddr cAddr) (fromCompact cVal) NoDatum SNothing
       | otherwise = TxOutCompact' cAddr cVal
-      where
-        value = fromCompact cVal
 
 pattern TxOutCompactDH ::
   ( Era era,
@@ -352,10 +349,8 @@ pattern TxOutCompactDH addr vl dh <-
   (viewCompactTxOut -> (addr, vl, DatumHash dh, SNothing))
   where
     TxOutCompactDH cAddr cVal dh
-      | adaOnly value = TxOut (decompactAddr cAddr) value (DatumHash dh) SNothing
+      | isAdaOnlyCompact cVal = TxOut (decompactAddr cAddr) (fromCompact cVal) (DatumHash dh) SNothing
       | otherwise = TxOutCompactDH' cAddr cVal dh
-      where
-        value = fromCompact cVal
 
 {-# COMPLETE TxOutCompact, TxOutCompactDH #-}
 

eras/shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -39,7 +40,7 @@ import Cardano.Binary
     toCBOR,
   )
 import qualified Cardano.Crypto.Hash.Class as Hash
-import Cardano.Ledger.Coin (Coin (..), integerToWord64)
+import Cardano.Ledger.Coin (Coin (..), CompactForm (..), integerToWord64)
 import Cardano.Ledger.Compactible (Compactible (..))
 import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.Serialization (decodeMap, encodeMap)
@@ -182,6 +183,14 @@ instance CC.Crypto crypto => Val (Value crypto) where
             + repOverhead
         )
 
+  isAdaOnly (Value _ v) = Map.null v
+
+  isAdaOnlyCompact = \case
+    CompactValue (CompactValueAdaOnly _) -> True
+    CompactValue (CompactValueMultiAsset {}) -> False
+
+  injectCompact = CompactValue . CompactValueAdaOnly
+
 -- space (in Word64s) taken up by the ada amount
 adaWords :: Int
 adaWords = 1
@@ -351,9 +360,9 @@ instance CC.Crypto crypto => FromCBOR (CompactValue crypto) where
       Just x -> pure x
 
 data CompactValue crypto
-  = CompactValueAdaOnly {-# UNPACK #-} !Word64
+  = CompactValueAdaOnly {-# UNPACK #-} !(CompactForm Coin)
   | CompactValueMultiAsset
-      {-# UNPACK #-} !Word64 -- ada
+      {-# UNPACK #-} !(CompactForm Coin) -- ada
       {-# UNPACK #-} !Word32 -- number of ma's
       {-# UNPACK #-} !ShortByteString -- rep
   deriving (Show, Typeable)
@@ -483,7 +492,7 @@ to ::
   Maybe (CompactValue crypto)
 to (Value ada ma)
   | Map.null ma =
-    CompactValueAdaOnly <$> integerToWord64 ada
+    CompactValueAdaOnly . CompactCoin <$> integerToWord64 ada
 to v = do
   c <- integerToWord64 ada
   -- Here we convert the (pid, assetName, quantity) triples into
@@ -494,7 +503,7 @@ to v = do
   preparedTriples <-
     zip [0 ..] . sortOn (\(_, x, _) -> x) <$> traverse prepare triples
   pure $
-    CompactValueMultiAsset c (fromIntegral numTriples) $
+    CompactValueMultiAsset (CompactCoin c) (fromIntegral numTriples) $
       runST $ do
         byteArray <- BA.newByteArray repSize
         forM_ preparedTriples $ \(i, (pidoff, anoff, q)) ->
@@ -618,8 +627,8 @@ representationSize xs = abcRegionSize + pidBlockSize + anameBlockSize
       Semigroup.getSum $ foldMap' (Semigroup.Sum . BS.length . assetName) assetNames
 
 from :: forall crypto. (CC.Crypto crypto) => CompactValue crypto -> Value crypto
-from (CompactValueAdaOnly c) = Value (fromIntegral c) mempty
-from (CompactValueMultiAsset c numAssets rep) =
+from (CompactValueAdaOnly (CompactCoin c)) = Value (fromIntegral c) mempty
+from (CompactValueMultiAsset (CompactCoin c) numAssets rep) =
   valueFromList (fromIntegral c) triples
   where
     n = fromIntegral numAssets

libs/cardano-ledger-core/src/Cardano/Ledger/Coin.hs

@@ -83,6 +83,13 @@ instance Compactible Coin where
   toCompact (Coin c) = CompactCoin <$> integerToWord64 c
   fromCompact (CompactCoin c) = word64ToCoin c
 
+instance Compactible DeltaCoin where
+  newtype CompactForm DeltaCoin = CompactDeltaCoin Word64
+    deriving (Eq, Show, NoThunks, NFData, Typeable, HeapWords, Prim)
+
+  toCompact (DeltaCoin dc) = CompactDeltaCoin <$> integerToWord64 dc
+  fromCompact (CompactDeltaCoin cdc) = DeltaCoin (unCoin (word64ToCoin cdc))
+
 -- It's odd for this to live here. Where should it go?
 integerToWord64 :: Integer -> Maybe Word64
 integerToWord64 c
@@ -96,3 +103,9 @@ instance ToCBOR (CompactForm Coin) where
 
 instance FromCBOR (CompactForm Coin) where
   fromCBOR = CompactCoin <$> fromCBOR
+
+instance ToCBOR (CompactForm DeltaCoin) where
+  toCBOR (CompactDeltaCoin c) = toCBOR c
+
+instance FromCBOR (CompactForm DeltaCoin) where
+  fromCBOR = CompactDeltaCoin <$> fromCBOR

libs/cardano-ledger-core/src/Cardano/Ledger/Val.hs

@@ -21,8 +21,9 @@ module Cardano.Ledger.Val
 where
 
 import Cardano.Binary (Decoder, Encoding, decodeWord64, toCBOR)
-import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
+import Cardano.Ledger.Coin (Coin (..), CompactForm (..), DeltaCoin (..))
 import Cardano.Ledger.Compactible (Compactible (..))
+import Data.Coerce
 import Data.Foldable (foldl')
 import Data.Group (Abelian)
 
@@ -66,6 +67,12 @@ class
   -- | If a quantity is stored in only one of 'v1' or 'v2', we use 0 for the missing quantity.
   pointwise :: (Integer -> Integer -> Bool) -> t -> t -> Bool
 
+  isAdaOnly :: t -> Bool
+
+  isAdaOnlyCompact :: CompactForm t -> Bool
+
+  injectCompact :: CompactForm Coin -> CompactForm t
+
 -- =============================================================
 -- Synonyms with types fixed at (Val t). Makes calls easier
 -- to read, and gives better error messages, when a mistake is made
@@ -88,6 +95,7 @@ invert x = (-1 :: Integer) <×> x
 -- returns a Value containing only the coin (ada) tokens from the input Value
 adaOnly :: Val v => v -> Bool
 adaOnly v = (inject . coin) v == v
+{-# DEPRECATED adaOnly "In favor of `isAdaOnly`" #-}
 
 instance Val Coin where
   n <×> (Coin x) = Coin $ fromIntegral n * x
@@ -96,8 +104,20 @@ instance Val Coin where
   size _ = 1
   modifyCoin f v = f v
   pointwise p (Coin x) (Coin y) = p x y
-
-deriving via Coin instance Val DeltaCoin
+  isAdaOnly _ = True
+  isAdaOnlyCompact _ = True
+  injectCompact = id
+
+instance Val DeltaCoin where
+  n <×> (DeltaCoin x) = DeltaCoin $ fromIntegral n * x
+  coin = coerce
+  inject = coerce
+  size _ = 1
+  modifyCoin f v = coerce f v
+  pointwise p (DeltaCoin x) (DeltaCoin y) = p x y
+  isAdaOnly _ = True
+  isAdaOnlyCompact _ = True
+  injectCompact (CompactCoin cc) = CompactDeltaCoin cc
 
 -- =============================================================
 

libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/TxOut.hs

@@ -52,7 +52,7 @@ benchTxOut =
       txOutAddrAdaOnlyDataHash :: Int -> TxOut A
       txOutAddrAdaOnlyDataHash n = TxOut (addr n) ada (SJust dataHash32)
       count :: Int
-      count = 10000
+      count = 1000
    in bgroup
         "TxOut"
         [ bgroup
@@ -132,7 +132,7 @@ serializeTxOutAlonzoBench count name mkTxOuts =
     name
     [ env (pure (mkTxOuts <$> [1 .. count])) $ bench "ToCBOR" . nf (map serialize),
       env (pure (serialize . mkTxOuts <$> [1 .. count])) $
-      bench "FromCBOR" . nf (map (either (error . show) (id @(TxOut A)) . decodeFull))
+        bench "FromCBOR" . nf (map (either (error . show) (id @(TxOut A)) . decodeFull))
     ]
 
 payAddr28 :: Int -> KeyHash 'Payment StandardCrypto

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Model/BaseTypes.hs

@@ -2,13 +2,15 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Test.Cardano.Ledger.Model.BaseTypes
   ( ModelValue (..),
@@ -27,8 +29,10 @@ module Test.Cardano.Ledger.Model.BaseTypes
   )
 where
 
+import Cardano.Binary (ToCBOR (..))
 import Cardano.Ledger.BaseTypes (Globals)
-import Cardano.Ledger.Coin (Coin)
+import Cardano.Ledger.Coin (Coin (..), CompactForm (..))
+import Cardano.Ledger.Compactible
 import Cardano.Ledger.Keys (KeyRole (..))
 import Cardano.Ledger.Mary.Value (AssetName)
 import qualified Cardano.Ledger.Val as Val
@@ -38,12 +42,13 @@ import Control.Lens
     iso,
     _1,
   )
+import Data.Coerce
 import Data.Group (Abelian, Group)
 import Data.Group.GrpMap (GrpMap (..))
 import qualified Data.Map.Strict as Map
 import Data.Monoid (Sum (..))
 import Data.Proxy (Proxy (..))
-import Data.Typeable ((:~:) (Refl))
+import Data.Typeable (Typeable, (:~:) (Refl))
 import qualified GHC.Exts as GHC (IsString)
 import GHC.Generics (Generic)
 import GHC.Natural (Natural)
@@ -121,7 +126,7 @@ deriving instance Eq (ModelValueVars era valF)
 deriving instance Ord (ModelValueVars era valF)
 
 liftModelValueVars :: ModelValueVars era 'ExpectAdaOnly -> ModelValueVars era k
-liftModelValueVars = \case {}
+liftModelValueVars = \case
 
 filterModelValueVars ::
   forall a b c d.
@@ -134,9 +139,27 @@ filterModelValueVars (ModelValue_MA ys) = do
   ModelValue_MA <$> _1 filterModelScript ys
 
 newtype ModelValue k era = ModelValue {unModelValue :: ModelValueF (ModelValueVars era k)}
-  deriving (Eq, Ord, Generic, NFData, Semigroup, Monoid, Group, Abelian, Val.Val)
+  deriving (Eq, Ord, Generic, NFData, Semigroup, Monoid, Group, Abelian)
   deriving (Show) via Quiet (ModelValue k era)
 
+instance Val.Val (ModelValue k era) where
+  coin = coerce (Val.coin :: ModelValueF (ModelValueVars era k) -> Coin)
+  modifyCoin f =
+    coerce
+      (Val.modifyCoin f :: ModelValueF (ModelValueVars era k) -> ModelValueF (ModelValueVars era k))
+  (<×>) i =
+    coerce
+      ((i Val.<×>) :: ModelValueF (ModelValueVars era k) -> ModelValueF (ModelValueVars era k))
+  inject = coerce (Val.inject :: Coin -> ModelValueF (ModelValueVars era k))
+  size = coerce (Val.size :: ModelValueF (ModelValueVars era k) -> Integer)
+  pointwise f =
+    coerce
+      (Val.pointwise f :: ModelValueF (ModelValueVars era k) -> ModelValueF (ModelValueVars era k) -> Bool)
+  isAdaOnly = coerce (Val.isAdaOnly :: ModelValueF (ModelValueVars era k) -> Bool)
+  isAdaOnlyCompact (ModelValueCompact v) = Val.isAdaOnly v
+  injectCompact (CompactCoin w64) =
+    ModelValueCompact (Val.inject (Coin (toInteger w64)))
+
 liftModelValue :: ModelValue 'ExpectAdaOnly era -> ModelValue k era
 liftModelValue = ModelValue . mapModelValueF liftModelValueVars . unModelValue
 
@@ -150,7 +173,8 @@ filterModelValue = \case
   ModelValue x -> ModelValue <$> traverseModelValueF filterModelValueVars x
 
 instance KnownValueFeature v => RequiredFeatures (ModelValue v) where
-  filterFeatures tag (ModelValue val) = ModelValue <$> traverseModelValueF (hasKnownRequiredFeatures tag filterModelValueVars) val
+  filterFeatures tag (ModelValue val) =
+    ModelValue <$> traverseModelValueF (hasKnownRequiredFeatures tag filterModelValueVars) val
 
 -- | The spec stipulates that certain values particularly, the sigma parameter
 -- used in rewards calculations) to be within [0,1], but which never-the-less
@@ -163,3 +187,14 @@ boundPositiveRational :: Rational -> Maybe PositiveRational
 boundPositiveRational x
   | x > 0 = Just $ PositiveRational x
   | otherwise = Nothing
+
+-- No compacting, just an identitity with ModelValueF, since Compactible instance is needed
+instance (Typeable k, Typeable era) => Compactible (ModelValue k era) where
+  newtype CompactForm (ModelValue k era) = ModelValueCompact (ModelValue k era)
+    deriving (Show, Eq)
+
+  toCompact = Just . ModelValueCompact
+  fromCompact (ModelValueCompact mvc) = mvc
+
+instance (Typeable k, Typeable era) => ToCBOR (CompactForm (ModelValue k era)) where
+  toCBOR = error "Unimplemented. Instance is only needed to satisfy Compactible constraints"