From f0b54a588d724130808fbf103fb429fde95de191 Mon Sep 17 00:00:00 2001 From: Nikolaos Bezirgiannis Date: Wed, 22 May 2024 15:14:06 +0200 Subject: [PATCH] Renamed to ASTSize, changed to Maybe CoverageIndex --- plutus-benchmark/marlowe/test/Spec.hs | 4 +- .../src/PlutusBenchmark/NoFib/Knights/Sort.hs | 16 +- .../test/9.6/knights10-4x4.budget.golden | 2 +- .../nofib/test/9.6/knights10-4x4.pir.golden | 1067 +++++++++-------- .../nofib/test/9.6/knights10-4x4.size.golden | 2 +- plutus-benchmark/nofib/test/Spec.hs | 8 +- plutus-benchmark/script-contexts/test/Spec.hs | 4 +- .../20240522_152938_bezirg_astsize.md | 3 + plutus-core/executables/pir/Main.hs | 4 +- .../src/PlutusCore/Executable/Common.hs | 2 +- plutus-core/plutus-core.cabal | 6 +- plutus-core/plutus-core/src/PlutusCore.hs | 11 +- .../plutus-core/src/PlutusCore/ASTSize.hs | 66 + .../plutus-core/src/PlutusCore/Name/Unique.hs | 7 +- .../plutus-core/src/PlutusCore/Size.hs | 76 -- plutus-core/plutus-ir/src/PlutusIR/ASTSize.hs | 25 + .../src/PlutusIR/Analysis/RetainedSize.hs | 38 +- .../plutus-ir/src/PlutusIR/Analysis/Size.hs | 25 - .../Transform/Inline/CallSiteInline.hs | 6 +- .../src/PlutusIR/Transform/Inline/Inline.hs | 4 +- plutus-core/testlib/PlutusCore/Test.hs | 8 +- .../src/UntypedPlutusCore.hs | 2 +- .../src/UntypedPlutusCore/ASTSize.hs | 26 + .../src/UntypedPlutusCore/Size.hs | 29 - .../src/UntypedPlutusCore/Transform/Cse.hs | 27 +- .../src/UntypedPlutusCore/Transform/Inline.hs | 4 +- .../Common/SerialisedScript.hs | 8 +- plutus-tx-plugin/src/PlutusTx/Plugin.hs | 2 +- plutus-tx-plugin/test/Plugin/Coverage/Spec.hs | 4 +- plutus-tx-plugin/test/size/Main.hs | 58 +- .../20240522_153034_bezirg_astsize.md | 4 + plutus-tx/src/PlutusTx/Code.hs | 15 +- plutus-tx/src/PlutusTx/Lift.hs | 2 +- plutus-tx/src/PlutusTx/TH.hs | 2 +- plutus-tx/testlib/PlutusTx/Test.hs | 2 +- 35 files changed, 785 insertions(+), 784 deletions(-) create mode 100644 plutus-core/changelog.d/20240522_152938_bezirg_astsize.md create mode 100644 plutus-core/plutus-core/src/PlutusCore/ASTSize.hs delete mode 100644 plutus-core/plutus-core/src/PlutusCore/Size.hs create mode 100644 plutus-core/plutus-ir/src/PlutusIR/ASTSize.hs delete mode 100644 plutus-core/plutus-ir/src/PlutusIR/Analysis/Size.hs create mode 100644 plutus-core/untyped-plutus-core/src/UntypedPlutusCore/ASTSize.hs delete mode 100644 plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Size.hs create mode 100644 plutus-tx/changelog.d/20240522_153034_bezirg_astsize.md diff --git a/plutus-benchmark/marlowe/test/Spec.hs b/plutus-benchmark/marlowe/test/Spec.hs index e3591c2f4b1..49d2c4d534f 100644 --- a/plutus-benchmark/marlowe/test/Spec.hs +++ b/plutus-benchmark/marlowe/test/Spec.hs @@ -46,13 +46,13 @@ main = do allTests = testGroup "plutus-benchmark Marlowe tests" [ runTestGhc ["semantics"] $ - goldenSize "semantics" marloweValidator + goldenASTSize "semantics" marloweValidator : [ goldenUEvalBudget name [value] | bench <- semanticsMBench , let (name, value) = mkBudgetTest marloweValidator bench ] , runTestGhc ["role-payout"] $ - goldenSize "role-payout" rolePayoutValidator + goldenASTSize "role-payout" rolePayoutValidator : [ goldenUEvalBudget name [value] | bench <- rolePayoutMBench , let (name, value) = mkBudgetTest rolePayoutValidator bench diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Sort.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Sort.hs index 80b8b7b3d58..42a9bc7fe3d 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Sort.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights/Sort.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +{-# LANGUAGE NoImplicitPrelude #-} module PlutusBenchmark.NoFib.Knights.Sort ( insertSort, @@ -6,7 +7,8 @@ module PlutusBenchmark.NoFib.Knights.Sort quickSort ) where -import PlutusTx.Prelude qualified as Tx +import PlutusTx.Builtins as Tx +import PlutusTx.Prelude as Tx {-# INLINABLE insertSort #-} insertSort :: (Tx.Ord a) => [a] -> [a] @@ -25,8 +27,8 @@ mergeSort xs = if (n <=1 ) then xs else (mergeList - ( mergeSort (take (n `div` 2) xs)) - ( mergeSort (drop (n `div` 2) xs))) + ( mergeSort (take (n `divideInteger` 2) xs)) + ( mergeSort (drop (n `divideInteger` 2) xs))) where n = length xs @@ -99,9 +101,9 @@ randomIntegers s1 s2 = if 1 <= s2 && s2 <= 2147483398 then rands s1 s2 else - error "randomIntegers: Bad second seed." + error () -- "randomIntegers: Bad second seed." else - error "randomIntegers: Bad first seed." + error () -- "randomIntegers: Bad first seed." {-# INLINABLE rands #-} rands :: Integer -> Integer -> [Integer] @@ -110,11 +112,11 @@ rands s1 s2 else z : rands s1'' s2'' where - k = s1 `div` 53668 + k = s1 `divideInteger` 53668 s1' = 40014 * (s1 - k * 53668) - k * 12211 s1'' = if s1' < 0 then s1' + 2147483563 else s1' - k' = s2 `div` 52774 + k' = s2 `divideInteger` 52774 s2' = 40692 * (s2 - k' * 52774) - k' * 3791 s2'' = if s2' < 0 then s2' + 2147483399 else s2' diff --git a/plutus-benchmark/nofib/test/9.6/knights10-4x4.budget.golden b/plutus-benchmark/nofib/test/9.6/knights10-4x4.budget.golden index 977d0679283..2e98d546c0d 100644 --- a/plutus-benchmark/nofib/test/9.6/knights10-4x4.budget.golden +++ b/plutus-benchmark/nofib/test/9.6/knights10-4x4.budget.golden @@ -1,2 +1,2 @@ ({cpu: 1474894000 -| mem: 7526812}) \ No newline at end of file +| mem: 7526812}) diff --git a/plutus-benchmark/nofib/test/9.6/knights10-4x4.pir.golden b/plutus-benchmark/nofib/test/9.6/knights10-4x4.pir.golden index b8bdffdd19e..e12d9582c81 100644 --- a/plutus-benchmark/nofib/test/9.6/knights10-4x4.pir.golden +++ b/plutus-benchmark/nofib/test/9.6/knights10-4x4.pir.golden @@ -27,27 +27,13 @@ {all dead. dead} in let - data Bool | Bool_match where - True : Bool - False : Bool - data (Maybe :: * -> *) a | Maybe_match where - Just : a -> Maybe a - Nothing : Maybe a - data (Tuple2 :: * -> * -> *) a b | Tuple2_match where - Tuple2 : a -> b -> Tuple2 a b - data ChessSet | ChessSet_match where - Board : - integer -> - integer -> - Maybe (Tuple2 integer integer) -> - List (Tuple2 integer integer) -> - ChessSet - !`$fEqChessSet_$c==` : ChessSet -> ChessSet -> Bool - = \(ds : ChessSet) (ds : ChessSet) -> True data Ordering | Ordering_match where EQ : Ordering GT : Ordering LT : Ordering + data Bool | Bool_match where + True : Bool + False : Bool data (Ord :: * -> *) a | Ord_match where CConsOrd : (\a -> a -> a -> Bool) a -> @@ -59,15 +45,27 @@ (a -> a -> a) -> (a -> a -> a) -> Ord a + data (Maybe :: * -> *) a | Maybe_match where + Just : a -> Maybe a + Nothing : Maybe a + data (Tuple2 :: * -> * -> *) a b | Tuple2_match where + Tuple2 : a -> b -> Tuple2 a b + data ChessSet | ChessSet_match where + Board : + integer -> + integer -> + Maybe (Tuple2 integer integer) -> + List (Tuple2 integer integer) -> + ChessSet !v : Ord ChessSet = CConsOrd {ChessSet} - `$fEqChessSet_$c==` + (\(ds : ChessSet) (ds : ChessSet) -> True) (\(eta : ChessSet) (eta : ChessSet) -> EQ) (\(x : ChessSet) (y : ChessSet) -> False) - `$fEqChessSet_$c==` + (\(ds : ChessSet) (ds : ChessSet) -> True) (\(x : ChessSet) (y : ChessSet) -> False) - `$fEqChessSet_$c==` + (\(x : ChessSet) (y : ChessSet) -> True) (\(x : ChessSet) (y : ChessSet) -> y) (\(x : ChessSet) (y : ChessSet) -> x) !equalsInteger : integer -> integer -> Bool @@ -147,6 +145,31 @@ /\dead -> addInteger 1 (go xs)) {all dead. dead} in + letrec + !ds : List (Tuple2 integer ChessSet) -> List ChessSet + = \(ds : List (Tuple2 integer ChessSet)) -> + List_match + {Tuple2 integer ChessSet} + ds + {all dead. List ChessSet} + (/\dead -> Nil {ChessSet}) + (\(ds : Tuple2 integer ChessSet) + (ds : List (Tuple2 integer ChessSet)) -> + /\dead -> + Tuple2_match + {integer} + {ChessSet} + ds + {List ChessSet} + (\(y : integer) (x : ChessSet) -> + ifThenElse + {all dead. List ChessSet} + (equalsInteger 1 y) + (/\dead -> Cons {ChessSet} x (ds ds)) + (/\dead -> ds ds) + {all dead. dead})) + {all dead. dead} + in letrec !go : List (Tuple2 integer ChessSet) -> List (Tuple2 integer ChessSet) = \(ds : List (Tuple2 integer ChessSet)) -> @@ -322,140 +345,105 @@ ds {all dead. List a} (/\dead -> Nil {a}) - (\(x : a) (xs : List a) -> - /\dead -> - let - !xs : List a - = let - !xs : List a - = quickSort + (\(x : a) -> + letrec + !ds : List a -> List a + = \(ds : List a) -> + List_match + {a} + ds + {all dead. List a} + (/\dead -> Nil {a}) + (\(ds : a) (ds : List a) -> + /\dead -> + Bool_match + (Ord_match + {a} + `$dOrd` + {a -> a -> Bool} + (\(v : (\a -> a -> a -> Bool) a) + (v : a -> a -> Ordering) + (v : a -> a -> Bool) + (v : a -> a -> Bool) + (v : a -> a -> Bool) + (v : a -> a -> Bool) + (v : a -> a -> a) + (v : a -> a -> a) -> + v) + ds + x) + {all dead. List a} + (/\dead -> Cons {a} ds (ds ds)) + (/\dead -> ds ds) + {all dead. dead}) + {all dead. dead} + in + letrec + !ds : List a -> List a + = \(ds : List a) -> + List_match + {a} + ds + {all dead. List a} + (/\dead -> Nil {a}) + (\(ds : a) (ds : List a) -> + /\dead -> + Bool_match + (Ord_match + {a} + `$dOrd` + {a -> a -> Bool} + (\(v : (\a -> a -> a -> Bool) a) + (v : a -> a -> Ordering) + (v : a -> a -> Bool) + (v : a -> a -> Bool) + (v : a -> a -> Bool) + (v : a -> a -> Bool) + (v : a -> a -> a) + (v : a -> a -> a) -> + v) + ds + x) + {all dead. List a} + (/\dead -> Cons {a} ds (ds ds)) + (/\dead -> ds ds) + {all dead. dead}) + {all dead. dead} + in + \(xs : List a) -> + /\dead -> + let + !l : List a = quickSort {a} `$dOrd` (ds xs) + !r : List a = quickSort {a} `$dOrd` (ds xs) + in + letrec + !go : List a -> List a + = \(ds : List a) -> + List_match {a} - `$dOrd` - ((let - a = List a - in - \(c : a -> a -> a) (n : a) -> - letrec - !go : List a -> a - = \(ds : List a) -> - List_match - {a} - ds - {all dead. a} - (/\dead -> n) - (\(y : a) (ys : List a) -> - /\dead -> - let - !ds : a = go ys - in - Bool_match - (Ord_match - {a} - `$dOrd` - {a -> a -> Bool} - (\(v : - (\a -> - a -> a -> Bool) - a) - (v : - a -> a -> Ordering) - (v : a -> a -> Bool) - (v : a -> a -> Bool) - (v : a -> a -> Bool) - (v : a -> a -> Bool) - (v : a -> a -> a) - (v : a -> a -> a) -> - v) - y - x) - {all dead. a} - (/\dead -> c y ds) - (/\dead -> ds) - {all dead. dead}) - {all dead. dead} - in - go xs) - (\(ds : a) (ds : List a) -> Cons {a} ds ds) - (Nil {a})) - in - (let - b = List a - in - \(c : a -> b -> b) (n : b) -> c x n) - (\(ds : a) (ds : List a) -> Cons {a} ds ds) - xs - in - (let - b = List a + ds + {all dead. List a} + (/\dead -> r) + (\(x : a) (xs : List a) -> + /\dead -> Cons {a} x (go xs)) + {all dead. dead} in - \(c : a -> b -> b) (n : b) -> - letrec - !go : List a -> b - = \(ds : List a) -> - List_match - {a} - ds - {all dead. b} - (/\dead -> n) - (\(y : a) (ys : List a) -> - /\dead -> c y (go ys)) - {all dead. dead} - in - let - !eta : List a - = quickSort + let + !r : List a = go (Cons {a} x (Nil {a})) + in + letrec + !go : List a -> List a + = \(ds : List a) -> + List_match {a} - `$dOrd` - ((let - a = List a - in - \(c : a -> a -> a) (n : a) -> - letrec - !go : List a -> a - = \(ds : List a) -> - List_match - {a} - ds - {all dead. a} - (/\dead -> n) - (\(y : a) (ys : List a) -> - /\dead -> - let - !ds : a = go ys - in - Bool_match - (Ord_match - {a} - `$dOrd` - {a -> a -> Bool} - (\(v : - (\a -> - a -> a -> Bool) - a) - (v : - a -> a -> Ordering) - (v : a -> a -> Bool) - (v : a -> a -> Bool) - (v : a -> a -> Bool) - (v : a -> a -> Bool) - (v : a -> a -> a) - (v : a -> a -> a) -> - v) - y - x) - {all dead. a} - (/\dead -> c y ds) - (/\dead -> ds) - {all dead. dead}) - {all dead. dead} - in - go xs) - (\(ds : a) (ds : List a) -> Cons {a} ds ds) - (Nil {a})) - in - go eta) - (\(ds : a) (ds : List a) -> Cons {a} ds ds) - xs) + ds + {all dead. List a} + (/\dead -> r) + (\(x : a) (xs : List a) -> + /\dead -> Cons {a} x (go xs)) + {all dead. dead} + in + go l) {all dead. dead} in let @@ -659,9 +647,9 @@ {Bool} (\(a' : integer) (b' : integer) -> - ifThenElse - {all dead. Bool} + Bool_match (equalsInteger a a') + {all dead. Bool} (/\dead -> equalsInteger b b') (/\dead -> False) @@ -683,37 +671,64 @@ (ipv : integer) (ipv : Maybe (Tuple2 integer integer)) (ipv : List (Tuple2 integer integer)) -> - (let - a = List Direction - in - \(c : Direction -> a -> a) -> - let - !c : Direction -> a -> a - = \(ds : Direction) (ds : a) -> - Bool_match - (canMoveTo - (move - ds - (List_match - {Tuple2 integer integer} - ipv - {all dead. Tuple2 integer integer} - (/\dead -> error {Tuple2 integer integer}) - (\(t : Tuple2 integer integer) - (ds : List (Tuple2 integer integer)) -> - /\dead -> t) - {all dead. dead})) - board) - {all dead. a} - (/\dead -> c ds ds) - (/\dead -> ds) - {all dead. dead} - in - \(n : a) -> - c UL (c UR (c DL (c DR (c LU (c LD (c RU (c RD n)))))))) - (\(ds : Direction) (ds : List Direction) -> - Cons {Direction} ds ds) - (Nil {Direction})) + letrec + !ds : List Direction -> List Direction + = \(ds : List Direction) -> + List_match + {Direction} + ds + {all dead. List Direction} + (/\dead -> Nil {Direction}) + (\(ds : Direction) (ds : List Direction) -> + /\dead -> + Bool_match + (canMoveTo + (move + ds + (List_match + {Tuple2 integer integer} + ipv + {all dead. Tuple2 integer integer} + (/\dead -> + error {Tuple2 integer integer}) + (\(t : Tuple2 integer integer) + (ds : + List (Tuple2 integer integer)) -> + /\dead -> t) + {all dead. dead})) + board) + {all dead. List Direction} + (/\dead -> Cons {Direction} ds (ds ds)) + (/\dead -> ds ds) + {all dead. dead}) + {all dead. dead} + in + ds + (Cons + {Direction} + UL + (Cons + {Direction} + UR + (Cons + {Direction} + DL + (Cons + {Direction} + DR + (Cons + {Direction} + LU + (Cons + {Direction} + LD + (Cons + {Direction} + RU + (Cons + {Direction} + RD + (Nil {Direction})))))))))) !deleteFirst : ChessSet -> ChessSet = \(ds : ChessSet) -> ChessSet_match @@ -814,6 +829,28 @@ {all dead. dead} in rev ts (Nil {Tuple2 integer integer})) + in + letrec + !ds : List ChessSet -> List (Tuple2 integer ChessSet) + = \(ds : List ChessSet) -> + List_match + {ChessSet} + ds + {all dead. List (Tuple2 integer ChessSet)} + (/\dead -> Nil {Tuple2 integer ChessSet}) + (\(ds : ChessSet) (ds : List ChessSet) -> + /\dead -> + Cons + {Tuple2 integer ChessSet} + (Tuple2 + {integer} + {ChessSet} + (go (possibleMoves (deleteFirst ds))) + ds) + (ds ds)) + {all dead. dead} + in + let !descAndNo : ChessSet -> List (Tuple2 integer ChessSet) = \(board : ChessSet) -> letrec @@ -860,39 +897,7 @@ (go xs)) {all dead. dead} in - (let - a = Tuple2 integer ChessSet - in - \(g : all b. (a -> b -> b) -> b -> b) -> - g {List a} (\(ds : a) (ds : List a) -> Cons {a} ds ds) (Nil {a})) - (/\a -> - \(c : Tuple2 integer ChessSet -> a -> a) (n : a) -> - letrec - !go : List ChessSet -> a - = \(ds : List ChessSet) -> - List_match - {ChessSet} - ds - {all dead. a} - (/\dead -> n) - (\(y : ChessSet) (ys : List ChessSet) -> - /\dead -> - let - !ds : a = go ys - in - c - (Tuple2 - {integer} - {ChessSet} - (go (possibleMoves (deleteFirst y))) - y) - ds) - {all dead. dead} - in - let - !eta : List ChessSet = go (possibleMoves board) - in - go eta) + ds (go (possibleMoves board)) in letrec !zip : all a b. List a -> List b -> List (Tuple2 a b) @@ -919,8 +924,55 @@ {all dead. dead}) {all dead. dead} in - \(depth : integer) - (boardSize : integer) -> + \(depth : integer) (boardSize : integer) -> + letrec + !ds : List integer -> List ChessSet + = \(ds : List integer) -> + List_match + {integer} + ds + {all dead. List ChessSet} + (/\dead -> Nil {ChessSet}) + (\(ds : integer) (ds : List integer) -> + letrec + !ds : List integer -> List ChessSet + = \(ds : List integer) -> + List_match + {integer} + ds + {all dead. List ChessSet} + (/\dead -> ds ds) + (\(ds : integer) -> + let + !st : Tuple2 integer integer + = Tuple2 {integer} {integer} ds ds + in + \(ds : List integer) -> + /\dead -> + Cons + {ChessSet} + (ifThenElse + {all dead. ChessSet} + (equalsInteger + 0 + (remainderInteger boardSize 2)) + (/\dead -> + Board + boardSize + 1 + (Just {Tuple2 integer integer} st) + (Cons + {Tuple2 integer integer} + st + (Nil {Tuple2 integer integer}))) + (/\dead -> error {ChessSet}) + {all dead. dead}) + (ds ds)) + {all dead. dead} + in + /\dead -> ds (interval 1 boardSize)) + {all dead. dead} + in depthSearch {Tuple2 integer ChessSet} (\(ds : Tuple2 integer ChessSet) (ds : Tuple2 integer ChessSet) -> @@ -944,123 +996,9 @@ {all dead. dead}))) depth (let - !list : - List (Tuple2 integer ChessSet) + !list : List (Tuple2 integer ChessSet) = let - !l : - List ChessSet - = (let - a = List ChessSet - in - \(c : ChessSet -> a -> a) - (n : a) -> - letrec - !go : - List integer -> a - = \(ds : List integer) -> - List_match - {integer} - ds - {all dead. a} - (/\dead -> n) - (\(y : integer) - (ys : List integer) -> - /\dead -> - let - !ds : a = go ys - in - letrec - !go : - List integer -> a - = \(ds : List integer) -> - List_match - {integer} - ds - {all dead. a} - (/\dead -> ds) - (\(y : integer) -> - let - !st : Tuple2 integer integer - = Tuple2 - {integer} - {integer} - y - y - in - \(ys : List integer) -> - /\dead -> - let - !ds : a = go ys - in - c - (ifThenElse - {all dead. ChessSet} - (equalsInteger - 0 - (remainderInteger - boardSize - 2)) - (/\dead -> - Board - boardSize - 1 - (Just - {Tuple2 - integer - integer} - st) - ((let - a - = Tuple2 - integer - integer - in - \(g : - all b. - (a -> - b -> - b) -> - b -> - b) -> - g - {List a} - (\(ds : a) - (ds : - List - a) -> - Cons - {a} - ds - ds) - (Nil {a})) - (/\a -> - \(c : - Tuple2 - integer - integer -> - a -> - a) - (n : a) -> - c st n))) - (/\dead -> - error {ChessSet}) - {all dead. dead}) - ds) - {all dead. dead} - in - let - !eta : List integer = interval 1 boardSize - in - go eta) - {all dead. dead} - in - let - !eta : List integer = interval 1 boardSize - in - go eta) - (\(ds : ChessSet) (ds : List ChessSet) -> - Cons {ChessSet} ds ds) - (Nil {ChessSet}) + !l : List ChessSet = ds (interval 1 boardSize) !numStarts : integer = go l in zip @@ -1118,48 +1056,7 @@ (ipv : Maybe (Tuple2 integer integer)) (ipv : List (Tuple2 integer integer)) -> let - !singles : List ChessSet - = (let - a = List ChessSet - in - \(c : ChessSet -> a -> a) (n : a) -> - (let - a = Tuple2 integer ChessSet - in - /\b -> - \(k : a -> b -> b) (z : b) -> - letrec - !go : List a -> b - = \(ds : List a) -> - List_match - {a} - ds - {all dead. b} - (/\dead -> z) - (\(y : a) (ys : List a) -> - /\dead -> k y (go ys)) - {all dead. dead} - in - \(eta : List a) -> go eta) - {a} - (\(ds : Tuple2 integer ChessSet) (ds : a) -> - Tuple2_match - {integer} - {ChessSet} - ds - {a} - (\(y : integer) (x : ChessSet) -> - ifThenElse - {all dead. a} - (equalsInteger 1 y) - (/\dead -> c x ds) - (/\dead -> ds) - {all dead. dead})) - n - (descAndNo y)) - (\(ds : ChessSet) (ds : List ChessSet) -> - Cons {ChessSet} ds ds) - (Nil {ChessSet}) + !singles : List ChessSet = ds (descAndNo y) ~`$j` : List ChessSet = let !l : integer = go singles @@ -1256,30 +1153,45 @@ {ChessSet} y {Bool} - (\(ipv : integer) - (ipv : ChessSet) -> - Ordering_match - (compare - {integer} - v - ipv - ipv) - {all dead. Bool} - (/\dead -> - Ordering_match - (compare - {ChessSet} - v - ipv - ipv) - {all dead. Bool} - (/\dead -> False) - (/\dead -> False) - (/\dead -> True) - {all dead. dead}) - (/\dead -> False) - (/\dead -> True) - {all dead. dead}))) + (\(ipv : integer) -> + let + ~defaultBody : Bool + = Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> + error {Bool}) + (/\dead -> False) + (/\dead -> True) + {all dead. dead} + in + \(ipv : ChessSet) -> + Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> + Ordering_match + (compare + {ChessSet} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> False) + (/\dead -> False) + (/\dead -> True) + {all dead. dead}) + (/\dead -> defaultBody) + (/\dead -> defaultBody) + {all dead. dead}))) (\(x : Tuple2 integer ChessSet) (y : Tuple2 integer ChessSet) -> Tuple2_match @@ -1294,30 +1206,45 @@ {ChessSet} y {Bool} - (\(ipv : integer) - (ipv : ChessSet) -> - Ordering_match - (compare - {integer} - v - ipv - ipv) - {all dead. Bool} - (/\dead -> - Ordering_match - (compare - {ChessSet} - v - ipv - ipv) - {all dead. Bool} - (/\dead -> True) - (/\dead -> False) - (/\dead -> True) - {all dead. dead}) - (/\dead -> False) - (/\dead -> True) - {all dead. dead}))) + (\(ipv : integer) -> + let + ~defaultBody : Bool + = Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> + error {Bool}) + (/\dead -> False) + (/\dead -> True) + {all dead. dead} + in + \(ipv : ChessSet) -> + Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> + Ordering_match + (compare + {ChessSet} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> True) + (/\dead -> False) + (/\dead -> True) + {all dead. dead}) + (/\dead -> defaultBody) + (/\dead -> defaultBody) + {all dead. dead}))) (\(x : Tuple2 integer ChessSet) (y : Tuple2 integer ChessSet) -> Tuple2_match @@ -1332,30 +1259,45 @@ {ChessSet} y {Bool} - (\(ipv : integer) - (ipv : ChessSet) -> - Ordering_match - (compare - {integer} - v - ipv - ipv) - {all dead. Bool} - (/\dead -> - Ordering_match - (compare - {ChessSet} - v - ipv - ipv) - {all dead. Bool} - (/\dead -> False) - (/\dead -> True) - (/\dead -> False) - {all dead. dead}) - (/\dead -> True) - (/\dead -> False) - {all dead. dead}))) + (\(ipv : integer) -> + let + ~defaultBody : Bool + = Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> + error {Bool}) + (/\dead -> True) + (/\dead -> False) + {all dead. dead} + in + \(ipv : ChessSet) -> + Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> + Ordering_match + (compare + {ChessSet} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> False) + (/\dead -> True) + (/\dead -> False) + {all dead. dead}) + (/\dead -> defaultBody) + (/\dead -> defaultBody) + {all dead. dead}))) (\(x : Tuple2 integer ChessSet) (y : Tuple2 integer ChessSet) -> Tuple2_match @@ -1370,30 +1312,45 @@ {ChessSet} y {Bool} - (\(ipv : integer) - (ipv : ChessSet) -> - Ordering_match - (compare - {integer} - v - ipv - ipv) - {all dead. Bool} - (/\dead -> - Ordering_match - (compare - {ChessSet} - v - ipv - ipv) - {all dead. Bool} - (/\dead -> True) - (/\dead -> True) - (/\dead -> False) - {all dead. dead}) - (/\dead -> True) - (/\dead -> False) - {all dead. dead}))) + (\(ipv : integer) -> + let + ~defaultBody : Bool + = Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> + error {Bool}) + (/\dead -> True) + (/\dead -> False) + {all dead. dead} + in + \(ipv : ChessSet) -> + Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> + Ordering_match + (compare + {ChessSet} + v + ipv + ipv) + {all dead. Bool} + (/\dead -> True) + (/\dead -> True) + (/\dead -> False) + {all dead. dead}) + (/\dead -> defaultBody) + (/\dead -> defaultBody) + {all dead. dead}))) (\(x : Tuple2 integer ChessSet) (y : Tuple2 integer ChessSet) -> Tuple2_match @@ -1408,36 +1365,58 @@ {ChessSet} y {Tuple2 integer ChessSet} - (\(ipv : integer) - (ipv : ChessSet) -> - Ordering_match - (compare - {integer} - v - ipv - ipv) - {all dead. - Tuple2 - integer - ChessSet} - (/\dead -> - Ordering_match - (compare - {ChessSet} - v - ipv - ipv) - {all dead. - Tuple2 - integer - ChessSet} - (/\dead -> y) - (/\dead -> x) - (/\dead -> y) - {all dead. dead}) - (/\dead -> x) - (/\dead -> y) - {all dead. dead}))) + (\(ipv : integer) -> + let + ~defaultBody : + Tuple2 integer ChessSet + = Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. + Tuple2 + integer + ChessSet} + (/\dead -> + error + {Tuple2 + integer + ChessSet}) + (/\dead -> x) + (/\dead -> y) + {all dead. dead} + in + \(ipv : ChessSet) -> + Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. + Tuple2 + integer + ChessSet} + (/\dead -> + Ordering_match + (compare + {ChessSet} + v + ipv + ipv) + {all dead. + Tuple2 + integer + ChessSet} + (/\dead -> y) + (/\dead -> x) + (/\dead -> y) + {all dead. dead}) + (/\dead -> defaultBody) + (/\dead -> defaultBody) + {all dead. dead}))) (\(x : Tuple2 integer ChessSet) (y : Tuple2 integer ChessSet) -> Tuple2_match @@ -1452,36 +1431,58 @@ {ChessSet} y {Tuple2 integer ChessSet} - (\(ipv : integer) - (ipv : ChessSet) -> - Ordering_match - (compare - {integer} - v - ipv - ipv) - {all dead. - Tuple2 - integer - ChessSet} - (/\dead -> - Ordering_match - (compare - {ChessSet} - v - ipv - ipv) - {all dead. - Tuple2 - integer - ChessSet} - (/\dead -> x) - (/\dead -> y) - (/\dead -> x) - {all dead. dead}) - (/\dead -> y) - (/\dead -> x) - {all dead. dead})))) + (\(ipv : integer) -> + let + ~defaultBody : + Tuple2 integer ChessSet + = Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. + Tuple2 + integer + ChessSet} + (/\dead -> + error + {Tuple2 + integer + ChessSet}) + (/\dead -> y) + (/\dead -> x) + {all dead. dead} + in + \(ipv : ChessSet) -> + Ordering_match + (compare + {integer} + v + ipv + ipv) + {all dead. + Tuple2 + integer + ChessSet} + (/\dead -> + Ordering_match + (compare + {ChessSet} + v + ipv + ipv) + {all dead. + Tuple2 + integer + ChessSet} + (/\dead -> x) + (/\dead -> y) + (/\dead -> x) + {all dead. dead}) + (/\dead -> defaultBody) + (/\dead -> defaultBody) + {all dead. dead})))) (descAndNo y))) (/\dead -> ifThenElse diff --git a/plutus-benchmark/nofib/test/9.6/knights10-4x4.size.golden b/plutus-benchmark/nofib/test/9.6/knights10-4x4.size.golden index c31ad1f6288..52dddf2565a 100644 --- a/plutus-benchmark/nofib/test/9.6/knights10-4x4.size.golden +++ b/plutus-benchmark/nofib/test/9.6/knights10-4x4.size.golden @@ -1 +1 @@ -1998 \ No newline at end of file +2149 \ No newline at end of file diff --git a/plutus-benchmark/nofib/test/Spec.hs b/plutus-benchmark/nofib/test/Spec.hs index d7722d27ad9..2068349fdae 100644 --- a/plutus-benchmark/nofib/test/Spec.hs +++ b/plutus-benchmark/nofib/test/Spec.hs @@ -49,7 +49,7 @@ testClausify = testGroup "clausify" , testCase "formula5" $ mkClausifyTest Clausify.F5 , runTestGhc [ Tx.goldenPirReadable "clausify-F5" formula5example - , Tx.goldenSize "clausify-F5" formula5example + , Tx.goldenASTSize "clausify-F5" formula5example , Tx.goldenBudget "clausify-F5" formula5example , Tx.goldenEvalCekCatch "clausify-F5" [formula5example] ] @@ -72,7 +72,7 @@ testKnights = testGroup "knights" -- Odd sizes call "error" because there are n , testCase "depth 100, 8x8" $ mkKnightsTest 100 8 , runTestGhc [ Tx.goldenPirReadable "knights10-4x4" knightsExample - , Tx.goldenSize "knights10-4x4" knightsExample + , Tx.goldenASTSize "knights10-4x4" knightsExample , Tx.goldenBudget "knights10-4x4" knightsExample , Tx.goldenEvalCekCatch "knights10-4x4" [knightsExample] ] @@ -95,7 +95,7 @@ testQueens = testGroup "queens" , testCase "Fc" $ mkQueensTest 4 Queens.Fc , runTestGhc [ Tx.goldenPirReadable "queens4-bt" queens4btExample - , Tx.goldenSize "queens4-bt" queens4btExample + , Tx.goldenASTSize "queens4-bt" queens4btExample , Tx.goldenBudget "queens4-bt" queens4btExample , Tx.goldenEvalCekCatch "queens4-bt" [queens4btExample] ] @@ -108,7 +108,7 @@ testQueens = testGroup "queens" , testCase "Fc" $ mkQueensTest 5 Queens.Fc , runTestGhc [ Tx.goldenPirReadable "queens5-fc" queens5fcExample - , Tx.goldenSize "queens5-fc" queens5fcExample + , Tx.goldenASTSize "queens5-fc" queens5fcExample , Tx.goldenBudget "queens5-fc" queens5fcExample , Tx.goldenEvalCekCatch "queens5-fc" [queens5fcExample] ] diff --git a/plutus-benchmark/script-contexts/test/Spec.hs b/plutus-benchmark/script-contexts/test/Spec.hs index 62557c4ccb5..ec47d3a678d 100644 --- a/plutus-benchmark/script-contexts/test/Spec.hs +++ b/plutus-benchmark/script-contexts/test/Spec.hs @@ -43,7 +43,7 @@ testCheckSc1 = testGroup "checkScriptContext1" compiledCodeToTerm $ mkCheckScriptContext1Code (mkScriptContext 4) , testCase "fails on 5" . assertFailed $ compiledCodeToTerm $ mkCheckScriptContext1Code (mkScriptContext 5) - , runTestGhc [ Tx.goldenSize "checkScriptContext1" $ + , runTestGhc [ Tx.goldenASTSize "checkScriptContext1" $ mkCheckScriptContext1Code (mkScriptContext 1) , Tx.goldenPirReadable "checkScriptContext1" $ mkCheckScriptContext1Code (mkScriptContext 1) @@ -64,7 +64,7 @@ testCheckSc2 = testGroup "checkScriptContext2" compiledCodeToTerm $ mkCheckScriptContext2Code (mkScriptContext 4) , testCase "succeed on 5" . assertSucceeded $ compiledCodeToTerm $ mkCheckScriptContext2Code (mkScriptContext 5) - , runTestGhc [ Tx.goldenSize "checkScriptContext2" $ + , runTestGhc [ Tx.goldenASTSize "checkScriptContext2" $ mkCheckScriptContext2Code (mkScriptContext 1) , Tx.goldenPirReadable "checkScriptContext2" $ mkCheckScriptContext2Code (mkScriptContext 1) diff --git a/plutus-core/changelog.d/20240522_152938_bezirg_astsize.md b/plutus-core/changelog.d/20240522_152938_bezirg_astsize.md new file mode 100644 index 00000000000..51982903dda --- /dev/null +++ b/plutus-core/changelog.d/20240522_152938_bezirg_astsize.md @@ -0,0 +1,3 @@ +### Changed + +- Renamed all `*Size` related datatypes and constructors to `*ASTSize`. diff --git a/plutus-core/executables/pir/Main.hs b/plutus-core/executables/pir/Main.hs index 9590fb1c7f9..5274fa99623 100644 --- a/plutus-core/executables/pir/Main.hs +++ b/plutus-core/executables/pir/Main.hs @@ -219,11 +219,11 @@ runOptimisations (PirOptimiseOptions inp ifmt outp ofmt mode) = do ---------------- Analysis ---------------- -- | a csv-outputtable record row of {name,unique,size} -data RetentionRecord = RetentionRecord { name :: T.Text, unique :: Int, size :: PIR.Size} +data RetentionRecord = RetentionRecord { name :: T.Text, unique :: Int, size :: PIR.ASTSize} deriving stock (Generic, Show) deriving anyclass Csv.ToNamedRecord deriving anyclass Csv.DefaultOrdered -deriving newtype instance Csv.ToField PIR.Size +deriving newtype instance Csv.ToField PIR.ASTSize loadPirAndAnalyse :: AnalyseOptions -> IO () loadPirAndAnalyse (AnalyseOptions inp ifmt outp) = do diff --git a/plutus-core/executables/src/PlutusCore/Executable/Common.hs b/plutus-core/executables/src/PlutusCore/Executable/Common.hs index 8333287d342..cb5d5319469 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Common.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/Common.hs @@ -166,7 +166,7 @@ printBudgetStateTally term model (Cek.CekExTally costs) = do putStrLn "" putStrLn $ "startup " ++ (budgetToString $ getSpent Cek.BStartup) putStrLn $ "compute " ++ budgetToString totalComputeCost - putStrLn $ "AST nodes " ++ printf "%15d" (UPLC.unSize $ UPLC.termSize term) + putStrLn $ "AST nodes " ++ printf "%15d" (UPLC.unASTSize $ UPLC.termASTSize term) putStrLn "" case model of Default -> diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 0c6afcd8c47..8180aa2bb52 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -91,6 +91,7 @@ library PlutusCore.Analysis.Definitions PlutusCore.Annotation PlutusCore.Arity + PlutusCore.ASTSize PlutusCore.Bitwise.Convert PlutusCore.Builtin PlutusCore.Builtin.Debug @@ -163,7 +164,6 @@ library PlutusCore.Rename PlutusCore.Rename.Internal PlutusCore.Rename.Monad - PlutusCore.Size PlutusCore.StdLib.Data.Bool PlutusCore.StdLib.Data.ChurchNat PlutusCore.StdLib.Data.Data @@ -248,6 +248,7 @@ library Universe.Core UntypedPlutusCore.Analysis.Definitions UntypedPlutusCore.Analysis.Usages + UntypedPlutusCore.ASTSize UntypedPlutusCore.Core.Instance UntypedPlutusCore.Core.Instance.Eq UntypedPlutusCore.Core.Instance.Flat @@ -264,7 +265,6 @@ library UntypedPlutusCore.Rename.Internal UntypedPlutusCore.Simplify UntypedPlutusCore.Simplify.Opts - UntypedPlutusCore.Size UntypedPlutusCore.Subst UntypedPlutusCore.Transform.CaseReduce UntypedPlutusCore.Transform.Cse @@ -555,8 +555,8 @@ library plutus-ir other-modules: PlutusIR.Analysis.Definitions - PlutusIR.Analysis.Size PlutusIR.Analysis.Usages + PlutusIR.ASTSize PlutusIR.Compiler.Error PlutusIR.Compiler.Lower PlutusIR.Compiler.Recursion diff --git a/plutus-core/plutus-core/src/PlutusCore.hs b/plutus-core/plutus-core/src/PlutusCore.hs index 35ae6bc33c6..70091ea4d73 100644 --- a/plutus-core/plutus-core/src/PlutusCore.hs +++ b/plutus-core/plutus-core/src/PlutusCore.hs @@ -119,15 +119,15 @@ module PlutusCore -- * Combining programs , applyProgram -- * Benchmarking - , termSize - , typeSize - , kindSize - , programSize - , serialisedSize + , termASTSize + , typeASTSize + , kindASTSize + , programASTSize ) where import PlutusCore.Annotation +import PlutusCore.ASTSize import PlutusCore.Builtin import PlutusCore.Core import PlutusCore.DeBruijn @@ -142,7 +142,6 @@ import PlutusCore.Normalize import PlutusCore.Parser import PlutusCore.Quote import PlutusCore.Rename -import PlutusCore.Size import PlutusCore.Subst import PlutusCore.TypeCheck as TypeCheck diff --git a/plutus-core/plutus-core/src/PlutusCore/ASTSize.hs b/plutus-core/plutus-core/src/PlutusCore/ASTSize.hs new file mode 100644 index 00000000000..2e871099792 --- /dev/null +++ b/plutus-core/plutus-core/src/PlutusCore/ASTSize.hs @@ -0,0 +1,66 @@ +module PlutusCore.ASTSize + ( ASTSize (..) + , kindASTSize + , typeASTSize + , tyVarDeclASTSize + , termASTSize + , varDeclASTSize + , programASTSize + ) where + +import PlutusCore.Core +import PlutusPrelude + +import Control.Lens +import Data.Monoid + +newtype ASTSize = ASTSize + { unASTSize :: Integer + } deriving stock (Show) + deriving newtype (Pretty, Eq, Ord, Num) + deriving (Semigroup, Monoid) via Sum Integer + +-- | Count the number of AST nodes in a kind. +-- +-- >>> kindASTSize $ Type () +-- ASTSize {unASTSize = 1} +-- >>> kindASTSize $ KindArrow () (KindArrow () (Type ()) (Type ())) (Type ()) +-- ASTSize {unASTSize = 5} +kindASTSize :: Kind a -> ASTSize +kindASTSize kind = fold + [ ASTSize 1 + , kind ^. kindSubkinds . to kindASTSize + ] + +-- | Count the number of AST nodes in a type. +typeASTSize :: Type tyname uni ann -> ASTSize +typeASTSize ty = fold + [ ASTSize 1 + , ty ^. typeSubkinds . to kindASTSize + , ty ^. typeSubtypes . to typeASTSize + ] + +tyVarDeclASTSize :: TyVarDecl tyname ann -> ASTSize +tyVarDeclASTSize tyVarDecl = fold + [ ASTSize 1 + , tyVarDecl ^. tyVarDeclSubkinds . to kindASTSize + ] + +-- | Count the number of AST nodes in a term. +termASTSize :: Term tyname name uni fun ann -> ASTSize +termASTSize term = fold + [ ASTSize 1 + , term ^. termSubkinds . to kindASTSize + , term ^. termSubtypes . to typeASTSize + , term ^. termSubterms . to termASTSize + ] + +varDeclASTSize :: VarDecl tyname name uni ann -> ASTSize +varDeclASTSize varDecl = fold + [ ASTSize 1 + , varDecl ^. varDeclSubtypes . to typeASTSize + ] + +-- | Count the number of AST nodes in a program. +programASTSize :: Program tyname name uni fun ann -> ASTSize +programASTSize (Program _ _ t) = termASTSize t diff --git a/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs b/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs index fc2bcc5809d..72289b7cbc4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs @@ -122,7 +122,12 @@ instance Ord Name where instance Hashable Name where hashWithSalt s = hashWithSalt s . _nameUnique --- | A unique identifier +{-| A unique identifier + +We only make use of positive integral numbers. Using `Word` does not buy us much, +because under- & over-flow could still happen. Using `Natural`s would be nice, but +then we cannot use the faster `IntMap` implementation for the `UniqueMap`. +-} newtype Unique = Unique {unUnique :: Int} deriving stock (Eq, Show, Ord, Lift) deriving newtype (Enum, NFData, Pretty, Hashable) diff --git a/plutus-core/plutus-core/src/PlutusCore/Size.hs b/plutus-core/plutus-core/src/PlutusCore/Size.hs deleted file mode 100644 index afea4cf0812..00000000000 --- a/plutus-core/plutus-core/src/PlutusCore/Size.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module PlutusCore.Size - ( Size (..) - , kindSize - , typeSize - , tyVarDeclSize - , termSize - , varDeclSize - , programSize - , serialisedSize - ) where - -import PlutusPrelude - -import PlutusCore.Core - -import Control.Lens -import Data.ByteString qualified as BS -import Data.Monoid -import Flat hiding (to) - -newtype Size = Size - { unSize :: Integer - } deriving stock (Show) - deriving newtype (Pretty, Eq, Ord, Num) - deriving (Semigroup, Monoid) via Sum Integer - --- | Count the number of AST nodes in a kind. --- --- >>> kindSize $ Type () --- Size {unSize = 1} --- >>> kindSize $ KindArrow () (KindArrow () (Type ()) (Type ())) (Type ()) --- Size {unSize = 5} -kindSize :: Kind a -> Size -kindSize kind = fold - [ Size 1 - , kind ^. kindSubkinds . to kindSize - ] - --- | Count the number of AST nodes in a type. -typeSize :: Type tyname uni ann -> Size -typeSize ty = fold - [ Size 1 - , ty ^. typeSubkinds . to kindSize - , ty ^. typeSubtypes . to typeSize - ] - -tyVarDeclSize :: TyVarDecl tyname ann -> Size -tyVarDeclSize tyVarDecl = fold - [ Size 1 - , tyVarDecl ^. tyVarDeclSubkinds . to kindSize - ] - --- | Count the number of AST nodes in a term. -termSize :: Term tyname name uni fun ann -> Size -termSize term = fold - [ Size 1 - , term ^. termSubkinds . to kindSize - , term ^. termSubtypes . to typeSize - , term ^. termSubterms . to termSize - ] - -varDeclSize :: VarDecl tyname name uni ann -> Size -varDeclSize varDecl = fold - [ Size 1 - , varDecl ^. varDeclSubtypes . to typeSize - ] - --- | Count the number of AST nodes in a program. -programSize :: Program tyname name uni fun ann -> Size -programSize (Program _ _ t) = termSize t - --- | Compute the size of the serializabled form of a value. -serialisedSize :: Flat a => a -> Integer -serialisedSize = fromIntegral . BS.length . flat diff --git a/plutus-core/plutus-ir/src/PlutusIR/ASTSize.hs b/plutus-core/plutus-ir/src/PlutusIR/ASTSize.hs new file mode 100644 index 00000000000..c704b1f466e --- /dev/null +++ b/plutus-core/plutus-ir/src/PlutusIR/ASTSize.hs @@ -0,0 +1,25 @@ +module PlutusIR.ASTSize + ( ASTSize (..) + , kindASTSize + , typeASTSize + , tyVarDeclASTSize + , termASTSize + , varDeclASTSize + ) where + +import PlutusPrelude + +import PlutusIR.Core + +import PlutusCore.ASTSize (ASTSize (..), kindASTSize, tyVarDeclASTSize, typeASTSize, varDeclASTSize) + +import Control.Lens + +-- | Count the number of AST nodes in a term. +termASTSize :: Term tyname name uni fun ann -> ASTSize +termASTSize term = fold + [ ASTSize 1 + , term ^. termSubkinds . to kindASTSize + , term ^. termSubtypes . to typeASTSize + , term ^. termSubterms . to termASTSize + ] diff --git a/plutus-core/plutus-ir/src/PlutusIR/Analysis/RetainedSize.hs b/plutus-core/plutus-ir/src/PlutusIR/Analysis/RetainedSize.hs index 908774ea0a9..6662f15e522 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Analysis/RetainedSize.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Analysis/RetainedSize.hs @@ -4,7 +4,7 @@ module PlutusIR.Analysis.RetainedSize ( RetainedSize (..) - , Size (..) + , ASTSize (..) , termRetentionMap , annotateWithRetainedSize ) where @@ -12,7 +12,7 @@ module PlutusIR.Analysis.RetainedSize import PlutusPrelude import PlutusIR.Analysis.Dependencies -import PlutusIR.Analysis.Size +import PlutusIR.ASTSize import PlutusIR.Core import PlutusCore qualified as PLC @@ -87,7 +87,7 @@ retains. But there doesn't seem to be a sensible way of doing that. Should it be rootSize :: Term tyname name uni fun ann -> Size rootSize (Let _ _ _ term) = rootSize term - rootSize term = termSize term + rootSize term = termASTSize term ? But what about bindings inside the final non-let term? However we don't need that directly retained size of the root for anything that is not "don't throw an error on encountering the root @@ -98,7 +98,7 @@ we know there's a bug somewhere and if it doesn't, we don't care about it. -} data RetainedSize - = Retains Size + = Retains ASTSize | NotARetainer deriving stock (Show) @@ -117,14 +117,14 @@ nodeToInt (Variable (PLC.Unique i)) = i nodeToInt Root = rootInt -- | A mapping from the index of a binding to what it directly retains. -newtype DirectionRetentionMap = DirectionRetentionMap (IntMap Size) +newtype DirectionRetentionMap = DirectionRetentionMap (IntMap ASTSize) -lookupSize :: Int -> DirectionRetentionMap -> Size +lookupSize :: Int -> DirectionRetentionMap -> ASTSize lookupSize i (DirectionRetentionMap ss) = ss IntMap.! i -- | Annotate the dominator tree with the retained size of each entry. The retained size is computed -- as the size directly retained by the binding plus the size of all its dependencies. -annotateWithSizes :: DirectionRetentionMap -> Tree Int -> Tree (Int, Size) +annotateWithSizes :: DirectionRetentionMap -> Tree Int -> Tree (Int, ASTSize) annotateWithSizes sizeInfo = go where go (Node i ts) = Node (i, sizeI) rs where rs = map go ts @@ -135,29 +135,29 @@ toDomTree :: C.Graph Node -> Tree Int toDomTree = domTree . (,) rootInt . adjacencyIntMap . fmap nodeToInt -- | Compute the retention map of a graph. -depsRetentionMap :: DirectionRetentionMap -> C.Graph Node -> IntMap Size +depsRetentionMap :: DirectionRetentionMap -> C.Graph Node -> IntMap ASTSize depsRetentionMap sizeInfo = IntMap.fromList . flatten . annotateWithSizes sizeInfo . toDomTree -- | Construct a 'UniqueMap' having size information for each individual part of a 'Binding'. bindingSize :: (HasUnique tyname TypeUnique, HasUnique name TermUnique) - => Binding tyname name uni fun ann -> PLC.UniqueMap Unique Size + => Binding tyname name uni fun ann -> PLC.UniqueMap Unique ASTSize bindingSize (TermBind _ _ var term) = - UMap.insertByNameIndex var (varDeclSize var <> termSize term) mempty + UMap.insertByNameIndex var (varDeclASTSize var <> termASTSize term) mempty bindingSize (TypeBind _ tyVar ty) = - UMap.insertByNameIndex tyVar (tyVarDeclSize tyVar <> typeSize ty) mempty + UMap.insertByNameIndex tyVar (tyVarDeclASTSize tyVar <> typeASTSize ty) mempty bindingSize (DatatypeBind _ (Datatype _ dataDecl params matchName constrs)) - = UMap.insertByNameIndex dataDecl (tyVarDeclSize dataDecl) - . flip (foldr $ \param -> UMap.insertByNameIndex param $ tyVarDeclSize param) params - . UMap.insertByNameIndex matchName (Size 1) - . flip (foldr $ \constr -> UMap.insertByNameIndex constr $ varDeclSize constr) constrs + = UMap.insertByNameIndex dataDecl (tyVarDeclASTSize dataDecl) + . flip (foldr $ \param -> UMap.insertByNameIndex param $ tyVarDeclASTSize param) params + . UMap.insertByNameIndex matchName (ASTSize 1) + . flip (foldr $ \constr -> UMap.insertByNameIndex constr $ varDeclASTSize constr) constrs $ mempty -- | Construct a 'UniqueMap' having size information for each individual part of every 'Binding' -- in a term. bindingSizes :: (HasUnique tyname TypeUnique, HasUnique name TermUnique) - => Term tyname name uni fun ann -> PLC.UniqueMap Unique Size + => Term tyname name uni fun ann -> PLC.UniqueMap Unique ASTSize bindingSizes (Let _ _ binds term) = foldMap bindingSize binds <> bindingSizes term bindingSizes term = term ^. termSubterms . to bindingSizes @@ -168,7 +168,7 @@ toDirectionRetentionMap toDirectionRetentionMap term = DirectionRetentionMap . IntMap.insert rootInt rootSize . PLC.unUniqueMap $ bindingSizes term where -- See Note [Handling the root]. - rootSize = Size (- 10 ^ (10::Int)) + rootSize = ASTSize (- 10 ^ (10::Int)) -- | Check if a 'Node' appears in 'DirectionRetentionMap'. hasSizeIn :: DirectionRetentionMap -> Node -> Bool @@ -181,7 +181,7 @@ termRetentionMap => BuiltinsInfo uni fun -> VarsInfo tyname name uni ann -> Term tyname name uni fun ann - -> IntMap Size + -> IntMap ASTSize termRetentionMap binfo vinfo term = depsRetentionMap sizeInfo deps where sizeInfo = toDirectionRetentionMap term deps = C.induce (hasSizeIn sizeInfo) $ runTermDeps binfo vinfo term @@ -230,4 +230,4 @@ annotateWithRetainedSize binfo term = reannotateBindings (upd . unUnique) $ NotA retentionMap = termRetentionMap binfo vinfo term vinfo = termVarInfo term -- If a binding is not in the retention map, then it's still a retainer, just retains zero size. - upd i _ = Retains $ IntMap.findWithDefault (Size 0) i retentionMap + upd i _ = Retains $ IntMap.findWithDefault (ASTSize 0) i retentionMap diff --git a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Size.hs b/plutus-core/plutus-ir/src/PlutusIR/Analysis/Size.hs deleted file mode 100644 index 468e1d021a2..00000000000 --- a/plutus-core/plutus-ir/src/PlutusIR/Analysis/Size.hs +++ /dev/null @@ -1,25 +0,0 @@ -module PlutusIR.Analysis.Size - ( Size (..) - , kindSize - , typeSize - , tyVarDeclSize - , termSize - , varDeclSize - ) where - -import PlutusPrelude - -import PlutusIR.Core - -import PlutusCore.Size (Size (..), kindSize, tyVarDeclSize, typeSize, varDeclSize) - -import Control.Lens - --- | Count the number of AST nodes in a term. -termSize :: Term tyname name uni fun ann -> Size -termSize term = fold - [ Size 1 - , term ^. termSubkinds . to kindSize - , term ^. termSubtypes . to typeSize - , term ^. termSubterms . to termSize - ] diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/CallSiteInline.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/CallSiteInline.hs index 8af790f0d6f..21e245339a5 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/CallSiteInline.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/CallSiteInline.hs @@ -13,7 +13,7 @@ module PlutusIR.Transform.Inline.CallSiteInline where import PlutusCore qualified as PLC import PlutusCore.Rename (rename) import PlutusCore.Rename.Internal (Dupable (Dupable)) -import PlutusIR.Analysis.Size (Size, termSize) +import PlutusIR.ASTSize (ASTSize, termASTSize) import PlutusIR.Contexts import PlutusIR.Core import PlutusIR.Transform.Inline.Utils @@ -115,7 +115,7 @@ callSiteInline :: forall tyname name uni fun ann. (InliningConstraints tyname name uni fun) => -- | The term size if it were not inlined. - Size -> + ASTSize -> -- | The `Utils.VarInfo` of the variable (the head of the term). InlineVarInfo tyname name uni fun ann -> -- | The application context of the term, already processed. @@ -150,7 +150,7 @@ callSiteInline processedTSize = go applyAndBetaReduce renamedRhs args >>= \case Just inlined -> do let -- Inline only if the size is no bigger than not inlining. - sizeIsOk = termSize inlined <= processedTSize + sizeIsOk = termASTSize inlined <= processedTSize pure $ if sizeIsOk then Just inlined else Nothing Nothing -> pure Nothing else pure Nothing diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Inline.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Inline.hs index 1be00d3f172..a5098d8ebf6 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Inline.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Inline.hs @@ -18,9 +18,9 @@ import PlutusCore.Quote import PlutusCore.Rename (dupable) import PlutusIR import PlutusIR.Analysis.Builtins -import PlutusIR.Analysis.Size (termSize) import PlutusIR.Analysis.Usages qualified as Usages import PlutusIR.Analysis.VarInfo qualified as VarInfo +import PlutusIR.ASTSize (termASTSize) import PlutusIR.Contexts (AppContext (..), fillAppContext, splitApplication) import PlutusIR.MkPir (mkLet) import PlutusIR.Pass @@ -284,7 +284,7 @@ processTerm = handleTerm <=< traverseOf termSubtypes applyTypeSubstitution where Just varInfo -> do maybeInlined <- callSiteInline - (termSize reconstructed) + (termASTSize reconstructed) varInfo args' pure $ fromMaybe reconstructed maybeInlined diff --git a/plutus-core/testlib/PlutusCore/Test.hs b/plutus-core/testlib/PlutusCore/Test.hs index 2aee9675ee1..293f8a12eed 100644 --- a/plutus-core/testlib/PlutusCore/Test.hs +++ b/plutus-core/testlib/PlutusCore/Test.hs @@ -31,7 +31,7 @@ module PlutusCore.Test ( goldenUEvalProfile, goldenUEvalProfile', goldenUEvalBudget, - goldenSize, + goldenASTSize, initialSrcSpan, topSrcSpan, NoMarkRenameT (..), @@ -411,14 +411,14 @@ goldenUEvalBudget :: goldenUEvalBudget name values = nestedGoldenVsDocM name ".budget" $ ppCatch $ runUPlcBudget values -goldenSize :: +goldenASTSize :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> a -> TestNested -goldenSize name value = +goldenASTSize name value = nestedGoldenVsDocM name ".size" $ - pure . pretty . UPLC.programSize =<< rethrow (toUPlc value) + pure . pretty . UPLC.programASTSize =<< rethrow (toUPlc value) -- | This is mostly useful for profiling a test that is normally -- tested with one of the other functions, as it's a drop-in diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs index 2c66191ffb8..92fe75fc23e 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs @@ -8,12 +8,12 @@ module UntypedPlutusCore ( , PLC.DefaultFun ) where +import UntypedPlutusCore.ASTSize as Export import UntypedPlutusCore.Check.Scope as Export import UntypedPlutusCore.Core as Export import UntypedPlutusCore.DeBruijn as Export import UntypedPlutusCore.Parser as Parser (parseScoped) import UntypedPlutusCore.Simplify as Export -import UntypedPlutusCore.Size as Export import UntypedPlutusCore.Subst as Export import PlutusCore.Default qualified as PLC diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/ASTSize.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/ASTSize.hs new file mode 100644 index 00000000000..6e6233b286a --- /dev/null +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/ASTSize.hs @@ -0,0 +1,26 @@ +module UntypedPlutusCore.ASTSize + ( ASTSize (..) + , termASTSize + , programASTSize + , uvarDeclASTSize + ) where + +import PlutusCore.ASTSize (ASTSize (..)) +import UntypedPlutusCore.Core + +import Control.Lens +import Data.Foldable + +-- | Count the number of AST nodes in a term. +termASTSize :: Term name uni fun ann -> ASTSize +termASTSize term = fold + [ ASTSize 1 + , term ^. termSubterms . to termASTSize + ] + +-- | Count the number of AST nodes in a program. +programASTSize :: Program name uni fun ann -> ASTSize +programASTSize (Program _ _ t) = termASTSize t + +uvarDeclASTSize :: UVarDecl name ann -> ASTSize +uvarDeclASTSize _ = ASTSize 1 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Size.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Size.hs deleted file mode 100644 index 68bc765b280..00000000000 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Size.hs +++ /dev/null @@ -1,29 +0,0 @@ -module UntypedPlutusCore.Size - ( Size (..) - , termSize - , programSize - , serialisedSize - ) where - -import PlutusCore.Size (Size (..)) -import UntypedPlutusCore.Core - -import Control.Lens -import Data.ByteString qualified as BS -import Data.Foldable -import Flat hiding (to) - --- | Count the number of AST nodes in a term. -termSize :: Term name uni fun ann -> Size -termSize term = fold - [ Size 1 - , term ^. termSubterms . to termSize - ] - --- | Count the number of AST nodes in a program. -programSize :: Program name uni fun ann -> Size -programSize (Program _ _ t) = termSize t - --- | Compute the size of the serialized form of a value. -serialisedSize :: Flat a => a -> Integer -serialisedSize = fromIntegral . BS.length . flat diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs index 8e674f83c02..b7031528969 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Cse.hs @@ -8,9 +8,9 @@ module UntypedPlutusCore.Transform.Cse (cse) where import PlutusCore (MonadQuote, Name, Rename, freshName, rename) import PlutusCore.Builtin (ToBuiltinMeaning (BuiltinSemanticsVariant)) +import UntypedPlutusCore.ASTSize (termASTSize) import UntypedPlutusCore.Core import UntypedPlutusCore.Purity (isWorkFree) -import UntypedPlutusCore.Size (termSize) import Control.Arrow ((>>>)) import Control.Lens (foldrOf, transformOf) @@ -35,14 +35,10 @@ import PlutusCore.Arity (builtinArity) 1. Simplifications ------------------------------------------------------------------------------- -This is a simplified (i.e., not fully optimal) implementation of CSE. The two simplifications -we made are: +This is a simplified (i.e., not fully optimal) implementation of CSE. One simplification +we made is: - No alpha equivalence check, i.e., `\x -> x` and `\y -> y` are considered different expressions. -- The builtin function arity information is approximate: rather than using the accurate arities, - we simply use the maximum number of arguments applied to a builtin function in the program - as the builtin function's arity. The arity information is used to determine whether a builtin - application is possibly saturated. ------------------------------------------------------------------------------- 2. How does it work? @@ -58,10 +54,9 @@ We use the following example to explain how the implementation works: ] ) -The implementation makes several passes on the given term. The first pass collects builtin -arity information as described above. +The implementation makes several passes on the given term. -In the second pass, we assign a unique ID to each `LamAbs`, `Delay`, and each `Case` branch. +In the first pass, we assign a unique ID to each `LamAbs`, `Delay`, and each `Case` branch. Then, we annotate each subterm with a path, consisting of IDs encountered from the root to that subterm (not including itself). The reason to do this is because `LamAbs`, `Delay`, and `Case` branches represent places where computation stops, i.e., subexpressions are not @@ -72,7 +67,7 @@ three case branches are 2, 3, 4 (the actual numbers don't matter, as long as the The path for the first `1+(2+x)` and the first `2+x` is "0.1"; the path for the second `1+(2+x)` and the second `2+x` is "0.1.2"; the path for `4+x` is "0.1.4". -In the third pass, we calculate a count for each `(term, path)` pair, where `term` is a +In the second pass, we calculate a count for each `(term, path)` pair, where `term` is a non-workfree term, and `path` is its path. If the same term has two paths, and one is an ancestor (i.e., prefix) of the other, we increment the count for the ancestor path in both instances. @@ -88,7 +83,7 @@ In the above example, the CSE candidates are `(2+x, "0.1")` and `(1+(2+x), "0.1" Note that `3+x` is not a CSE candidate, because it has two paths, and neither has a count greater than 1. `2+` is also not a CSE candidate, because it is workfree. -The CSE candidates are then processed in descending order of their `termSize`s. For each CSE +The CSE candidates are then processed in descending order of their `termASTSize`s. For each CSE candidate, we generate a fresh variable, create a LamAbs for it under its path, and substitute it for all occurrences in the original term whose paths are descendents (or self) of the candidate's path. The order is because a bigger expression may contain a small subexpression. @@ -220,9 +215,9 @@ cse builtinSemanticsVariant t0 = do t <- rename t0 let annotated = annotate t commonSubexprs = - -- Processed the common subexpressions in descending order of `termSize`. + -- Processed the common subexpressions in descending order of `termASTSize`. -- See Note [CSE]. - sortOn (Down . termSize) + sortOn (Down . termASTSize) . fmap snd3 -- A subexpression is common if the count is greater than 1. . filter ((> 1) . thd3) @@ -231,7 +226,7 @@ cse builtinSemanticsVariant t0 = do $ countOccs builtinSemanticsVariant annotated mkCseTerm commonSubexprs annotated --- | The second pass. See Note [CSE]. +-- | The first pass. See Note [CSE]. annotate :: Term name uni fun ann -> Term name uni fun (Path, ann) annotate = flip evalState 0 . flip runReaderT [] . go where @@ -265,7 +260,7 @@ annotate = flip evalState 0 . flip runReaderT [] . go local (freshId :) (go br) ) --- | The third pass. See Note [CSE]. +-- | The second pass. See Note [CSE]. countOccs :: forall name uni fun ann. (Hashable (Term name uni fun ()), ToBuiltinMeaning uni fun) => diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs index 30b7dc4b45c..e60910a39bd 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Inline.hs @@ -33,13 +33,13 @@ import PlutusCore.Quote import PlutusCore.Rename (Dupable, dupable, liftDupable) import PlutusPrelude import UntypedPlutusCore.Analysis.Usages qualified as Usages +import UntypedPlutusCore.ASTSize import UntypedPlutusCore.Core qualified as UPLC import UntypedPlutusCore.Core.Plated import UntypedPlutusCore.Core.Type import UntypedPlutusCore.MkUPlc import UntypedPlutusCore.Purity import UntypedPlutusCore.Rename () -import UntypedPlutusCore.Size import UntypedPlutusCore.Subst import Control.Lens hiding (Strict) @@ -494,7 +494,7 @@ inlineSaturatedApp t Just fullyApplied -> do let -- Inline only if the size is no bigger than not inlining. - sizeIsOk = termSize fullyApplied <= termSize t + sizeIsOk = termASTSize fullyApplied <= termASTSize t rhs = varInfo ^. varRhs -- Cost is always OK if the RHS is a LamAbs, but may not be otherwise. costIsOk = costIsAcceptable rhs diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs index 249c4a63c73..b5563fadf1e 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/SerialisedScript.hs @@ -236,7 +236,7 @@ deserialiseScript ll pv sScript = do throwing _ScriptDecodeError $ LedgerLanguageNotAvailableError ll llIntroPv pv - (remderBS, dScript@(ScriptNamedDeBruijn (UPLC.Program{}))) <- deserialiseSScript sScript + (remderBS, dScript) <- deserialiseSScript sScript when (ll /= PlutusV1 && ll /= PlutusV2 && remderBS /= mempty) $ throwing _ScriptDecodeError $ RemainderError remderBS @@ -249,8 +249,8 @@ deserialiseScript ll pv sScript = do >>> BSL.fromStrict >>> CBOR.deserialiseFromBytes (scriptCBORDecoder ll pv) -- lift the underlying cbor error to our custom error - >>> either (throwing _ScriptDecodeError . toScripDecodeError) pure + >>> either (throwing _ScriptDecodeError . toScriptDecodeError) pure -- turn a cborg failure to our own error type - toScripDecodeError :: CBOR.DeserialiseFailure -> ScriptDecodeError - toScripDecodeError = CBORDeserialiseError . CBOR.Extras.readDeserialiseFailureInfo + toScriptDecodeError :: CBOR.DeserialiseFailure -> ScriptDecodeError + toScriptDecodeError = CBORDeserialiseError . CBOR.Extras.readDeserialiseFailureInfo diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index 585bd3750bd..12d5a857413 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -638,7 +638,7 @@ stripTicks = \case -- | Helper to avoid doing too much construction of Core ourselves mkCompiledCode :: forall a . BS.ByteString -> BS.ByteString -> BS.ByteString -> CompiledCode a -mkCompiledCode plcBS pirBS ci = SerializedCode plcBS (Just pirBS) (fold . unflat $ ci) +mkCompiledCode plcBS pirBS ci = SerializedCode plcBS (Just pirBS) (Just ci) -- | Make a 'NameInfo' mapping the given set of TH names to their -- 'GHC.TyThing's for later reference. diff --git a/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs b/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs index b8c4051e318..ce3d718422e 100644 --- a/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs @@ -68,7 +68,7 @@ applicationHeadsCorrect cc heads = testCase "correct application heads" (assertE headSymbols = -- TODO: This should really use a prism instead of going to and from lists I guess Set.fromList $ [ s - | covMeta <- cc ^. to getCovIdx . coverageMetadata . to Map.elems + | covMeta <- cc ^?! to getCovIdx . _Just . coverageMetadata . to Map.elems , ApplicationHeadSymbol s <- Set.toList $ covMeta ^. metadataSet ] linesInCoverageIndex :: CompiledCode t -> [Int] -> TestTree @@ -76,4 +76,4 @@ linesInCoverageIndex cc ls = testCase "correct line coverage" (assertBool ("Line where covered = all (\l -> any (\(s, e) -> s <= l && l <= e) covLineSpans) ls covLineSpans = [ (covLoc ^. covLocStartLine, covLoc ^. covLocEndLine) - | CoverLocation covLoc <- cc ^. to getCovIdx . coverageMetadata . to Map.keys ] + | CoverLocation covLoc <- cc ^?! to getCovIdx . _Just . coverageMetadata . to Map.keys ] diff --git a/plutus-tx-plugin/test/size/Main.hs b/plutus-tx-plugin/test/size/Main.hs index 19ff5982f0d..11c408a3f0b 100644 --- a/plutus-tx-plugin/test/size/Main.hs +++ b/plutus-tx-plugin/test/size/Main.hs @@ -19,47 +19,47 @@ main = defaultMain $ testGroup "Size regression tests" [ runTestNested ["test", "size", "Golden"] [ testNested "Rational" [ testNested "Eq" - [ goldenSize "equal" ratEq - , goldenSize "not-equal" ratNeq + [ goldenASTSize "equal" ratEq + , goldenASTSize "not-equal" ratNeq ] , testNested "Ord" - [ goldenSize "compare" ratCompare - , goldenSize "less-than-equal" ratLe - , goldenSize "greater-than-equal" ratGe - , goldenSize "less-than" ratLt - , goldenSize "greater-than" ratGt - , goldenSize "max" ratMax - , goldenSize "min" ratMin + [ goldenASTSize "compare" ratCompare + , goldenASTSize "less-than-equal" ratLe + , goldenASTSize "greater-than-equal" ratGe + , goldenASTSize "less-than" ratLt + , goldenASTSize "greater-than" ratGt + , goldenASTSize "max" ratMax + , goldenASTSize "min" ratMin ] , testNested "Additive" - [ goldenSize "plus" ratPlus - , goldenSize "zero" ratZero - , goldenSize "minus" ratMinus - , goldenSize "negate-specialized" ratNegate + [ goldenASTSize "plus" ratPlus + , goldenASTSize "zero" ratZero + , goldenASTSize "minus" ratMinus + , goldenASTSize "negate-specialized" ratNegate ] , testNested "Multiplicative" - [ goldenSize "times" ratTimes - , goldenSize "one" ratOne - , goldenSize "scale" ratScale + [ goldenASTSize "times" ratTimes + , goldenASTSize "one" ratOne + , goldenASTSize "scale" ratScale ] , testNested "Serialization" - [ goldenSize "toBuiltinData" ratToBuiltin - , goldenSize "fromBuiltinData" ratFromBuiltin - , goldenSize "unsafeFromBuiltinData" ratUnsafeFromBuiltin + [ goldenASTSize "toBuiltinData" ratToBuiltin + , goldenASTSize "fromBuiltinData" ratFromBuiltin + , goldenASTSize "unsafeFromBuiltinData" ratUnsafeFromBuiltin ] , testNested "Construction" - [ goldenSize "unsafeRatio" ratMkUnsafe - , goldenSize "ratio" ratMkSafe - , goldenSize "fromInteger" ratFromInteger + [ goldenASTSize "unsafeRatio" ratMkUnsafe + , goldenASTSize "ratio" ratMkSafe + , goldenASTSize "fromInteger" ratFromInteger ] , testNested "Other" - [ goldenSize "numerator" ratNumerator - , goldenSize "denominator" ratDenominator - , goldenSize "round" ratRound - , goldenSize "truncate" ratTruncate - , goldenSize "properFraction" ratProperFraction - , goldenSize "recip" ratRecip - , goldenSize "abs-specialized" ratAbs + [ goldenASTSize "numerator" ratNumerator + , goldenASTSize "denominator" ratDenominator + , goldenASTSize "round" ratRound + , goldenASTSize "truncate" ratTruncate + , goldenASTSize "properFraction" ratProperFraction + , goldenASTSize "recip" ratRecip + , goldenASTSize "abs-specialized" ratAbs ] ] ] diff --git a/plutus-tx/changelog.d/20240522_153034_bezirg_astsize.md b/plutus-tx/changelog.d/20240522_153034_bezirg_astsize.md new file mode 100644 index 00000000000..8bf32730776 --- /dev/null +++ b/plutus-tx/changelog.d/20240522_153034_bezirg_astsize.md @@ -0,0 +1,4 @@ +### Changed + +- `CompiledCode` differentiates between missing and empty `CoverageIndex`, by using `Maybe CoverageIndex`. +- `SerialisedCode` keeps the `CoverageIndex` serialised as flat. diff --git a/plutus-tx/src/PlutusTx/Code.hs b/plutus-tx/src/PlutusTx/Code.hs index a7187aedf0e..58a7ebd271a 100644 --- a/plutus-tx/src/PlutusTx/Code.hs +++ b/plutus-tx/src/PlutusTx/Code.hs @@ -25,6 +25,7 @@ import PlutusTx.Coverage import PlutusTx.Lift.Instances () import UntypedPlutusCore qualified as UPLC -- We do not use qualified import because the whole module contains off-chain code +import Data.Either.Extras import PlutusPrelude import Prelude as Haskell @@ -45,12 +46,15 @@ type role CompiledCodeIn representational representational nominal -- if you want to put it on the chain you must normalize the types first. data CompiledCodeIn uni fun a = -- | Serialized UPLC code and possibly serialized PIR code with metadata used for program coverage. - SerializedCode BS.ByteString (Maybe BS.ByteString) CoverageIndex + SerializedCode + BS.ByteString -- ^ UPLC.Program flat-encoded + (Maybe BS.ByteString) -- ^ PlutusIR.Program flat-encoded + (Maybe BS.ByteString) -- ^ CoverageIndex flat-encoded -- | Deserialized UPLC program, and possibly deserialized PIR program with metadata used for program coverage. | DeserializedCode (UPLC.Program UPLC.NamedDeBruijn uni fun SrcSpans) (Maybe (PIR.Program PLC.TyName PLC.Name uni fun SrcSpans)) - CoverageIndex + (Maybe CoverageIndex) -- | 'CompiledCodeIn' instantiated with default built-in types and functions. type CompiledCode = CompiledCodeIn PLC.DefaultUni PLC.DefaultFun @@ -105,7 +109,7 @@ unsafeApplyCode fun arg = case applyCode fun arg of -- | The size of a 'CompiledCodeIn', in AST nodes. sizePlc :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => CompiledCodeIn uni fun a -> Integer -sizePlc = UPLC.unSize . UPLC.programSize . getPlc +sizePlc = UPLC.unASTSize . UPLC.programASTSize . getPlc {- Note [Deserializing the AST] The types suggest that we can fail to deserialize the AST that we embedded in the program. @@ -149,7 +153,8 @@ getPirNoAnn => CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun ()) getPirNoAnn = fmap void . getPir -getCovIdx :: CompiledCodeIn uni fun a -> CoverageIndex +-- | Will throw an error if the `CoverageIndex` is present but cannot be deserialised. +getCovIdx :: CompiledCodeIn uni fun a -> Maybe CoverageIndex getCovIdx wrapper = case wrapper of - SerializedCode _ _ idx -> idx + SerializedCode _ _ idx -> unsafeFromEither . unflat <$> idx DeserializedCode _ _ idx -> idx diff --git a/plutus-tx/src/PlutusTx/Lift.hs b/plutus-tx/src/PlutusTx/Lift.hs index acff1543917..3611ca9bd43 100644 --- a/plutus-tx/src/PlutusTx/Lift.hs +++ b/plutus-tx/src/PlutusTx/Lift.hs @@ -267,4 +267,4 @@ typeCode p prog = do _ <- typeCheckAgainst p prog compiled <- flip runReaderT PLC.defaultCompilationOpts $ PLC.compileProgram prog db <- traverseOf UPLC.progTerm UPLC.deBruijnTerm compiled - pure $ DeserializedCode (mempty <$ db) Nothing mempty + pure $ DeserializedCode (mempty <$ db) Nothing Nothing diff --git a/plutus-tx/src/PlutusTx/TH.hs b/plutus-tx/src/PlutusTx/TH.hs index 841337b4f84..1a45d1542f5 100644 --- a/plutus-tx/src/PlutusTx/TH.hs +++ b/plutus-tx/src/PlutusTx/TH.hs @@ -29,7 +29,7 @@ loadFromFile fp = TH.liftSplice $ do -- We don't have a 'Lift' instance for 'CompiledCode' (we could but it would be tedious), -- so we lift the bytestring and construct the value in the quote. bs <- liftIO $ BS.readFile fp - TH.examineSplice [|| SerializedCode bs Nothing mempty ||] + TH.examineSplice [|| SerializedCode bs Nothing Nothing ||] {- Note [Typed TH] It's nice to use typed TH! However, we sadly can't *quite* use it thoroughly, because we diff --git a/plutus-tx/testlib/PlutusTx/Test.hs b/plutus-tx/testlib/PlutusTx/Test.hs index c6fe9b747e0..d0f1f6a29b5 100644 --- a/plutus-tx/testlib/PlutusTx/Test.hs +++ b/plutus-tx/testlib/PlutusTx/Test.hs @@ -9,7 +9,7 @@ module PlutusTx.Test ( -- * Size tests - goldenSize, + goldenASTSize, fitsUnder, -- * Compilation testing