Merge branch 'master' of https://github.com/input-output-hk/plutus in…

…to effectfully/test/improve-distribution-of-generated-integers

cabal.project

@@ -92,9 +92,4 @@ constraints:
  -- The API has changed for version 2.2, ledger depends on the old version and ledger will not
  -- be updated until after the Conway release.
  , cardano-crypto-class ^>= 2.1
- -- Later versions have API changes.
- , nothunks ^>= 0.1.5
-
-allow-newer:
- , nothunks:containers
 

plutus-benchmark/bitwise/bench/Main.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main (main) where
+
+import Criterion.Main (bench, defaultMain)
+import PlutusBenchmark.Common (benchProgramCek, mkMostRecentEvalCtx)
+import PlutusBenchmark.NQueens (nqueens)
+import PlutusTx.Code (CompiledCode, getPlcNoAnn)
+import PlutusTx.Plugin ()
+import PlutusTx.TH (compile)
+
+main :: IO ()
+main = defaultMain [
+ bench "8-queens" . benchProgramCek mkMostRecentEvalCtx . getPlcNoAnn $ nqueensCompiled
+ ]
+
+-- Helpers
+
+nqueensCompiled :: CompiledCode [(Integer, Integer)]
+nqueensCompiled = $$(compile [|| nqueens 8 ||])
+

plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens.hs

