rollback some of the splitting in the hope to get allocations back under control but to no avail

Author: ulysses4ever

benchrunner/Benchrunner.hs

@@ -5,15 +5,71 @@ 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
 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)

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

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 #-}