Parallel quicksort in f#

Viewed 280

Playing with quicksort parallelization in f# using Task based parallelism.

I cannot get the parallel code to run faster that sequential. Depth argument to 'quicksortParallel' func takes a depth argument that decides if the recursive call at that 'depth/level' is to be run sequentially or in parallel. The code can be run in sequential manner by passing a negative depth. Sequential run takes around 9 seconds to sort 2 million numbers. Now if i pass in a non-negative (<4) 'depth' value, the time almost remains the same and for 'depth' values (>4) the run time starts increasing again due to cost of parallelizing being more than the gains to be had from parallelizing the code.

What i do not understand is why don't i see a performance gain for depth argument values 0 to 4? I am running it on a 16 logical core Intel i9 CPU. How can i parallelize it?

open System
open System.Threading.Tasks
module myMod =
    let genRandomNums count =
        let rnd = System.Random()
        List.init count (fun _ -> rnd.Next())

    let rec quicksortParallel depth aList =
        match aList with
        | [] -> []
        | firstElement :: restOfList ->
            let smaller, larger =
                List.partition (fun number -> number < firstElement) restOfList
            if depth < 0 then
                let left  = quicksortParallel depth smaller
                let right = quicksortParallel depth larger
                left @ (firstElement :: right)
            else
                let left  = Task.Run(fun () -> quicksortParallel (depth-1) smaller)
                let right = Task.Run(fun () -> quicksortParallel (depth-1) larger)
                Task.WaitAll(left, right)
                left.Result @ (firstElement :: right.Result)
    
    let sampleNumbers = genRandomNums 2000000
    
    let stopWatch = System.Diagnostics.Stopwatch.StartNew()
    //let sortedSnums = quicksortParallel -1 sampleNumbers //this runs the quicksort sequentially
    let sortedSnums = quicksortParallel 4 sampleNumbers
    stopWatch.Stop()

    printfn "time taken %A millseconds\n" stopWatch.Elapsed.TotalMilliseconds
    printfn "time taken %A seconds\n" stopWatch.Elapsed.TotalSeconds
    printfn "time taken %A minutes\n" stopWatch.Elapsed.TotalMinutes
    printfn "time taken %A hours\n" stopWatch.Elapsed.TotalHours

The equivalent code in c#(without in-place partitioning) runs faster when parallelized:

class Program
    {
        static List<int> genRandomNums(int count)
        {
            var rnd = new System.Random();
            IEnumerable<int> enumerable = Enumerable.Range(0, count)
                .Select(i => new Tuple<int, int>(rnd.Next(int.MaxValue), i))
                                     //.OrderBy(i => i.Item1)
                                     .Select(i => i.Item1);
            return enumerable.ToList();
        }

        static List<T> QuickSort<T>(List<T> values, int depth)
           where T : IComparable
        {
            if (values.Count == 0)
            {
                return new List<T>();
            }

            //get the first element       
            T firstElement = values[0];

            //get the smaller and larger elements       
            var smallerElements = new List<T>();
            var largerElements = new List<T>();
            for (int i = 1; i < values.Count; i++)  // i starts at 1       
            {                                       // not 0!          
                var elem = values[i];
                if (elem.CompareTo(firstElement) < 0)
                {
                    smallerElements.Add(elem);
                }
                else
                {
                    largerElements.Add(elem);
                }
            }

            //return the result       
            var result = new List<T>();
            if (depth < 0)
            {
                List<T> smallList = QuickSort(smallerElements.ToList(), depth);
                result.AddRange(smallList);
                result.Add(firstElement);
                List<T> bigList = QuickSort(largerElements.ToList(), depth);
                result.AddRange(bigList);
                return result;
            }
            else
            {
                Task<List<T>> smallTask = Task.Run(() => { return QuickSort(smallerElements.ToList(), depth - 1); });
                Task<List<T>> bigTask = Task.Run(() => { return QuickSort(largerElements.ToList(), depth - 1); });


                List<Task<List<T>>> tasks = new List<Task<List<T>>>();
                tasks.Add(smallTask);
                tasks.Add(bigTask);
                Task.WaitAll(tasks.ToArray());

                List<T> smallList = smallTask.Result;
                result.AddRange(smallList);

                result.Add(firstElement);

                List<T> bigList = bigTask.Result;
                result.AddRange(bigList);
                return result;
            }
        }

        static void Main(string[] args)
        {
            var sampleNumbers = genRandomNums(50000000);

            int depth = 4;//set it to a negative value to run serially
            var stopWatch = System.Diagnostics.Stopwatch.StartNew();
            List<int> sortedList = QuickSort<int>(sampleNumbers, depth);
            stopWatch.Stop();

            Console.WriteLine("time taken {0} seconds\n", stopWatch.Elapsed.TotalSeconds);
            Console.WriteLine("time taken {0} minutes\n", stopWatch.Elapsed.TotalMinutes);
        }
    }

A correct implementation of quicksort in F# which uses in-place sorting/partitioning does run faster when Task parallelized.

module myMod =
    
    let genRandomNums_arr count =
        let rnd = System.Random()
        Array.init count (fun _ -> rnd.Next(System.Int32.MaxValue))
    
    let swap (aArray: int array) indexA indexB = 
        let temp = aArray.[indexA]
        Array.set aArray indexA (aArray.[indexB])
        Array.set aArray indexB (temp)

    let partition (aArray: int array) first last =
        let pivot = aArray.[last]
        let mutable wallindex = first;
        let mutable currentindex = first
        while currentindex < last do  
            if aArray.[currentindex] < pivot then
                swap aArray wallindex currentindex
                wallindex <- wallindex + 1

            currentindex <- currentindex + 1    

        swap aArray wallindex last
        wallindex

    let rec quicksortParallelInPlace (aArray: int array) first last depth =
        if ((last - first) >= 1) then
            let pivotposition = partition aArray first last
            if depth < 0 then
                quicksortParallelInPlace aArray first (pivotposition - 1) depth
                quicksortParallelInPlace aArray (pivotposition + 1) last depth
            else
                let left  = Task.Run(fun () -> quicksortParallelInPlace aArray first (pivotposition - 1) (depth-1))
                let right = Task.Run(fun () -> quicksortParallelInPlace aArray (pivotposition + 1) last (depth-1))
                Task.WaitAll(left, right)
                        

    let quickSortInPlace (aArray: int array) depth =
        quicksortParallelInPlace aArray 0 (aArray.Length - 1) depth

    let sampleNumbers_arr = genRandomNums_arr 50000000    
    //printfn "un-sorted list %A" sampleNumbers_arr 

    let stopWatch1 = System.Diagnostics.Stopwatch.StartNew()
    //let sortedSnums = quicksortParallel -1 sampleNumbers //this runs the quicksort sequentially
    quickSortInPlace sampleNumbers_arr 4 //run serially using a negative number
    stopWatch1.Stop()

    //printfn "un-sorted list %A" sampleNumbers_arr

    printfn "time taken %A millseconds\n" stopWatch1.Elapsed.TotalMilliseconds
    printfn "time taken %A seconds\n" stopWatch1.Elapsed.TotalSeconds
    printfn "time taken %A minutes\n" stopWatch1.Elapsed.TotalMinutes
    printfn "time taken %A hours\n" stopWatch1.Elapsed.TotalHours        
1 Answers

I suspect the culprit for the low performance is actually List.partition. See this. You might be better by computing the indices of the partition and work with them than copy around partitions.

Related