Merge pull request #477 from tweag/tbagrel1/quicksort-perf-bench

Add Quicksort benchmark and export benchmark results as an artifact

.github/workflows/ci.yaml

@@ -33,13 +33,24 @@ jobs:
     - name: Update Cabal's database
       run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal update"
     - name: Build Cabal's dependencies
-      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build --allow-newer --disable-tests --disable-benchmarks --dependencies-only"
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build --dependencies-only"
     - name: Build
-      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build --allow-newer --disable-tests --disable-benchmarks"
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build"
     - name: Haddock
-      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal --allow-newer haddock"
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal haddock"
     - name: cabal-docspec
-      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run cabal-docspec
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal-docspec"
+    - name: Build benchmarks
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build linear-base:bench:bench"
+    - name: Run benchmarks
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal bench 2>&1 | tee benchmark_ghc${{ matrix.ghc-version }}.txt"
+    - name: Upload benchmark results
+      uses: actions/upload-artifact@v3
+      with:
+        name: linear-base_benchmarks_ghc${{ matrix.ghc-version }}
+        path: |
+          benchmark_ghc${{ matrix.ghc-version }}.txt
+        retention-days: 90
 
   ormolu:
     name: check formatting with ormolu

bench/Data/Mutable/Quicksort.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NumericUnderscores #-}
+
+module Data.Mutable.Quicksort (benchmarks) where
+
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Data.List (sort)
+import Simple.Quicksort (quicksortUsingArray, quicksortUsingList)
+import System.Random
+import Test.Tasty.Bench
+
+-- Follows thread from https://discourse.haskell.org/t/linear-haskell-quicksort-performance/10280
+
+gen :: StdGen
+gen = mkStdGen 4541645642
+
+randomListBuilder :: Int -> IO [Int]
+randomListBuilder size = evaluate $ force $ take size (randoms gen :: [Int])
+
+sizes :: [Int]
+sizes = [1_000, 50_000, 1_000_000]
+
+benchmarks :: Benchmark
+benchmarks =
+  bgroup
+    "quicksort"
+    ( ( \size ->
+          env (randomListBuilder size) $ \randomList ->
+            bgroup
+              ("size " ++ (show size))
+              [ bench "quicksortUsingArray" $
+                  nf quicksortUsingArray randomList,
+                bench "quicksortUsingList" $
+                  nf quicksortUsingList randomList,
+                bench "sortStdLib" $
+                  nf sort randomList
+              ]
+      )
+        <$> sizes
+    )

bench/Main.hs

@@ -2,11 +2,13 @@ module Main where
 
 import qualified Data.Mutable.Array as Array
 import qualified Data.Mutable.HashMap as HashMap
+import qualified Data.Mutable.Quicksort as Quicksort
 import Test.Tasty.Bench (defaultMain)
 
 main :: IO ()
 main = do
   defaultMain
     [ Array.benchmarks,
-      HashMap.benchmarks
+      HashMap.benchmarks,
+      Quicksort.benchmarks
     ]

cabal.project

@@ -1 +1,6 @@
 packages: *.cabal
+
+tests: True
+benchmarks: True
+allow-newer: all
+index-state: 2024-09-13T13:31:57Z

examples/Simple/Quicksort.hs