@@ -0,0 +1,77 @@
+-- editorconfig-checker-disable-file
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module PlutusBenchmark.NQueens (nqueens) where
+
+import PlutusTx.Builtins (replicateByte)
+import PlutusTx.Prelude
+
+-- Based on Qiu, Zongyan (February 2002). "Bit-vector encoding of n-queen problem". ACM SIGPLAN Notices. 37 (2): 68–70
+-- For simplicity, this only accepts multiples of 8 for the dimension (so 8, 16,
+-- 24, etc): in all other cases it will return an empty list. Results are (row,
+-- column) pairs.
+{-# INLINE nqueens #-}
+nqueens :: Integer -> [(Integer, Integer)]
+nqueens dim
+ | dim < 8 = []
+ | dim `remainder` 8 /= 0 = []
+ | otherwise =
+ let down = replicateByte bytesNeeded 0x00
+ left = replicateByte bytesNeeded 0x00
+ right = replicateByte bytesNeeded 0x00
+ in go 0 0 down left right (replicateByte bytesNeeded 0xFF)
+ where
+ bytesNeeded :: Integer
+ bytesNeeded = dim `quotient` 8
+ go ::
+ Integer ->
+ Integer ->
+ BuiltinByteString ->
+ BuiltinByteString ->
+ BuiltinByteString ->
+ BuiltinByteString ->
+ [(Integer, Integer)]
+ go selectIx row down left right control
+ | selectIx == dim = []
+ | otherwise =
+ -- In the original writeup, 0 in a position meant 'occupied'. However,
+ -- this makes updates to the control vectors very annoying, because
+ -- now we have to 'shift in' 1 bits, which costs us an extra two
+ -- copies. We can reduce this by one by instead treating 0 as 'free'.
+ -- Ideally, we would eliminate one more redundant copy, but this
+ -- requires a select0 operation, which can't be implemented
+ -- efficiently. However, given that these copies are per recursive
+ -- call, we can save ourselves considerable effort by avoiding them.
+ let available = selectByteString selectIx control
+ in if
+ | available == (-1) -> []
+ | row == lastRow -> [(row, available)]
+ | otherwise ->
+ let newDown = writeBit down available True
+ newLeft = shiftByteString (writeBit left available True) 1
+ newRight = shiftByteString (writeBit right available True) (-1)
+ newRow = row + 1
+ -- We 'hoist' the control vector as a parameter rather
+ -- than recomputing it every time we modify selectIx.
+ newControl = complementByteString . orByteString False newDown . orByteString False newLeft $ newRight
+ in case go 0 newRow newDown newLeft newRight newControl of
+ [] -> go (selectIx + 1) row down left right control
+ next -> (row, available) : next
+ lastRow :: Integer
+ lastRow = dim - 1
+
+-- Helpers
+
+{-# INLINE selectByteString #-}
+selectByteString :: Integer -> BuiltinByteString -> Integer
+selectByteString which bs
+ | which <= 0 = findFirstSetBit bs
+ | otherwise = let i = selectByteString (which - 1) bs
+ in if i == (-1)
+ then (-1)
+ else i + 1 + findFirstSetBit (shiftByteString bs $ negate (i + 1))
+
+{-# INLINE writeBit #-}
+writeBit :: BuiltinByteString -> Integer -> Bool -> BuiltinByteString
+writeBit bs i b = writeBits bs [i] [b]

plutus-benchmark/bitwise/test/Main.hs

@@ -0,0 +1,12 @@
+module Main (main) where
+
+import PlutusBenchmark.NQueens (nqueens)
+import Test.Tasty (defaultMain, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
+
+main :: IO ()
+main = defaultMain . testGroup "nqueens" $ [
+ testCase "solves for 8 queens" $ assertEqual ""
+ [(0,0), (1,4), (2,7), (3,5), (4,2), (5,6), (6,1), (7,3)]
+ (nqueens 8)
+ ]

plutus-benchmark/plutus-benchmark.cabal

@@ -593,3 +593,35 @@ benchmark marlowe-agda-cek
  , plutus-benchmark-common
  , plutus-ledger-api ^>=1.31
  , plutus-tx ^>=1.31
+
+-------------------- bitwise-----------------------
+
+library bitwise-internal
+ import: lang, ghc-version-support
+ hs-source-dirs: bitwise/src
+ exposed-modules: PlutusBenchmark.NQueens
+ build-depends: plutus-tx ^>=1.31
+
+test-suite bitwise-test
+ import: lang, ghc-version-support
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ hs-source-dirs: bitwise/test
+ build-depends:
+ , base >=4.9 && <5
+ , bitwise-internal
+ , tasty
+ , tasty-hunit
+
+benchmark bitwise-bench
+ import: lang, ghc-version-support
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ hs-source-dirs: bitwise/bench
+ build-depends:
+ , base >=4.9 && <5
+ , bitwise-internal
+ , criterion
+ , plutus-benchmark-common
+ , plutus-tx ^>=1.31
+ , plutus-tx-plugin ^>=1.31

plutus-core/changelog.d/20240726_102834_bezirg_ratinteger.md

@@ -0,0 +1,3 @@
+### Added
+
+- Support for `Natural` numbers in the default universe, backed by `Integer`.

plutus-core/changelog.d/20240726_165736_Yuriy.Lazaryev_nothunks_0_2.md

@@ -0,0 +1,3 @@
+### Changed
+
+- Updated version boundaries for the `nothunks` dependency (^>=0.2)

plutus-core/cost-model/budgeting-bench/Benchmarks/Bitwise.hs

@@ -46,10 +46,6 @@ topBitIndex s = fromIntegral $ 8*(BS.length s)-1
 memoryUsageAsNumBytes :: ExMemoryUsage a => a -> Int
 memoryUsageAsNumBytes = (8*) . fromSatInt . sumCostStream . flattenCostRose . memoryUsage
 
--- An explicit conversion to avoid some type annotations later.
-integerToInt :: Integer -> Int
-integerToInt = fromIntegral
-
 {- Experiments show that the times for big-endian and little-endian
  `byteStringToInteger` conversions are very similar, with big-endian
  conversion perhaps taking a fraction longer. We just generate a costing
@@ -81,7 +77,7 @@ benchIntegerToByteString =
  -- The minimum width of bytestring needed to fit the inputs into.
  widthsInBytes = fmap (fromIntegral . memoryUsageAsNumBytes) inputs
  in createThreeTermBuiltinBenchElementwiseWithWrappers
- (id, NumBytesCostedAsNumWords . integerToInt, id) b [] $
+ (id, NumBytesCostedAsNumWords, id) b [] $
  zip3 (repeat True) widthsInBytes inputs
 
 {- For `andByteString` with different-sized inputs, calling it with extension
@@ -174,7 +170,7 @@ benchReplicateByte =
  -- ^ This gives us replication counts up to 64*128 = 8192, the maximum allowed.
  inputs = pairWith (const (0xFF::Integer)) xs
  in createTwoTermBuiltinBenchElementwiseWithWrappers
- (NumBytesCostedAsNumWords . fromIntegral, id) ReplicateByte [] inputs
+ (NumBytesCostedAsNumWords, id) ReplicateByte [] inputs
 
 {- Benchmarks with varying sizes of bytestrings and varying amounts of shifting
  show that the execution time of `shiftByteString` depends linearly on the

plutus-core/plutus-core.cabal

@@ -318,7 +318,7 @@ library
  , monoidal-containers
  , mtl
  , multiset
- , nothunks ^>=0.1.5
+ , nothunks ^>=0.2
  , parser-combinators >=0.4.0
  , prettyprinter >=1.1.0.1
  , prettyprinter-configurable ^>=1.31

plutus-core/plutus-core/src/PlutusCore/Bitwise.hs

@@ -54,18 +54,14 @@ import GHC.Integer.Logarithms (integerLog2#)
 import GHC.IO.Unsafe (unsafeDupablePerformIO)
 
 {- Note [Input length limitation for IntegerToByteString].
-We make 'integerToByteString' and 'replicateByte' fail if they're called with arguments which would
+We make `integerToByteString` and `replicateByte` fail if they're called with arguments which would
 cause the length of the result to exceed about 8K bytes because the execution time becomes difficult
 to predict accurately beyond this point (benchmarks on a number of different machines show that the
 CPU time increases smoothly for inputs up to about 8K then increases sharply, becoming chaotic after
-about 14K). This restriction may be removed once a more efficient implementation becomes available,
-which may happen when we no longer have to support GHC 8.10.
--}
-
-{- NB: if we do relax the length restriction then we will need two variants of 'integerToByteString'
-and 'replicateByte' in Plutus Core so that we can continue to support the current behaviour for old
-scripts.
--}
+about 14K). This restriction may be removed once a more efficient implementation becomes available,
+which may happen when we no longer have to support GHC 8.10. -}
+{- NB: if we do relax the length restriction then we will need two variants of integerToByteString in
+ Plutus Core so that we can continue to support the current behaviour for old scripts.-}
 maximumOutputLength :: Integer
 maximumOutputLength = 8192
 
@@ -600,18 +596,18 @@ writeBits bs ixs bits = case unsafeDupablePerformIO . try $ go of
 -- | Byte replication, as per [CIP-122](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122)
 -- We want to cautious about the allocation of huge amounts of memory so we
 -- impose the same length limit that's used in integerToByteString.
-replicateByte :: Int -> Word8 -> BuiltinResult ByteString
+replicateByte :: Integer -> Word8 -> BuiltinResult ByteString
 replicateByte len w8
  | len < 0 = do
  emit "replicateByte: negative length requested"
  evaluationFailure
- | toInteger len > maximumOutputLength = do
+ | len > maximumOutputLength = do
  emit . pack $ "replicateByte: requested length is too long (maximum is "
  ++ show maximumOutputLength
  ++ " bytes)"
  emit $ "Length requested: " <> (pack . show $ len)
  evaluationFailure
- | otherwise = pure . BS.replicate len $ w8
+ | otherwise = pure . BS.replicate (fromIntegral len) $ w8
 
 -- | Wrapper for calling 'shiftByteString' safely. Specifically, we avoid various edge cases:
 --

plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs

@@ -38,7 +38,7 @@ instance NoThunks (BuiltinRuntime val) where
  wNoThunks ctx = \case
  -- Unreachable, because we don't allow nullary builtins and the 'BuiltinArrow' case only
  -- checks for WHNF without recursing. Hence we can throw if we reach this clause somehow.
- BuiltinCostedResult _ _ -> pure . Just $ ThunkInfo ctx
+ BuiltinCostedResult _ _ -> pure . Just . ThunkInfo $ Left ctx
  -- This one doesn't do much. It only checks that the function stored in the 'BuiltinArrow'
  -- is in WHNF. The function may contain thunks inside of it. Not sure if it's possible to do
  -- better, since the final 'BuiltinCostedResult' contains a thunk for the result of the

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

@@ -1872,12 +1872,8 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
  toBuiltinMeaning _semvar IntegerToByteString =
  let integerToByteStringDenotation :: Bool -> NumBytesCostedAsNumWords -> Integer -> BuiltinResult BS.ByteString
  {- The second argument is wrapped in a NumBytesCostedAsNumWords to allow us to
- interpret it as a size during costing. Elsewhere we need
- `NumBytesCostedAsNumWords` to contain an `Int` so we re-use that
- here at the cost of not being able to convert an integer to a
- bytestring of length greater than 2^63-1, which we're never going
- to want to do anyway. -}
- integerToByteStringDenotation b (NumBytesCostedAsNumWords w) = Bitwise.integerToByteStringWrapper b $ toInteger w
+ interpret it as a size during costing. -}
+ integerToByteStringDenotation b (NumBytesCostedAsNumWords w) = Bitwise.integerToByteStringWrapper b w
  {-# INLINE integerToByteStringDenotation #-}
  in makeBuiltinMeaning
  integerToByteStringDenotation

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

@@ -489,6 +489,26 @@ deriving newtype instance KnownBuiltinTypeIn DefaultUni term [a] =>
 deriving newtype instance KnownBuiltinTypeIn DefaultUni term [a] =>
  ReadKnownIn DefaultUni term (ListCostedByLength a)
 
+deriving via AsInteger Natural instance
+ KnownTypeAst tyname DefaultUni Natural
+deriving via AsInteger Natural instance HasConstantIn DefaultUni term =>
+ MakeKnownIn DefaultUni term Natural
+instance HasConstantIn DefaultUni term => ReadKnownIn DefaultUni term Natural where
+ readKnown term =
+ -- See Note [Performance of ReadKnownIn and MakeKnownIn instances].
+ -- Funnily, we don't need 'inline' here, unlike in the default implementation of 'readKnown'
+ -- (go figure why).
+ inline readKnownConstant term >>= oneShot \(i :: Integer) ->
+ -- TODO: benchmark alternatives:signumInteger,integerIsNegative,integerToNaturalThrow
+ if i >= 0
+ -- TODO: benchmark alternatives: ghc8.10 naturalFromInteger, ghc>=9 integerToNatural
+ then pure $ fromInteger i
+ else throwing _OperationalUnliftingError . MkUnliftingError $ fold
+ [ Text.pack $ show i
+ , " is not within the bounds of Natural"
+ ]
+ {-# INLINE readKnown #-}
+
 {- Note [Stable encoding of tags]
 'encodeUni' and 'decodeUni' are used for serialisation and deserialisation of types from the
 universe and we need serialised things to be extremely stable, hence the definitions of 'encodeUni'

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemoryUsage.hs

@@ -179,10 +179,14 @@ instance ExMemoryUsage () where
  denotation of a builtin then it *MUST* also be used to wrap the same argument
  in the relevant budgeting benchmark.
 -}
-newtype NumBytesCostedAsNumWords = NumBytesCostedAsNumWords { unNumBytesCostedAsNumWords :: Int }
+newtype NumBytesCostedAsNumWords = NumBytesCostedAsNumWords { unNumBytesCostedAsNumWords :: Integer }
 instance ExMemoryUsage NumBytesCostedAsNumWords where
  memoryUsage (NumBytesCostedAsNumWords n) = singletonRose . fromIntegral $ ((n-1) `div` 8) + 1
  {-# INLINE memoryUsage #-}
+ -- Note that this uses `fromIntegral`, which will narrow large values to
+ -- maxBound::SatInt = 2^63-1. This shouldn't be a problem for costing because no
+ -- realistic input should be that large; however if you're going to use this then be
+ -- sure to convince yourself that it's safe.
 
 {- | A wrapper for `Integer`s whose "memory usage" for costing purposes is the
  absolute value of the `Integer`. This is used for costing built-in functions
@@ -195,6 +199,10 @@ newtype IntegerCostedLiterally = IntegerCostedLiterally { unIntegerCostedLiteral
 instance ExMemoryUsage IntegerCostedLiterally where
  memoryUsage (IntegerCostedLiterally n) = singletonRose . fromIntegral $ abs n
  {-# INLINE memoryUsage #-}
+ -- Note that this uses `fromIntegral`, which will narrow large values to
+ -- maxBound::SatInt = 2^63-1. This shouldn't be a problem for costing because no
+ -- realistic input should be that large; however if you're going to use this then be
+ -- sure to convince yourself that it's safe.
 
 {- | A wrappper for lists whose "memory usage" for costing purposes is just the
  length of the list, ignoring the sizes of the elements. If this is used to
@@ -204,6 +212,10 @@ newtype ListCostedByLength a = ListCostedByLength { unListCostedByLength :: [a]
 instance ExMemoryUsage (ListCostedByLength a) where
  memoryUsage (ListCostedByLength l) = singletonRose . fromIntegral $ length l
  {-# INLINE memoryUsage #-}
+ -- Note that this uses `fromIntegral`, which will narrow large values to
+ -- maxBound::SatInt = 2^63-1. This shouldn't be a problem for costing because no
+ -- realistic input should be that large; however if you're going to use this then be
+ -- sure to convince yourself that it's safe.
 
 -- | Calculate a 'CostingInteger' for the given 'Integer'.
 memoryUsageInteger :: Integer -> CostingInteger