Fuse unionWith and checkBinRel in PlutusLedgerApi.V1.Data.Value

plutus-ledger-api/changelog.d/20260527_131134_yuriy.lazaryev_issue_2243_fused_unionwith.md

@@ -0,0 +1,3 @@
+### Changed
+
+- Optimised `unionWith` in `PlutusLedgerApi.V1.Data.Value`: same semantics and signature, but the merge now runs in two outer passes instead of three. A constant-factor speedup, not an algorithmic one.

plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs

@@ -402,31 +402,23 @@ assetClassValueOf :: Value -> AssetClass -> Integer
 assetClassValueOf v (AssetClass (c, t)) = valueOf v c t
 {-# INLINEABLE assetClassValueOf #-}
 
--- | Combine two 'Value' maps, assumes the well-definedness of the two maps.
-unionVal :: Value -> Value -> Map CurrencySymbol (Map TokenName (These Integer Integer))
-unionVal (Value l) (Value r) =
-  let
-    combined = Map.union l r
-    unThese k = case k of
-      This a -> Map.map This a
-      That b -> Map.map That b
-      These a b -> Map.union a b
-   in
-    Map.map unThese combined
-{-# INLINEABLE unionVal #-}
-
 {-| Combine two 'Value' maps with the argument function.
 Assumes the well-definedness of the two maps. -}
 unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value
-unionWith f ls rs =
-  let
-    combined = unionVal ls rs
-    unThese k' = case k' of
+unionWith f (Value mapL) (Value mapR) =
+  Value (Map.map fuseInners (Map.union mapL mapR))
+  where
+    fuseInners :: These (Map TokenName Integer) (Map TokenName Integer) -> Map TokenName Integer
+    fuseInners = \case
+      This innerL -> Map.map (\v -> f v 0) innerL
+      That innerR -> Map.map (\v -> f 0 v) innerR
+      These innerL innerR -> Map.map collapseInner (Map.union innerL innerR)
+
+    collapseInner :: These Integer Integer -> Integer
+    collapseInner = \case
       This a -> f a 0
       That b -> f 0 b
       These a b -> f a b
-   in
-    Value (Map.map (Map.map unThese) combined)
 {-# INLINEABLE unionWith #-}
 
 {-| Convert a 'Value' to a simple list, keeping only the non-zero amounts.
@@ -452,28 +444,26 @@ isZero :: Value -> Bool
 isZero (Value xs) = Map.all (Map.all (\i -> 0 == i)) xs
 {-# INLINEABLE isZero #-}
 
-{-| Checks whether a predicate holds for all the values in a 'Value'
-union. Assumes the well-definedness of the two underlying 'Map's. -}
-checkPred :: (These Integer Integer -> Bool) -> Value -> Value -> Bool
-checkPred f l r =
-  let
-    inner :: Map TokenName (These Integer Integer) -> Bool
-    inner = Map.all f
-   in
-    Map.all inner (unionVal l r)
-{-# INLINEABLE checkPred #-}
-
 {-| Check whether a binary relation holds for value pairs of two 'Value' maps,
-  supplying 0 where a key is only present in one of them. -}
+  supplying 0 where a key is only present in one of them.
+
+Walks the outer 'Map.union' with 'Map.all', short-circuiting on the first pair
+that fails @f@. -}
 checkBinRel :: (Integer -> Integer -> Bool) -> Value -> Value -> Bool
-checkBinRel f l r =
-  let
-    unThese k' = case k' of
+checkBinRel f (Value mapL) (Value mapR) =
+  Map.all checkInners (Map.union mapL mapR)
+  where
+    checkInners :: These (Map TokenName Integer) (Map TokenName Integer) -> Bool
+    checkInners = \case
+      This innerL -> Map.all (\v -> f v 0) innerL
+      That innerR -> Map.all (\v -> f 0 v) innerR
+      These innerL innerR -> Map.all collapseInner (Map.union innerL innerR)
+
+    collapseInner :: These Integer Integer -> Bool
+    collapseInner = \case
       This a -> f a 0
       That b -> f 0 b
       These a b -> f a b
-   in
-    checkPred unThese l r
 {-# INLINEABLE checkBinRel #-}
 
 {-| Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation

plutus-tx-plugin/test-ledger-api/Spec.hs

@@ -28,6 +28,7 @@ tests =
     , Spec.Data.ScriptContext.tests
     , Spec.Data.Value.test_EqValue
     , Spec.Data.Value.test_valueOf
+    , Spec.Data.Value.test_unionWith
     , Spec.Data.MintValue.V3.tests
     , Spec.Envelope.tests
     , Spec.ReturnUnit.V1.tests

plutus-tx-plugin/test-ledger-api/Spec/Data/Budget/9.12/geq1.golden.eval

@@ -1,6 +1,6 @@
-CPU:               333_462_100
-Memory:                963_345
-AST Size:                  625
-Flat Size:                 942
+CPU:               331_010_215
+Memory:                952_905
+AST Size:                  624
+Flat Size:                 938
 
 (con bool True)

plutus-tx-plugin/test-ledger-api/Spec/Data/Budget/9.12/geq2.golden.eval

@@ -1,6 +1,6 @@
-CPU:               350_706_346
-Memory:              1_027_715
-AST Size:                  625
-Flat Size:                 993
+CPU:               340_731_162
+Memory:                978_731
+AST Size:                  624
+Flat Size:                 989
 
 (con bool False)

plutus-tx-plugin/test-ledger-api/Spec/Data/Budget/9.12/geq3.golden.eval

@@ -1,6 +1,6 @@
-CPU:               363_986_374
-Memory:              1_070_929
-AST Size:                  625
-Flat Size:                 993
+CPU:               351_760_500
+Memory:              1_010_925
+AST Size:                  624
+Flat Size:                 989
 
 (con bool True)

plutus-tx-plugin/test-ledger-api/Spec/Data/Budget/9.12/geq4.golden.eval

@@ -1,6 +1,6 @@
-CPU:               327_778_382
-Memory:                924_936
-AST Size:                  625
-Flat Size:                 949
+CPU:               177_245_560
+Memory:                523_041
+AST Size:                  624
+Flat Size:                 945
 
 (con bool False)

plutus-tx-plugin/test-ledger-api/Spec/Data/Budget/9.12/geq5.golden.eval

@@ -1,6 +1,6 @@
-CPU:               345_381_135
-Memory:                995_200
-AST Size:                  625
-Flat Size:                 949
+CPU:               342_977_250
+Memory:                985_060
+AST Size:                  624
+Flat Size:                 945
 
 (con bool True)