8-queens using bitwise primops benchmark (#6311)

* Milestone 3 benchmark, test

* Fix cabal file

* Update writeBits use in NQueens

plutus-benchmark/bitwise/bench/Main.hs

@@ -0,0 +1,26 @@
+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.TH (compile)
+-}
+
+main :: IO ()
+main = print "Pending"
+
+{- Currently not able to run, due to problems with writeBits compiling under PlutusTx
+
+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.30
+-- , plutus-tx-plugin ^>=1.30