Add shift builtin (fix #4168).

plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs

@@ -26,6 +26,7 @@ import           PlutusCore.Evaluation.Result
 import           PlutusCore.Pretty
 
 import           Crypto
+import qualified Data.Bits                                      as Bits
 import qualified Data.ByteString                                as BS
 import qualified Data.ByteString.Hash                           as Hash
 import           Data.Char
@@ -51,6 +52,7 @@ data DefaultFun
     | EqualsInteger
     | LessThanInteger
     | LessThanEqualsInteger
+    | ShiftInteger
     -- Bytestrings
     | AppendByteString
     | ConsByteString
@@ -178,6 +180,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
         makeBuiltinMeaning
             ((<=) @Integer)
             (runCostingFunTwoArguments . paramLessThanEqualsInteger)
+    toBuiltinMeaning ShiftInteger =
+        makeBuiltinMeaning
+            (\x i -> Bits.shift @Integer x (fromIntegral @Integer i))
+            mempty -- TODO: add costing for ShiftInteger
     -- Bytestrings
     toBuiltinMeaning AppendByteString =
         makeBuiltinMeaning
@@ -502,6 +508,8 @@ instance Flat DefaultFun where
               MkNilData                -> 49
               MkNilPairData            -> 50
 
+              ShiftInteger             -> 51
+
     decode = go =<< decodeBuiltin
         where go 0  = pure AddInteger
               go 1  = pure SubtractInteger
@@ -554,6 +562,7 @@ instance Flat DefaultFun where
               go 48 = pure MkPairData
               go 49 = pure MkNilData
               go 50 = pure MkNilPairData
+              go 51 = pure ShiftInteger
               go t  = fail $ "Failed to decode builtin tag, got: " ++ show t
 
     size _ n = n + builtinTagWidth

plutus-core/plutus-core/test/TypeSynthesis/Golden/ShiftInteger.plc.golden

@@ -0,0 +1 @@
+(fun (con integer) (fun (con integer) (con integer)))

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs

@@ -343,6 +343,9 @@ test_Integer = testCase "Integer" $ do
     evals False LessThanEqualsInteger [cons @Integer 4001, cons @Integer 4000]
     evals True EqualsInteger [cons @Integer (-101), cons @Integer (-101)]
     evals False EqualsInteger [cons @Integer 0, cons @Integer 1]
+    evals @Integer 24 ShiftInteger [cons @Integer 3, cons @Integer 3]
+    evals @Integer 0 ShiftInteger [cons @Integer 3, cons @Integer (-3)]
+    evals @Integer (-2) ShiftInteger [cons @Integer (-3), cons @Integer (-1)]
 
 -- | Test all string-like builtins
 test_String :: TestTree

plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs

@@ -186,6 +186,7 @@ builtinNames = [
     , 'Builtins.lessThanInteger
     , 'Builtins.lessThanEqualsInteger
     , 'Builtins.equalsInteger
+    , 'Builtins.shiftInteger
 
     , 'Builtins.error
 
@@ -305,6 +306,7 @@ defineBuiltinTerms = do
     defineBuiltinTerm 'Builtins.lessThanInteger $ mkBuiltin PLC.LessThanInteger
     defineBuiltinTerm 'Builtins.lessThanEqualsInteger $ mkBuiltin PLC.LessThanEqualsInteger
     defineBuiltinTerm 'Builtins.equalsInteger $ mkBuiltin PLC.EqualsInteger
+    defineBuiltinTerm 'Builtins.shiftInteger $ mkBuiltin PLC.ShiftInteger
 
     -- Error
     -- See Note [Delaying error]

plutus-tx/src/PlutusTx/Builtins.hs

@@ -35,6 +35,7 @@ module PlutusTx.Builtins (
                                 , lessThanInteger
                                 , lessThanEqualsInteger
                                 , equalsInteger
+                                , shiftInteger
                                 -- * Error
                                 , error
                                 -- * Data
@@ -217,6 +218,15 @@ lessThanEqualsInteger x y = fromBuiltin (BI.lessThanEqualsInteger (toBuiltin x)
 equalsInteger :: Integer -> Integer -> Bool
 equalsInteger x y = fromBuiltin (BI.equalsInteger (toBuiltin x) (toBuiltin y))
 
+{-# INLINABLE shiftInteger #-}
+{-| @'shiftInteger' x i@ shifts @x@ left by @i@ bits if @i@ is positive,
+    or right by @-i@ bits otherwise.
+    Right shifts perform sign extension on signed number types;
+    i.e. they fill the top bits with 1 if the @x@ is negative
+    and with 0 otherwise. -}
+shiftInteger :: Integer -> Integer -> Integer
+shiftInteger x y = fromBuiltin (BI.shiftInteger (toBuiltin x) (toBuiltin y))
+
 {-# INLINABLE error #-}
 -- | Aborts evaluation with an error.
 error :: () -> a

plutus-tx/src/PlutusTx/Builtins/Internal.hs

@@ -15,6 +15,7 @@ module PlutusTx.Builtins.Internal where
 import           Codec.Serialise
 import           Control.DeepSeq      (NFData)
 import qualified Crypto
+import qualified Data.Bits            as Bits
 import qualified Data.ByteArray       as BA
 import           Data.ByteString      as BS
 import qualified Data.ByteString.Hash as Hash
@@ -143,6 +144,10 @@ lessThanEqualsInteger = coerce ((<=) @Integer)
 equalsInteger :: BuiltinInteger -> BuiltinInteger -> BuiltinBool
 equalsInteger = coerce ((==) @Integer)
 
+{-# NOINLINE shiftInteger #-}
+shiftInteger :: BuiltinInteger -> BuiltinInteger -> BuiltinInteger
+shiftInteger x i = Bits.shift @Integer x (fromIntegral @Integer i)
+
 {-
 BYTESTRING
 -}