diff --git a/.github/workflows/manual-benchmark.yml b/.github/workflows/manual-benchmark.yml index fc3a390716b..957edc93d82 100644 --- a/.github/workflows/manual-benchmark.yml +++ b/.github/workflows/manual-benchmark.yml @@ -43,13 +43,15 @@ jobs: uses: actions/github-script@main with: script: | - const regex = /^\/benchmark\s*(.*?)\s*$/; + const regex = /^\/benchmark\s*([^\s]*)\s*(cap=([0-9]+))?$/; const comment = context.payload.comment.body; const match = comment.match(regex) - if (match !== null && match.length == 2) + if (match !== null && match.length == 4 && match[1] !== '') { core.setOutput('benchmark', match[1]); - else - core.setFailed(`Unable to extract benchmark name from ${comment}`); + core.setOutput('capability_num', match[3] || ""); + } else { + core.setFailed(`Unable to extract benchmark name from comment '${comment}'`); + } - name: Extract Branch Name id: extract-branch @@ -116,6 +118,7 @@ jobs: nix develop --no-warn-dirty --accept-flake-config --command bash ./scripts/ci-plutus-benchmark.sh env: BENCHMARK_NAME: ${{ steps.extract-benchmark.outputs.benchmark }} + CAPABILITY_NUM: ${{ steps.extract-benchmark.outputs.capability_num }} PR_NUMBER: ${{ github.event.issue.number }} PR_BRANCH: ${{ steps.extract-branch.outputs.head_ref }} diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 682895dbafa..85d0e59882b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1,10 +1,12 @@ -- editorconfig-checker-disable-file {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -46,6 +48,10 @@ import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Flat hiding (from, to) import Flat.Decoder (Get, dBEBits8) import Flat.Encoder as Flat (Encoding, NumBits, eBits) +#if MIN_VERSION_base(4,15,0) +import GHC.Num.Integer (Integer (..)) +#endif +import GHC.Types (Int (..)) import NoThunks.Class (NoThunks) import Prettyprinter (viaShow) @@ -104,6 +110,7 @@ data DefaultFun | HeadList | TailList | NullList + | DropList -- Data -- See Note [Pattern matching on built-in types]. -- It is convenient to have a "choosing" function for a data type that has more than two @@ -1557,6 +1564,30 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where nullListDenotation (runCostingFunOneArgument . paramNullList) + toBuiltinMeaning _semvar DropList = + let dropListDenotation :: Integer -> SomeConstant uni [a] -> BuiltinResult (Opaque val [a]) + dropListDenotation i (SomeConstant (Some (ValueOf uniListA xs))) = do + -- See Note [Operational vs structural errors within builtins]. + case uniListA of + DefaultUniList _ -> +#if MIN_VERSION_base(4,15,0) + fromValueOf uniListA <$> case i of + IS i# -> pure $ drop (I# i#) xs + IP _ -> case drop maxBound xs of + [] -> pure [] + _ -> + throwing _StructuralUnliftingError + "Panic: unreachable clause executed" + IN _ -> pure xs +#else + throwing _StructuralUnliftingError "'dropList' is not supported on GHC-8.10" +#endif + _ -> throwing _StructuralUnliftingError "Expected a list but got something else" + {-# INLINE dropListDenotation #-} + in makeBuiltinMeaning + dropListDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + -- Data toBuiltinMeaning _semvar ChooseData = let chooseDataDenotation :: Data -> a -> a -> a -> a -> a -> a @@ -2187,6 +2218,8 @@ instance Flat DefaultFun where CaseList -> 88 CaseData -> 89 + DropList -> 90 + decode = go =<< decodeBuiltin where go 0 = pure AddInteger go 1 = pure SubtractInteger @@ -2278,6 +2311,7 @@ instance Flat DefaultFun where go 87 = pure ExpModInteger go 88 = pure CaseList go 89 = pure CaseData + go 90 = pure DropList go t = fail $ "Failed to decode builtin tag, got: " ++ show t size _ n = n + builtinTagWidth diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/DropList.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/DropList.plc.golden new file mode 100644 index 00000000000..bca92b3691c --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/DropList.plc.golden @@ -0,0 +1 @@ +all a. integer -> list a -> list a \ No newline at end of file diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs index 4ac4920d046..40e1f8b1b2c 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs @@ -146,3 +146,4 @@ isCommutative = \case CountSetBits -> False FindFirstSetBit -> False ExpModInteger -> False + DropList -> False diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index 45c38ef1e3e..72669c85af8 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -128,7 +128,8 @@ builtinsIntroducedIn = Map.fromList [ ]), ((PlutusV3, futurePV), Set.fromList [ ExpModInteger, - CaseList, CaseData + CaseList, CaseData, + DropList ]) ] diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index e2eb7bb93e6..18b367fad87 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -234,6 +234,7 @@ builtinNames = [ , 'Builtins.mkNilData , 'Builtins.mkNilPairData , 'Builtins.mkCons + , 'Builtins.drop , ''Builtins.BuiltinData , 'Builtins.chooseData @@ -413,6 +414,7 @@ defineBuiltinTerms = do PLC.MkNilData -> defineBuiltinInl 'Builtins.mkNilData PLC.MkNilPairData -> defineBuiltinInl 'Builtins.mkNilPairData PLC.MkCons -> defineBuiltinInl 'Builtins.mkCons + PLC.DropList -> defineBuiltinInl 'Builtins.drop -- Data PLC.ChooseData -> defineBuiltinInl 'Builtins.chooseData diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 85318041b47..af8022cbdb8 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -82,6 +82,7 @@ module PlutusTx.Builtins ( , headMaybe , BI.head , BI.tail + , BI.drop , uncons , unsafeUncons -- * Tracing diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index a9d575fd300..c938c228040 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -29,6 +29,7 @@ import Data.Data (Data) import Data.Foldable qualified as Foldable import Data.Hashable (Hashable (..)) import Data.Kind (Type) +import Data.List qualified as Haskell import Data.Text as Text (Text, empty) import Data.Text.Encoding as Text (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) @@ -408,6 +409,10 @@ chooseList :: BuiltinList a -> b -> b -> b chooseList (BuiltinList []) b1 _ = b1 chooseList (BuiltinList (_:_)) _ b2 = b2 +{-# OPAQUE drop #-} +drop :: Integer -> BuiltinList a -> BuiltinList a +drop i (BuiltinList xs) = BuiltinList (Haskell.genericDrop i xs) + {-# OPAQUE caseList' #-} caseList' :: forall a r . r -> (a -> BuiltinList a -> r) -> BuiltinList a -> r caseList' nilCase _ (BuiltinList []) = nilCase diff --git a/scripts/ci-plutus-benchmark.sh b/scripts/ci-plutus-benchmark.sh index a5f96136ab2..3ef1cdba1f8 100755 --- a/scripts/ci-plutus-benchmark.sh +++ b/scripts/ci-plutus-benchmark.sh @@ -10,14 +10,18 @@ # This script can also be run locally inside the nix shell like so: # `BENCHMARK_NAME=nofib ./scripts/ci-plutus-benchmark.sh` # +# # NOTES: # The `cabal update` command below is neccessary because while the whole script is executed inside # a nix shell, this environment does not provide the hackage record inside .cabal and we have to # fetch/build this each time since we want to run this in a clean environment. # The `jq` invocation below is necessary because we have to POST the PR comment as JSON data # (see the curl command) meaning the script output has to be escaped first before we can insert it. +# Also note the use of the envvar CAPABILITY_NUM and `taskset -c` to limit +# the benchmark to a single core. Experiments have shown that this can lead to more stable results. +# This is only available on linux. -set -e +set -ex if [ -z "$BENCHMARK_NAME" ] ; then echo "[ci-plutus-benchmark]: 'BENCHMARK_NAME' is not set, exiting." @@ -36,6 +40,13 @@ else git checkout "$PR_BRANCH" fi +if [ -z "$CAPABILITY_NUM" ] ; then + echo "[ci-plutus-benchmark]: 'CAPABILITY_NUM' is not set, will default to 2" + CAPABILITY_NUM=2 +else + echo "[ci-plutus-benchmark]: 'CAPABILITY_NUM' set to $CAPABILITY_NUM" +fi + PR_BRANCH_REF="$(git rev-parse --short HEAD)" if [ -z "$(git merge-base HEAD origin/master)" ]; then @@ -55,8 +66,14 @@ cabal update echo "[ci-plutus-benchmark]: Clearing caches with cabal clean ..." cabal clean +if ! which taskset; then + TASKSET="" +else + TASKSET="taskset -c $CAPABILITY_NUM" +fi + echo "[ci-plutus-benchmark]: Running benchmark for PR branch at $PR_BRANCH_REF ..." -2>&1 cabal bench "$BENCHMARK_NAME" | tee bench-PR.log +2>&1 $TASKSET cabal bench "$BENCHMARK_NAME" | tee bench-PR.log echo "[ci-plutus-benchmark]: Switching branches ..." git checkout "$(git merge-base HEAD origin/master)" @@ -66,7 +83,7 @@ echo "[ci-plutus-benchmark]: Clearing caches with cabal clean ..." cabal clean echo "[ci-plutus-benchmark]: Running benchmark for base branch at $BASE_BRANCH_REF ..." -2>&1 cabal bench "$BENCHMARK_NAME" | tee bench-base.log +2>&1 $TASKSET cabal bench "$BENCHMARK_NAME" | tee bench-base.log git checkout "$PR_BRANCH_REF" # .. so we use the most recent version of the comparison script echo "[ci-plutus-benchmark]: Comparing results ..."