@@ -1,6 +1,10 @@
 {-# LANGUAGE LinearTypes #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
+-- Uncomment the line below to observe the generated (optimised) Core. It will
+-- land in a file named “Quicksort.dump-simpl”
+-- {-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all -dsuppress-uniques #-}
+
 -- | This module implements quicksort with mutable arrays from linear-base
 module Simple.Quicksort where
 
@@ -13,15 +17,22 @@ import Prelude.Linear hiding (partition)
 -- # Quicksort
 -------------------------------------------------------------------------------
 
-quickSort :: [Int] -> [Int]
-quickSort xs = unur $ Array.fromList xs $ Array.toList . arrQuicksort
+quicksortUsingList :: (Ord a) => [a] -> [a]
+quicksortUsingList [] = []
+quicksortUsingList (x : xs) = quicksortUsingList ltx ++ x : quicksortUsingList gex
+  where
+    ltx = [y | y <- xs, y < x]
+    gex = [y | y <- xs, y >= x]
+
+quicksortUsingArray :: (Ord a) => [a] -> [a]
+quicksortUsingArray xs = unur $ Array.fromList xs $ Array.toList . quicksortArray
 
-arrQuicksort :: Array Int %1 -> Array Int
-arrQuicksort arr =
+quicksortArray :: (Ord a) => Array a %1 -> Array a
+quicksortArray arr =
   Array.size arr
     & \(Ur len, arr1) -> go 0 (len - 1) arr1
 
-go :: Int -> Int -> Array Int %1 -> Array Int
+go :: (Ord a) => Int -> Int -> Array a %1 -> Array a
 go lo hi arr
   | lo >= hi = arr
   | otherwise =
@@ -39,23 +50,23 @@ go lo hi arr
 -- @arr'[j] > pivot@ for @ix < j <= hi@,
 -- @arr'[k] = arr[k]@ for @k < lo@ and @k > hi@, and
 -- @arr'@ is a permutation of @arr@.
-partition :: Array Int %1 -> Int -> Int -> Int -> (Array Int, Ur Int)
-partition arr pivot lx rx
-  | (rx < lx) = (arr, Ur (lx - 1))
+partition :: (Ord a) => Array a %1 -> a -> Int -> Int -> (Array a, Ur Int)
+partition arr pivot lo hi
+  | (hi < lo) = (arr, Ur (lo - 1))
   | otherwise =
-      Array.read arr lx
+      Array.read arr lo
         & \(Ur lVal, arr1) ->
-          Array.read arr1 rx
+          Array.read arr1 hi
             & \(Ur rVal, arr2) -> case (lVal <= pivot, pivot < rVal) of
-              (True, True) -> partition arr2 pivot (lx + 1) (rx - 1)
-              (True, False) -> partition arr2 pivot (lx + 1) rx
-              (False, True) -> partition arr2 pivot lx (rx - 1)
+              (True, True) -> partition arr2 pivot (lo + 1) (hi - 1)
+              (True, False) -> partition arr2 pivot (lo + 1) hi
+              (False, True) -> partition arr2 pivot lo (hi - 1)
               (False, False) ->
-                swap arr2 lx rx
-                  & \arr3 -> partition arr3 pivot (lx + 1) (rx - 1)
+                swap arr2 lo hi
+                  & \arr3 -> partition arr3 pivot (lo + 1) (hi - 1)
 
 -- | @swap a i j@ exchanges the positions of values at @i@ and @j@ of @a@.
-swap :: (HasCallStack) => Array Int %1 -> Int -> Int -> Array Int
+swap :: (HasCallStack) => Array a %1 -> Int -> Int -> Array a
 swap arr i j =
   Array.read arr i
     & \(Ur ival, arr1) ->

linear-base.cabal

@@ -219,6 +219,7 @@ benchmark bench
     other-modules:
         Data.Mutable.HashMap
         Data.Mutable.Array
+        Data.Mutable.Quicksort
     default-language: Haskell2010
     build-depends:
         base,

test-examples/Main.hs

@@ -1,7 +1,7 @@
 module Main where
 
 import Test.Foreign (foreignGCTests)
-import Test.Simple.Quicksort (quickSortTests)
+import Test.Simple.Quicksort (quicksortTests)
 import Test.Tasty
 
 main :: IO ()
@@ -12,5 +12,5 @@ allTests =
   testGroup
     "All tests"
     [ foreignGCTests,
-      quickSortTests
+      quicksortTests
     ]

test-examples/Test/Simple/Quicksort.hs

@@ -1,19 +1,29 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Test.Simple.Quicksort (quickSortTests) where
+module Test.Simple.Quicksort (quicksortTests) where
 
 import Data.List (sort)
 import Hedgehog
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
-import Simple.Quicksort (quickSort)
+import Simple.Quicksort (quicksortUsingArray, quicksortUsingList)
 import Test.Tasty
 import Test.Tasty.Hedgehog (testPropertyNamed)
 
-quickSortTests :: TestTree
-quickSortTests = testPropertyNamed "quicksort sorts" "testQuicksort" testQuicksort
+quicksortTests :: TestTree
+quicksortTests =
+  testGroup
+    "quicksort tests"
+    [ testPropertyNamed "sort xs === quicksortUsingArray xs" "testQuicksortUsingArray" testQuicksortUsingArray,
+      testPropertyNamed "sort xs === quicksortUsingList xs" "testQuicksortUsingList" testQuicksortUsingList
+    ]
 
-testQuicksort :: Property
-testQuicksort = property $ do
+testQuicksortUsingArray :: Property
+testQuicksortUsingArray = property $ do
   xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100)
-  sort xs === quickSort xs
+  sort xs === quicksortUsingArray xs
+
+testQuicksortUsingList :: Property
+testQuicksortUsingList = property $ do
+  xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int $ Range.linear 0 100)
+  sort xs === quicksortUsingList xs