[Builtins] Add the 'dropList' builtin

.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 }}
 

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

plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/DropList.plc.golden

@@ -0,0 +1 @@
+all a. integer -> list a -> list a

plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs

@@ -146,3 +146,4 @@ isCommutative = \case
   CountSetBits                    -> False
   FindFirstSetBit                 -> False
   ExpModInteger           -> False
+  DropList -> False

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
           ])
   ]
 

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

plutus-tx/src/PlutusTx/Builtins.hs

@@ -82,6 +82,7 @@ module PlutusTx.Builtins (
                          , headMaybe
                          , BI.head
                          , BI.tail
+                         , BI.drop
                          , uncons
                          , unsafeUncons
                          -- * Tracing

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

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 ..."