From 47929b6bb94f8345a46e1038249417eb33fe129b Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Fri, 21 Mar 2025 22:31:38 -0400 Subject: [PATCH 1/2] benchrunner: don't pre-allocate all arrays at once (fix #41) --- benchrunner/Benchrunner.hs | 128 +++------------------------------- benchrunner/Input.hs | 80 +++++++++++++++++++++ benchrunner/MVector.hs | 9 +++ benchrunner/Measure.hs | 83 ++++++++++------------ benchrunner/Sort.hs | 71 +++++++++++++++++++ benchrunner/Types.hs | 42 ----------- benchrunner/Utils.hs | 63 +++++++++++++++++ benchrunner/Vector.hs | 9 +++ benchrunner/benchrunner.cabal | 6 +- src/Array/Mutable.hs | 6 +- 10 files changed, 283 insertions(+), 214 deletions(-) create mode 100644 benchrunner/Input.hs create mode 100644 benchrunner/MVector.hs create mode 100644 benchrunner/Sort.hs delete mode 100644 benchrunner/Types.hs create mode 100644 benchrunner/Utils.hs create mode 100644 benchrunner/Vector.hs diff --git a/benchrunner/Benchrunner.hs b/benchrunner/Benchrunner.hs index adcccb0..f8bbaf5 100644 --- a/benchrunner/Benchrunner.hs +++ b/benchrunner/Benchrunner.hs @@ -2,129 +2,18 @@ module Main where -import Data.Int ( Int64 ) -import System.Random ( Random, newStdGen, randoms ) -import Data.Proxy ( Proxy(..) ) -import Control.DeepSeq ( NFData, force ) import Data.List.Split ( splitOn ) import System.Environment ( getArgs ) -import Control.Monad ( unless, replicateM ) -import Text.Read -import Linear.Common -import Types as T +import Control.Monad ( unless ) -import qualified Data.Primitive.Types as P +import qualified Array as A +import qualified Vector as V +import Input import qualified Measure as M -import qualified Insertion as I -import qualified QuickSort as Q -import qualified DpsMergeSort4 as DMS -import qualified DpsMergeSort4Par as DMSP -import qualified PiecewiseFallbackSort as PFS -import qualified PiecewiseFallbackSortPar as PFSP +import Sort +import Utils import qualified Microbench as MB -import qualified Array as A -import qualified Data.Vector.Unboxed as V -import qualified Data.Vector.Algorithms.Insertion as ISDVS -import qualified Data.Vector.Algorithms.Merge as MSDVS -import qualified Data.Vector.Algorithms.Intro as QSDVS - --------------------------------------------------------------------------------- - -getInput :: Benchmark -> Maybe Int -> IO (Input Int64) -getInput bench mb_size = case bench of - GenerateArray -> pure $ IntIn (mb 10000000) - FillArray -> pure $ EltsIn (mb 10000000) 1024 - CopyArray -> pure $ ArrayIn (A.make (mb 10000000) 1) - SumArray -> pure $ ArrayIn (A.make (mb 10000000) 1) - Fib -> pure $ IntIn (mb 45) - OurSort alg -> case alg of - Insertionsort -> ArrayIn <$> randArray (Proxy :: Proxy Int64) (mb 100) - Quicksort -> ArrayIn <$> randArray (Proxy :: Proxy Int64) (mb 1000000) - Mergesort -> ArrayIn <$> randArray (Proxy :: Proxy Int64) (mb 8000000) - Optsort -> ArrayIn <$> randArray (Proxy :: Proxy Int64) (mb 8000000) - _ -> error "getInput: Unexpected Input!" - where - mb x = case mb_size of - Nothing -> x - Just y -> y - -getInputAsDataVector :: SortAlgo -> Maybe Int -> IO Vec -getInputAsDataVector bench mb_size = case bench of - Insertionsort -> V.fromList <$> randList (Proxy :: Proxy Int64) (mb 100) - Quicksort -> V.fromList <$> randList (Proxy :: Proxy Int64) (mb 1000000) - Mergesort -> V.fromList <$> randList (Proxy :: Proxy Int64) (mb 8000000) - _ -> error "getInputAsDataVector: TODO sort function not implemented!" - where - mb x = case mb_size of - Nothing -> x - Just y -> y - -getInputAsList :: SortAlgo -> Maybe Int -> IO [Int64] -getInputAsList bench mb_size = case bench of - Insertionsort -> randList (Proxy :: Proxy Int64) (mb 100) - Quicksort -> randList (Proxy :: Proxy Int64) (mb 1000000) - Mergesort -> randList (Proxy :: Proxy Int64) (mb 8000000) - _ -> error "getInputAsDataVector: TODO sort function not implemented!" - where - mb x = case mb_size of - Nothing -> x - Just y -> y - -copyInput :: (Input Int64) -> IO (Input Int64) -copyInput i = case i of - ArrayIn arr -> pure $ ArrayIn (A.copy arr 0 (A.make (A.size arr) (A.get arr 0)) 0 (A.size arr)) - _ -> error "TODO: copyInput not implemented!" - -copyInputIterTimes :: Input Int64 -> Int -> IO [A.Array Int64] -copyInputIterTimes inp iters = do - copiedInputs <- replicateM iters (copyInput inp) - return [arr | ArrayIn arr <- copiedInputs] -randArray :: forall a. (Random a, NFData a, P.Prim a) => Proxy a -> Int -> IO (A.Array a) -randArray _ty size = do - rng <- newStdGen - let ls :: [a] - ls = take size $ randoms rng - !arr = force (A.fromList ls) - pure arr - -randList :: forall a. (Random a, NFData a) => Proxy a -> Int -> IO [a] -randList _ty size = do - rng <- newStdGen - let ls :: [a] - ls = take size $ randoms rng - pure (force ls) - -sortFn :: (Show a, A.HasPrimOrd a, NFData a) => SortAlgo -> ParOrSeq -> (A.Array a -. A.Array a) -sortFn bench parorseq = case (bench,parorseq) of - (Insertionsort, Seq) -> I.isort_top' - (Quicksort, Seq) -> Q.quickSort' - (Mergesort, Seq) -> DMS.msort - (Mergesort, Par) -> DMSP.msort - (Optsort, Seq) -> PFS.pfsort - (Optsort, Par) -> PFSP.pfsort - oth -> error $ "sortFn: unknown configuration: " ++ show oth - -vectorSortFn :: SortAlgo -> ParOrSeq -> VecSort -vectorSortFn bench parorseq = case (bench,parorseq) of - (Insertionsort, Seq) -> ISDVS.sort - (Mergesort, Seq) -> MSDVS.sort - (Quicksort, Seq) -> QSDVS.sort - oth -> error $ "sortFn: unknown configuration: " ++ show oth - --------------------------------------------------------------------------------- - -isSorted :: Ord a => [a] -> Bool -isSorted [] = True -isSorted [_] = True -isSorted (x:y:xs) = x <= y && isSorted (y:xs) - -readBench :: String -> Benchmark -readBench s = case readMaybe s of - Just b -> b - Nothing -> case readMaybe s of - Just srt -> OurSort srt - Nothing -> read s -- dobench :: Benchmark -> ParOrSeq -> Maybe Int -> IO () dobench :: Benchmark -> ParOrSeq -> Maybe Int -> Int -> IO () @@ -204,11 +93,10 @@ dobench bench parorseq mb_size iters = do putStrLn "Sorted: OK" pure (V.length inPutVec, V.length res0, tmed0, tall0) OurSort alg -> do - ArrayIn arr <- getInput bench mb_size - arrs <- copyInputIterTimes (ArrayIn arr) iters + (ArrayIn arr) <- getInput bench mb_size let fn = sortFn alg parorseq putStrLn $ "array size = " ++ show (A.size arr) - (res0, tmed0, tall0) <- M.benchOnArrays fn arrs + (res0, tmed0, tall0) <- M.benchOnArrays fn arr iters unless (isSorted (A.toList res0)) (error $ show bench ++ ": result not sorted.") putStrLn "Sorted: OK" pure (A.size arr, A.size res0, tmed0, tall0) diff --git a/benchrunner/Input.hs b/benchrunner/Input.hs new file mode 100644 index 0000000..7eb840e --- /dev/null +++ b/benchrunner/Input.hs @@ -0,0 +1,80 @@ +-- | Benchmarks and inputs + +module Input where + +import Sort +import Utils + +import qualified Array as A +import qualified Vector as V + +import Data.Proxy (Proxy (..)) +import Data.Int (Int64) +import Text.Read + +data Benchmark + = GenerateArray + | FillArray + | CopyArray + | SumArray + | Fib + | OurSort SortAlgo + | VectorSort SortAlgo + | CSort SortAlgo + | CxxSort SortAlgo + deriving (Eq, Show, Read) + +readBench :: String -> Benchmark +readBench s = case readMaybe s of + Just b -> b + Nothing -> case readMaybe s of + Just srt -> OurSort srt + Nothing -> read s + +data Input a + = EltsIn + Int {- number of elements -} + a {- element -} + | ArrayIn (A.Array a) + | IntIn Int + deriving Show + +getInput :: Benchmark -> Maybe Int -> IO (Input Int64) +getInput bench mb_size = case bench of + GenerateArray -> pure $ IntIn (mb 10000000) + FillArray -> pure $ EltsIn (mb 10000000) 1024 + CopyArray -> pure $ ArrayIn (A.make (mb 10000000) 1) + SumArray -> pure $ ArrayIn (A.make (mb 10000000) 1) + Fib -> pure $ IntIn (mb 45) + OurSort alg -> case alg of + Insertionsort -> ArrayIn <$> randArray (Proxy :: Proxy Int64) (mb 100) + Quicksort -> ArrayIn <$> randArray (Proxy :: Proxy Int64) (mb 1000000) + Mergesort -> ArrayIn <$> randArray (Proxy :: Proxy Int64) (mb 8000000) + Optsort -> ArrayIn <$> randArray (Proxy :: Proxy Int64) (mb 8000000) + _ -> error "getInput: Unexpected Input!" + where + mb x = case mb_size of + Nothing -> x + Just y -> y + +getInputAsDataVector :: SortAlgo -> Maybe Int -> IO Vec +getInputAsDataVector bench mb_size = case bench of + Insertionsort -> V.fromList <$> randList (Proxy :: Proxy Int64) (mb 100) + Quicksort -> V.fromList <$> randList (Proxy :: Proxy Int64) (mb 1000000) + Mergesort -> V.fromList <$> randList (Proxy :: Proxy Int64) (mb 8000000) + _ -> error "getInputAsDataVector: TODO sort function not implemented!" + where + mb x = case mb_size of + Nothing -> x + Just y -> y + +getInputAsList :: SortAlgo -> Maybe Int -> IO [Int64] +getInputAsList bench mb_size = case bench of + Insertionsort -> randList (Proxy :: Proxy Int64) (mb 100) + Quicksort -> randList (Proxy :: Proxy Int64) (mb 1000000) + Mergesort -> randList (Proxy :: Proxy Int64) (mb 8000000) + _ -> error "getInputAsDataVector: TODO sort function not implemented!" + where + mb x = case mb_size of + Nothing -> x + Just y -> y diff --git a/benchrunner/MVector.hs b/benchrunner/MVector.hs new file mode 100644 index 0000000..00e3329 --- /dev/null +++ b/benchrunner/MVector.hs @@ -0,0 +1,9 @@ +-- | Reexport of the right kind of mutable vectors + +module MVector + ( + module Data.Vector.Unboxed.Mutable + ) + where + +import Data.Vector.Unboxed.Mutable diff --git a/benchrunner/Measure.hs b/benchrunner/Measure.hs index a50ee8f..67baea4 100644 --- a/benchrunner/Measure.hs +++ b/benchrunner/Measure.hs @@ -1,4 +1,4 @@ -module Measure (benchAndRunCSorts, benchAndRunCxxSorts, benchAndRunDataVecSorts, benchOnArrays, bench, benchPar, dotrialIO, benchIO, benchParIO) where +module Measure where import Control.Exception (evaluate) import Control.Monad.Par hiding (runParIO) @@ -8,20 +8,13 @@ import Data.Int import System.Mem (performMajorGC) import Data.Time.Clock (getCurrentTime, diffUTCTime) -import Foreign as F import qualified Array as A -import Types as T (SortAlgo(..), Vec, VecSort) -import qualified Data.List as L -import qualified Data.Vector.Unboxed as V -import qualified ForeignFunctionImports as FFI -import qualified Data.Vector.Unboxed.Mutable as MV - --------------------------------------------------------------------------------- +import Foreign as F +import Sort +import Utils +import qualified Vector as V +import qualified MVector as MV -median :: [Double] -> Double -median ls = (L.sort ls) !! (length ls `div` 2) - --------------------------------------------------------------------------------- benchPar :: (NFData a, NFData b) => (a -> Par b) -> a -> Int -> IO (b, Double, Double) @@ -57,7 +50,6 @@ benchIO f arg iters = do batchtime = sum times return $! (last results, selftimed, batchtime) - {-# NOINLINE dotrialPar #-} dotrialPar :: (NFData a, NFData b) => (a -> Par b) -> a -> IO (b, Double) @@ -96,24 +88,6 @@ dotrialIO f arg = do -------------------------------------------------------------------------------- -bench :: (NFData a, Show b, NFData b) => (a %p -> b) -> a -> Int -> IO (b, Double, Double) -bench f arg iters = do - let !arg2 = force arg - !tups <- mapM (\_ -> dotrial f arg2) [1..iters] - let (results, times) = unzip tups - let selftimed = median times - batchtime = sum times - return $! (last results, selftimed, batchtime) - -benchOnArrays :: (NFData a, Show b, NFData b, Show a) => (A.Array a %p -> b) -> [A.Array a] -> IO (b, Double, Double) -benchOnArrays f arrArgs = do - let !arg2s = force arrArgs - !tups <- mapM (\arg2' -> dotrial f (force arg2')) arg2s - let (results, times) = unzip tups - let selftimed = median times - batchtime = sum times - return $! (last results, selftimed, batchtime) - {-# NOINLINE dotrial #-} dotrial :: (NFData a, Show b, NFData b) => (a %p -> b) -> a -> IO (b, Double) dotrial f arg = do @@ -125,13 +99,40 @@ dotrial f arg = do putStrLn ("iter time: " ++ show delt) return $! (a,delt) + +bench :: (NFData a, Show b, NFData b) => (a %p -> b) -> a -> Int -> IO (b, Double, Double) +bench f arg iters = do + let !arg2 = force arg + !tups <- mapM (\_ -> dotrial f arg2) [1..iters] + let (results, times) = unzip tups + let selftimed = median times + batchtime = sum times + return $! (last results, selftimed, batchtime) + +benchOnArrays :: + (NFData a, Show b, NFData b, Show a, A.HasPrim a) => + (A.Array a %p -> b) -> A.Array a -> Int -> IO (b, Double, Double) +benchOnArrays f arr iters = do + let go (i, a) + | i == 0 = pure Nothing + | otherwise = do + !b <- copyArrayInplaceIO arr a + res <- dotrial f b + pure $ Just (res, (i - 1, b)) + !tups <- unfoldrM go (iters, A.make (A.size arr) (A.get arr 0)) + + let (results, times) = unzip tups + selftimed = median times + batchtime = sum times + pure (last results, selftimed, batchtime) + benchAndRunDataVecSorts :: VecSort -> Vec -> Int -> IO (Vec, Double, Double) -benchAndRunDataVecSorts sortFn inVec iters = do +benchAndRunDataVecSorts sortfn inVec iters = do !tups <- mapM (\_ -> do mvec <- V.thaw inVec mvecCopy <- MV.new (MV.length mvec) MV.copy mvecCopy mvec - res <- dotrialLocal sortFn mvecCopy + res <- dotrialLocal sortfn mvecCopy pure res ) [1..iters] let (results, times) = unzip tups @@ -150,20 +151,6 @@ benchAndRunDataVecSorts sortFn inVec iters = do arg' <- V.freeze arg return $! (arg', delt) -sortFnC :: SortAlgo -> FFI.SortFn -sortFnC alg = case alg of - Insertionsort -> FFI.c_insertionsort - Mergesort -> FFI.c_mergesort - Quicksort -> FFI.c_quicksort - _ -> error "sortFnC: Csort not implemented!" - -sortFnCxx :: SortAlgo -> FFI.SortFnCxx -sortFnCxx alg = case alg of - Insertionsort -> FFI.cxx_int_insertionsort - Mergesort -> FFI.cxx_int_mergesort - Quicksort -> FFI.cxx_int_quicksort - _ -> error "sortFnCxx: Csort not implemented!" - -- return type : IO ([Int64], Double, Double) -- [Int64]: sorted output array from the last iteration that was run -- Double: median runtime from the iterations that were run (selftimed) diff --git a/benchrunner/Sort.hs b/benchrunner/Sort.hs new file mode 100644 index 0000000..62dfdc4 --- /dev/null +++ b/benchrunner/Sort.hs @@ -0,0 +1,71 @@ +-- | Encode sorting functions as an ADT +module Sort where + +import qualified Insertion as I +import qualified QuickSort as Q +import qualified DpsMergeSort4 as DMS +import qualified DpsMergeSort4Par as DMSP +import qualified PiecewiseFallbackSort as PFS +import qualified PiecewiseFallbackSortPar as PFSP +import qualified Array as A +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Algorithms.Insertion as ISDVS +import qualified Data.Vector.Algorithms.Merge as MSDVS +import qualified Data.Vector.Algorithms.Intro as QSDVS + +import Data.Int (Int64) +import Control.Monad.Primitive (PrimState) + +import qualified Data.Vector.Unboxed.Mutable as MV +import qualified ForeignFunctionImports as FFI +import Control.DeepSeq (NFData) +import Linear.Common + +data ParOrSeq = Seq | Par | ParM + deriving (Eq, Show, Read) + +data SortAlgo + = Insertionsort + | Mergesort + | Quicksort + | Optsort -- piecewise fallback + deriving (Eq, Show, Read) + +type MVec = MV.MVector (PrimState IO) Int64 +type Vec = V.Vector Int64 +type VecSort = MVec -> IO () + +sortFn :: (Show a, A.HasPrimOrd a, NFData a) => SortAlgo -> ParOrSeq -> (A.Array a -. A.Array a) +sortFn bench parorseq = case (bench,parorseq) of + (Insertionsort, Seq) -> I.isort_top' + (Quicksort, Seq) -> Q.quickSort' + (Mergesort, Seq) -> DMS.msort + (Mergesort, Par) -> DMSP.msort + (Optsort, Seq) -> PFS.pfsort + (Optsort, Par) -> PFSP.pfsort + oth -> error $ "sortFn: unknown configuration: " ++ show oth +{-# INLINABLE sortFn #-} + +vectorSortFn :: SortAlgo -> ParOrSeq -> VecSort +vectorSortFn bench parorseq = case (bench,parorseq) of + (Insertionsort, Seq) -> ISDVS.sort + (Mergesort, Seq) -> MSDVS.sort + (Quicksort, Seq) -> QSDVS.sort + oth -> error $ "sortFn: unknown configuration: " ++ show oth +{-# INLINABLE vectorSortFn #-} + +sortFnC :: SortAlgo -> FFI.SortFn +sortFnC alg = case alg of + Insertionsort -> FFI.c_insertionsort + Mergesort -> FFI.c_mergesort + Quicksort -> FFI.c_quicksort + _ -> error "sortFnC: Csort not implemented!" +{-# INLINABLE sortFnC #-} + +sortFnCxx :: SortAlgo -> FFI.SortFnCxx +sortFnCxx alg = case alg of + Insertionsort -> FFI.cxx_int_insertionsort + Mergesort -> FFI.cxx_int_mergesort + Quicksort -> FFI.cxx_int_quicksort + _ -> error "sortFnCxx: Csort not implemented!" +{-# INLINABLE sortFnCxx #-} diff --git a/benchrunner/Types.hs b/benchrunner/Types.hs deleted file mode 100644 index 42e9df6..0000000 --- a/benchrunner/Types.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Types (SortAlgo(..), Benchmark(..), ParOrSeq(..), Input(..), MVec, Vec, VecSort) where - -import Data.Int (Int64) -import Control.Monad.Primitive (PrimState) - -import qualified Array as A -import qualified Data.Vector.Unboxed as V -import qualified Data.Vector.Unboxed.Mutable as MV - -data SortAlgo - = Insertionsort - | Mergesort - | Quicksort - | Optsort -- piecewise fallback - deriving (Eq, Show, Read) - -data Benchmark - = GenerateArray - | FillArray - | CopyArray - | SumArray - | Fib - | OurSort SortAlgo - | VectorSort SortAlgo - | CSort SortAlgo - | CxxSort SortAlgo - deriving (Eq, Show, Read) - -data ParOrSeq = Seq | Par | ParM - deriving (Eq, Show, Read) - -data Input a - = EltsIn - Int {- number of elements -} - a {- element -} - | ArrayIn (A.Array a) - | IntIn Int - deriving Show - -type MVec = MV.MVector (PrimState IO) Int64 -type Vec = V.Vector Int64 -type VecSort = MVec -> IO () diff --git a/benchrunner/Utils.hs b/benchrunner/Utils.hs new file mode 100644 index 0000000..1dd1208 --- /dev/null +++ b/benchrunner/Utils.hs @@ -0,0 +1,63 @@ +-- | Kitchen sink +module Utils where + +import qualified Array as A +import System.Random (Random, randoms, newStdGen) +import Control.DeepSeq (NFData, force) +import qualified Data.Primitive.Types as P +import Data.Proxy (Proxy) +import Control.Monad +import qualified Data.List as L + +-- List utils + +median :: [Double] -> Double +median ls = (L.sort ls) !! (length ls `div` 2) + +-- |See 'Data.List.unfoldr'. This is a monad-friendly version of that. +unfoldrM :: (Monad m) => (a -> m (Maybe (b, a))) -> a -> m [b] +unfoldrM f = go + where + go z = do + x <- f z + case x of + Nothing -> return mzero + Just (x', z') -> do + xs <- go z' + return (return x' `mplus` xs) + +isSorted :: Ord a => [a] -> Bool +isSorted [] = True +isSorted [_] = True +isSorted (x:y:xs) = x <= y && isSorted (y:xs) + +-- Random stuff + +randArray :: forall a. (Random a, NFData a, P.Prim a) => Proxy a -> Int -> IO (A.Array a) +randArray _ty size = do + rng <- newStdGen + let ls :: [a] + ls = take size $ randoms rng + !arr = force (A.fromList ls) + pure arr + +randList :: forall a. (Random a, NFData a) => Proxy a -> Int -> IO [a] +randList _ty size = do + rng <- newStdGen + let ls :: [a] + ls = take size $ randoms rng + pure (force ls) + +-- Array / IO stuff +-- +-- In benchrunner, we don't use the linear part of the Array interface, +-- so, we need means to sequentialize operations to not get into a pickle. +-- The easiest solution is to pretend to do IO. + +copyArrayIO :: A.HasPrim a => A.Array a -> IO (A.Array a) +copyArrayIO arr = pure (A.copy arr 0 (A.make (A.size arr) (A.get arr 0)) 0 (A.size arr)) +{-# NOINLINE copyArrayIO #-} + +copyArrayInplaceIO :: A.HasPrim a => A.Array a -> A.Array a -> IO (A.Array a) +copyArrayInplaceIO src dst = pure (A.copy src 0 dst 0 (A.size src)) +{-# NOINLINE copyArrayInplaceIO #-} diff --git a/benchrunner/Vector.hs b/benchrunner/Vector.hs new file mode 100644 index 0000000..51ca121 --- /dev/null +++ b/benchrunner/Vector.hs @@ -0,0 +1,9 @@ +-- | Reexport of the right kind of vectors + +module Vector + ( + module Data.Vector.Unboxed + ) + where + +import Data.Vector.Unboxed diff --git a/benchrunner/benchrunner.cabal b/benchrunner/benchrunner.cabal index f327a9a..e18358c 100644 --- a/benchrunner/benchrunner.cabal +++ b/benchrunner/benchrunner.cabal @@ -8,7 +8,11 @@ executable benchrunner main-is: Benchrunner.hs other-modules: Measure , ForeignFunctionImports - , Types + , Input + , Sort + , Utils + , Vector + , MVector -- other-extensions: build-depends: base , lh-array-sort diff --git a/src/Array/Mutable.hs b/src/Array/Mutable.hs index 8b7a878..415e74e 100644 --- a/src/Array/Mutable.hs +++ b/src/Array/Mutable.hs @@ -145,10 +145,10 @@ splitAt m = Unsafe.toLinear (\xs -> (slice xs 0 m, slice xs m (size xs))) {-# INLINABLE append #-} -- PRE-CONDITION: the two slices are backed by the same array and should be contiguous. append :: Array a -. Array a -. Array a -append xs ys = +append xs' ys' = let !res = Unsafe.toLinear (\xs -> case xs of - (Array !l1 _r1 !a1) -> Unsafe.toLinear (\ys -> case ys of - (Array _l2 !r2 _a2) -> Array l1 r2 a1)) xs ys + (Array l1 _r1 !a1) -> Unsafe.toLinear (\ys -> case ys of + (Array _l2 !r2 _a2) -> Array l1 r2 a1)) xs' ys' in res -- token xs == token ys From 91a54502e6883798afe66db18fef05701fc78e17 Mon Sep 17 00:00:00 2001 From: Artem Pelenitsyn Date: Mon, 7 Apr 2025 10:15:07 -0400 Subject: [PATCH 2/2] rollback some of the splitting in the hope to get allocations back under control but to no avail --- benchrunner/Benchrunner.hs | 60 ++++++++++++++++++++++++++++++++++++-- benchrunner/Measure.hs | 19 ++++++------ benchrunner/Sort.hs | 47 +---------------------------- 3 files changed, 68 insertions(+), 58 deletions(-) diff --git a/benchrunner/Benchrunner.hs b/benchrunner/Benchrunner.hs index f8bbaf5..a3d5914 100644 --- a/benchrunner/Benchrunner.hs +++ b/benchrunner/Benchrunner.hs @@ -5,8 +5,12 @@ module Main where import Data.List.Split ( splitOn ) import System.Environment ( getArgs ) import Control.Monad ( unless ) +import Control.DeepSeq ( NFData ) import qualified Array as A +import Linear.Common + +import ForeignFunctionImports as FFI import qualified Vector as V import Input import qualified Measure as M @@ -14,6 +18,58 @@ import Sort import Utils import qualified Microbench as MB +import qualified Insertion as I +import qualified QuickSort as Q +import qualified DpsMergeSort4 as DMS +import qualified DpsMergeSort4Par as DMSP +import qualified PiecewiseFallbackSort as PFS +import qualified PiecewiseFallbackSortPar as PFSP +import qualified Data.Vector.Algorithms.Insertion as ISDVS +import qualified Data.Vector.Algorithms.Merge as MSDVS +import qualified Data.Vector.Algorithms.Intro as QSDVS + +-- +-- Table of sorting functions +-- + +sortFn :: (Show a, A.HasPrimOrd a, NFData a) => SortAlgo -> ParOrSeq -> (A.Array a -. A.Array a) +sortFn bench parorseq = case (bench,parorseq) of + (Insertionsort, Seq) -> I.isort_top' + (Quicksort, Seq) -> Q.quickSort' + (Mergesort, Seq) -> DMS.msort + (Mergesort, Par) -> DMSP.msort + (Optsort, Seq) -> PFS.pfsort + (Optsort, Par) -> PFSP.pfsort + oth -> error $ "sortFn: unknown configuration: " ++ show oth +{-# INLINABLE sortFn #-} + +vectorSortFn :: SortAlgo -> ParOrSeq -> VecSort +vectorSortFn bench parorseq = case (bench,parorseq) of + (Insertionsort, Seq) -> ISDVS.sort + (Mergesort, Seq) -> MSDVS.sort + (Quicksort, Seq) -> QSDVS.sort + oth -> error $ "sortFn: unknown configuration: " ++ show oth +{-# INLINABLE vectorSortFn #-} + +sortFnC :: SortAlgo -> FFI.SortFn +sortFnC alg = case alg of + Insertionsort -> FFI.c_insertionsort + Mergesort -> FFI.c_mergesort + Quicksort -> FFI.c_quicksort + _ -> error "sortFnC: Csort not implemented!" +{-# INLINABLE sortFnC #-} + +sortFnCxx :: SortAlgo -> FFI.SortFnCxx +sortFnCxx alg = case alg of + Insertionsort -> FFI.cxx_int_insertionsort + Mergesort -> FFI.cxx_int_mergesort + Quicksort -> FFI.cxx_int_quicksort + _ -> error "sortFnCxx: Csort not implemented!" +{-# INLINABLE sortFnCxx #-} + +-- +-- Select which benchmark to run +-- -- dobench :: Benchmark -> ParOrSeq -> Maybe Int -> IO () dobench :: Benchmark -> ParOrSeq -> Maybe Int -> Int -> IO () @@ -102,13 +158,13 @@ dobench bench parorseq mb_size iters = do pure (A.size arr, A.size res0, tmed0, tall0) CSort alg -> do arr <- getInputAsList alg mb_size - (res0, tmed0, tall0) <- M.benchAndRunCSorts alg arr iters + (res0, tmed0, tall0) <- M.benchAndRunCSorts (sortFnC alg) arr iters unless (isSorted (res0)) (error $ show bench ++ ": result not sorted.") putStrLn "Sorted: OK" pure (length arr, length res0, tmed0, tall0) CxxSort alg -> do arr <- getInputAsList alg mb_size - (res0, tmed0, tall0) <- M.benchAndRunCxxSorts alg arr iters + (res0, tmed0, tall0) <- M.benchAndRunCxxSorts (sortFnCxx alg) arr iters unless (isSorted (res0)) (error $ show bench ++ ": result not sorted.") putStrLn "Sorted: OK" pure (length arr, length res0, tmed0, tall0) diff --git a/benchrunner/Measure.hs b/benchrunner/Measure.hs index 67baea4..591c5b4 100644 --- a/benchrunner/Measure.hs +++ b/benchrunner/Measure.hs @@ -10,6 +10,7 @@ import Data.Time.Clock (getCurrentTime, diffUTCTime) import qualified Array as A import Foreign as F +import ForeignFunctionImports as FFI import Sort import Utils import qualified Vector as V @@ -155,11 +156,11 @@ benchAndRunDataVecSorts sortfn inVec iters = do -- [Int64]: sorted output array from the last iteration that was run -- Double: median runtime from the iterations that were run (selftimed) -- Double: Total time taken to run all the iterations (batchtime) -benchAndRunCSorts :: SortAlgo -> [Int64] -> Int -> IO ([Int64], Double, Double) -benchAndRunCSorts salg arr iters = do +benchAndRunCSorts :: FFI.SortFn -> [Int64] -> Int -> IO ([Int64], Double, Double) +benchAndRunCSorts fn arr iters = do !tups <- mapM (\_ -> do !ptr <- newArray arr - res <- dotrialC salg (length arr) ptr + res <- dotrialC fn (length arr) ptr pure res ) [1..iters] let (results, times) = unzip tups @@ -168,9 +169,8 @@ benchAndRunCSorts salg arr iters = do batchtime = sum times return $! (last results, selftimed, batchtime) where - dotrialC alg arrLength ptr = do + dotrialC fn arrLength ptr = do performMajorGC - let fn = sortFnC alg t1 <- getCurrentTime !sortedPtr <- fn ptr (fromIntegral arrLength) (fromIntegral $ F.sizeOf (undefined :: Int64)) t2 <- getCurrentTime @@ -183,11 +183,11 @@ benchAndRunCSorts salg arr iters = do -- [Int64]: sorted output array from the last iteration that was run -- Double: median runtime from the iterations that were run (selftimed) -- Double: Total time taken to run all the iterations (batchtime) -benchAndRunCxxSorts :: SortAlgo -> [Int64] -> Int -> IO ([Int64], Double, Double) -benchAndRunCxxSorts salg arr iters = do +benchAndRunCxxSorts :: FFI.SortFnCxx -> [Int64] -> Int -> IO ([Int64], Double, Double) +benchAndRunCxxSorts fn arr iters = do !tups <- mapM (\_ -> do !ptr <- newArray arr - res <- dotrialCxx salg (length arr) ptr + res <- dotrialCxx fn (length arr) ptr pure res ) [1..iters] let (results, times) = unzip tups @@ -196,9 +196,8 @@ benchAndRunCxxSorts salg arr iters = do batchtime = sum times return $! (last results, selftimed, batchtime) where - dotrialCxx alg arrLength ptr = do + dotrialCxx fn arrLength ptr = do performMajorGC - let fn = sortFnCxx alg t1 <- getCurrentTime !sortedPtr <- fn ptr (fromIntegral arrLength) t2 <- getCurrentTime diff --git a/benchrunner/Sort.hs b/benchrunner/Sort.hs index 62dfdc4..2ee625e 100644 --- a/benchrunner/Sort.hs +++ b/benchrunner/Sort.hs @@ -1,21 +1,10 @@ -- | Encode sorting functions as an ADT module Sort where -import qualified Insertion as I -import qualified QuickSort as Q -import qualified DpsMergeSort4 as DMS -import qualified DpsMergeSort4Par as DMSP -import qualified PiecewiseFallbackSort as PFS -import qualified PiecewiseFallbackSortPar as PFSP -import qualified Array as A -import qualified Data.Vector.Unboxed as V -import qualified Data.Vector.Algorithms.Insertion as ISDVS -import qualified Data.Vector.Algorithms.Merge as MSDVS -import qualified Data.Vector.Algorithms.Intro as QSDVS - import Data.Int (Int64) import Control.Monad.Primitive (PrimState) +import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed.Mutable as MV import qualified ForeignFunctionImports as FFI import Control.DeepSeq (NFData) @@ -35,37 +24,3 @@ type MVec = MV.MVector (PrimState IO) Int64 type Vec = V.Vector Int64 type VecSort = MVec -> IO () -sortFn :: (Show a, A.HasPrimOrd a, NFData a) => SortAlgo -> ParOrSeq -> (A.Array a -. A.Array a) -sortFn bench parorseq = case (bench,parorseq) of - (Insertionsort, Seq) -> I.isort_top' - (Quicksort, Seq) -> Q.quickSort' - (Mergesort, Seq) -> DMS.msort - (Mergesort, Par) -> DMSP.msort - (Optsort, Seq) -> PFS.pfsort - (Optsort, Par) -> PFSP.pfsort - oth -> error $ "sortFn: unknown configuration: " ++ show oth -{-# INLINABLE sortFn #-} - -vectorSortFn :: SortAlgo -> ParOrSeq -> VecSort -vectorSortFn bench parorseq = case (bench,parorseq) of - (Insertionsort, Seq) -> ISDVS.sort - (Mergesort, Seq) -> MSDVS.sort - (Quicksort, Seq) -> QSDVS.sort - oth -> error $ "sortFn: unknown configuration: " ++ show oth -{-# INLINABLE vectorSortFn #-} - -sortFnC :: SortAlgo -> FFI.SortFn -sortFnC alg = case alg of - Insertionsort -> FFI.c_insertionsort - Mergesort -> FFI.c_mergesort - Quicksort -> FFI.c_quicksort - _ -> error "sortFnC: Csort not implemented!" -{-# INLINABLE sortFnC #-} - -sortFnCxx :: SortAlgo -> FFI.SortFnCxx -sortFnCxx alg = case alg of - Insertionsort -> FFI.cxx_int_insertionsort - Mergesort -> FFI.cxx_int_mergesort - Quicksort -> FFI.cxx_int_quicksort - _ -> error "sortFnCxx: Csort not implemented!" -{-# INLINABLE sortFnCxx #-}