merge: dev

Author: artemiipatov

src/GraphBLAS-sharp.Backend/Common/Sum.fs

@@ -5,8 +5,12 @@ open GraphBLAS.FSharp.Backend.Quotes
 open Microsoft.FSharp.Control
 open Microsoft.FSharp.Quotations
 open GraphBLAS.FSharp.Backend.Objects.ClContext
+open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions
 
 module Reduce =
+    /// <summary>
+    /// Generalized reduction pattern.
+    /// </summary>
     let private runGeneral (clContext: ClContext) workGroupSize scan scanToCell =
 
         fun (processor: MailboxProcessor<_>) (inputArray: ClArray<'a>) ->
@@ -45,8 +49,8 @@ module Reduce =
             let result =
                 scanToCell processor fstVertices verticesLength
 
-            processor.Post(Msg.CreateFreeMsg(firstVerticesArray))
-            processor.Post(Msg.CreateFreeMsg(secondVerticesArray))
+            firstVerticesArray.Free processor
+            secondVerticesArray.Free processor
 
             result
 
@@ -127,6 +131,13 @@ module Reduce =
 
             resultCell
 
+    /// <summary>
+    /// Summarize array elements.
+    /// </summary>
+    /// <param name="clContext">ClContext.</param>
+    /// <param name="workGroupSize">Work group size.</param>
+    /// <param name="op">Summation operation.</param>
+    /// <param name="zero">Neutral element for summation.</param>
     let sum (clContext: ClContext) workGroupSize op zero =
 
         let scan = scanSum clContext workGroupSize op zero
@@ -224,6 +235,12 @@ module Reduce =
 
             resultCell
 
+    /// <summary>
+    /// Reduce an array of values.
+    /// </summary>
+    /// <param name="clContext">ClContext.</param>
+    /// <param name="workGroupSize">Work group size.</param>
+    /// <param name="op">Reduction operation.</param>
     let reduce (clContext: ClContext) workGroupSize op =
 
         let scan = scanReduce clContext workGroupSize op
@@ -235,3 +252,221 @@ module Reduce =
             runGeneral clContext workGroupSize scan scanToCell
 
         fun (processor: MailboxProcessor<_>) (array: ClArray<'a>) -> run processor array
+
+    /// <summary>
+    /// Reduction of an array of values by an array of keys.
+    /// </summary>
+    module ByKey =
+        /// <summary>
+        /// Reduce an array of values by key using a single work item.
+        /// </summary>
+        /// <param name="clContext">ClContext.</param>
+        /// <param name="workGroupSize">Work group size.</param>
+        /// <param name="reduceOp">Operation for reducing values.</param>
+        /// <remarks>
+        /// The length of the result must be calculated in advance.
+        /// </remarks>
+        let sequential (clContext: ClContext) workGroupSize (reduceOp: Expr<'a -> 'a -> 'a>) =
+
+            let kernel =
+                <@ fun (ndRange: Range1D) length (keys: ClArray<int>) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (reducedKeys: ClArray<int>) ->
+
+                    let gid = ndRange.GlobalID0
+
+                    if gid = 0 then
+                        let mutable currentKey = keys.[0]
+                        let mutable segmentResult = values.[0]
+                        let mutable segmentCount = 0
+
+                        for i in 1 .. length - 1 do
+                            if currentKey = keys.[i] then
+                                segmentResult <- (%reduceOp) segmentResult values.[i]
+                            else
+                                reducedValues.[segmentCount] <- segmentResult
+                                reducedKeys.[segmentCount] <- currentKey
+
+                                segmentCount <- segmentCount + 1
+                                currentKey <- keys.[i]
+                                segmentResult <- values.[i]
+
+                        reducedKeys.[segmentCount] <- currentKey
+                        reducedValues.[segmentCount] <- segmentResult @>
+
+            let kernel = clContext.Compile kernel
+
+            fun (processor: MailboxProcessor<_>) allocationMode (resultLength: int) (keys: ClArray<int>) (values: ClArray<'a>) ->
+
+                let reducedValues =
+                    clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength)
+
+                let reducedKeys =
+                    clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength)
+
+                let ndRange =
+                    Range1D.CreateValid(resultLength, workGroupSize)
+
+                let kernel = kernel.GetKernel()
+
+                processor.Post(
+                    Msg.MsgSetArguments
+                        (fun () -> kernel.KernelFunc ndRange keys.Length keys values reducedValues reducedKeys)
+                )
+
+                processor.Post(Msg.CreateRunMsg<_, _>(kernel))
+
+                reducedKeys, reducedValues
+
+        /// <summary>
+        /// Reduces values by key. Each segment is reduced by one work item.
+        /// </summary>
+        /// <param name="clContext">ClContext.</param>
+        /// <param name="workGroupSize">Work group size.</param>
+        /// <param name="reduceOp">Operation for reducing values.</param>
+        /// <remarks>
+        /// The length of the result must be calculated in advance.
+        /// </remarks>
+        let segmentSequential (clContext: ClContext) workGroupSize (reduceOp: Expr<'a -> 'a -> 'a>) =
+
+            let kernel =
+                <@ fun (ndRange: Range1D) uniqueKeyCount keysLength (offsets: ClArray<int>) (keys: ClArray<int>) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (reducedKeys: ClArray<int>) ->
+
+                    let gid = ndRange.GlobalID0
+
+                    if gid < uniqueKeyCount then
+                        let startPosition = offsets.[gid]
+
+                        let sourceKey = keys.[startPosition]
+                        let mutable sum = values.[startPosition]
+
+                        let mutable currentPosition = startPosition + 1
+
+                        while currentPosition < keysLength
+                              && sourceKey = keys.[currentPosition] do
+
+                            sum <- (%reduceOp) sum values.[currentPosition]
+                            currentPosition <- currentPosition + 1
+
+                        reducedValues.[gid] <- sum
+                        reducedKeys.[gid] <- sourceKey @>
+
+            let kernel = clContext.Compile kernel
+
+            fun (processor: MailboxProcessor<_>) allocationMode (resultLength: int) (offsets: ClArray<int>) (keys: ClArray<int>) (values: ClArray<'a>) ->
+
+                let reducedValues =
+                    clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength)
+
+                let reducedKeys =
+                    clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength)
+
+                let ndRange =
+                    Range1D.CreateValid(resultLength, workGroupSize)
+
+                let kernel = kernel.GetKernel()
+
+                processor.Post(
+                    Msg.MsgSetArguments
+                        (fun () ->
+                            kernel.KernelFunc
+                                ndRange
+                                resultLength
+                                keys.Length
+                                offsets
+                                keys
+                                values
+                                reducedValues
+                                reducedKeys)
+                )
+
+                processor.Post(Msg.CreateRunMsg<_, _>(kernel))
+
+                reducedKeys, reducedValues
+
+        /// <summary>
+        /// Reduces values by key. One work group participates in the reduction.
+        /// </summary>
+        /// <param name="clContext">ClContext.</param>
+        /// <param name="workGroupSize">Work group size.</param>
+        /// <param name="reduceOp">Operation for reducing values.</param>
+        /// <remarks>
+        /// Reduces an array of values that does not exceed the size of the workgroup.
+        /// The length of the result must be calculated in advance.
+        /// </remarks>
+        let oneWorkGroupSegments (clContext: ClContext) workGroupSize (reduceOp: Expr<'a -> 'a -> 'a>) =
+
+            let kernel =
+                <@ fun (ndRange: Range1D) length (keys: ClArray<int>) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (reducedKeys: ClArray<int>) ->
+
+                    let lid = ndRange.GlobalID0
+
+                    // load values to local memory (may be without it)
+                    let localValues = localArray<'a> workGroupSize
+
+                    if lid < length then
+                        localValues.[lid] <- values.[lid]
+
+                    // load keys to local memory (mb without it)
+                    let localKeys = localArray<int> workGroupSize
+
+                    if lid < length then
+                        localKeys.[lid] <- keys.[lid]
+
+                    // get unique keys bitmap
+                    let localBitmap = localArray<int> workGroupSize
+                    localBitmap.[lid] <- 0
+                    (%PreparePositions.getUniqueBitmapLocal<int>) localKeys workGroupSize lid localBitmap
+
+                    // get positions from bitmap by prefix sum
+                    // ??? get bitmap by prefix sum in another kernel ???
+                    // ??? we can restrict prefix sum for 0 .. length ???
+                    (%SubSum.localIntPrefixSum) lid workGroupSize localBitmap
+
+                    let uniqueKeysCount = localBitmap.[length - 1]
+
+                    if lid < uniqueKeysCount then
+                        let itemKeyId = lid + 1
+
+                        let startKeyIndex =
+                            (%Search.Bin.lowerPosition) length itemKeyId localBitmap
+
+                        match startKeyIndex with
+                        | Some startPosition ->
+                            let sourceKeyPosition = localBitmap.[startPosition]
+                            let mutable currentSum = localValues.[startPosition]
+                            let mutable currentIndex = startPosition + 1
+
+                            while currentIndex < length
+                                  && localBitmap.[currentIndex] = sourceKeyPosition do
+
+                                currentSum <- (%reduceOp) currentSum localValues.[currentIndex]
+                                currentIndex <- currentIndex + 1
+
+                            reducedKeys.[lid] <- localKeys.[startPosition]
+                            reducedValues.[lid] <- currentSum
+                        | None -> () @>
+
+            let kernel = clContext.Compile kernel
+
+            fun (processor: MailboxProcessor<_>) allocationMode (resultLength: int) (keys: ClArray<int>) (values: ClArray<'a>) ->
+                if keys.Length > workGroupSize then
+                    failwith "The length of the value should not exceed the size of the workgroup"
+
+                let reducedValues =
+                    clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength)
+
+                let reducedKeys =
+                    clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength)
+
+                let ndRange =
+                    Range1D.CreateValid(resultLength, workGroupSize)
+
+                let kernel = kernel.GetKernel()
+
+                processor.Post(
+                    Msg.MsgSetArguments
+                        (fun () -> kernel.KernelFunc ndRange keys.Length keys values reducedValues reducedKeys)
+                )
+
+                processor.Post(Msg.CreateRunMsg<_, _>(kernel))
+
+                reducedKeys, reducedValues

src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj

@@ -26,12 +26,12 @@
     <Compile Include="Quotes/PreparePositions.fs" />
     <Compile Include="Quotes/Predicates.fs" />
     <Compile Include="Quotes/Map.fs" />
-    <Compile Include="Quotes/BinSearch.fs" />
+    <Compile Include="Quotes/Search.fs" />
     <Compile Include="Common/Scatter.fs" />
     <Compile Include="Common/Utils.fs" />
-    <Compile Include="Common/Sum.fs" />
     <Compile Include="Common/PrefixSum.fs" />
     <Compile Include="Common/ClArray.fs" />
+    <Compile Include="Common/Sum.fs" />
     <Compile Include="Common/BitonicSort.fs" />
     <Compile Include="Predefined/PrefixSum.fs" />
     <!--Compile Include="Matrices.fs" /-->

src/GraphBLAS-sharp.Backend/Matrix/COOMatrix/Map.fs

@@ -1,5 +1,6 @@
 namespace GraphBLAS.FSharp.Backend.Matrix.COO
 
+open System
 open Brahma.FSharp
 open GraphBLAS.FSharp.Backend.Matrix
 open GraphBLAS.FSharp.Backend.Quotes
@@ -26,7 +27,7 @@ module internal Map =
                         (uint64 rowIndex <<< 32) ||| (uint64 columnIndex)
 
                     let value =
-                        (%BinSearch.byKey2D) valuesLength index rows columns values
+                        (%Search.Bin.byKey2D) valuesLength index rows columns values
 
                     match (%op) value with
                     | Some resultValue ->

src/GraphBLAS-sharp.Backend/Matrix/COOMatrix/Map2.fs

@@ -8,8 +8,10 @@ open GraphBLAS.FSharp.Backend
 open GraphBLAS.FSharp.Backend.Quotes
 open GraphBLAS.FSharp.Backend.Objects.ClMatrix
 open GraphBLAS.FSharp.Backend.Objects.ClContext
+open GraphBLAS.FSharp.Backend.Quotes
 
 module internal Map2 =
+
     let preparePositions<'a, 'b, 'c> (clContext: ClContext) workGroupSize opAdd =
 
         let preparePositions (op: Expr<'a option -> 'b option -> 'c option>) =
@@ -26,10 +28,10 @@ module internal Map2 =
                         (uint64 rowIndex <<< 32) ||| (uint64 columnIndex)
 
                     let leftValue =
-                        (%BinSearch.byKey2D) leftValuesLength index leftRows leftColumns leftValues
+                        (%Search.Bin.byKey2D) leftValuesLength index leftRows leftColumns leftValues
 
                     let rightValue =
-                        (%BinSearch.byKey2D) rightValuesLength index rightRows rightColumn rightValues
+                        (%Search.Bin.byKey2D) rightValuesLength index rightRows rightColumn rightValues
 
                     match (%op) leftValue rightValue with
                     | Some value ->

src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/Map.fs

@@ -27,7 +27,7 @@ module internal Map =
                     let lastIndex = rowPointers.[rowIndex + 1] - 1
 
                     let value =
-                        (%BinSearch.inRange) startIndex lastIndex columnIndex columns values
+                        (%Search.Bin.inRange) startIndex lastIndex columnIndex columns values
 
                     match (%op) value with
                     | Some resultValue ->

src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/Map2.fs

@@ -30,10 +30,10 @@ module internal Map2 =
                     let rightLastIndex = rightRowPointers.[rowIndex + 1] - 1
 
                     let leftValue =
-                        (%BinSearch.inRange) leftStartIndex leftLastIndex columnIndex leftColumns leftValues
+                        (%Search.Bin.inRange) leftStartIndex leftLastIndex columnIndex leftColumns leftValues
 
                     let rightValue =
-                        (%BinSearch.inRange) rightStartIndex rightLastIndex columnIndex rightColumn rightValues
+                        (%Search.Bin.inRange) rightStartIndex rightLastIndex columnIndex rightColumn rightValues
 
                     match (%op) leftValue rightValue with
                     | Some value ->

src/GraphBLAS-sharp.Backend/Objects/ArraysExtentions.fs

@@ -13,6 +13,14 @@ module ArraysExtensions =
             let dst = Array.zeroCreate this.Length
             q.PostAndReply(fun ch -> Msg.CreateToHostMsg(this, dst, ch))
 
+        member this.Free(q: MailboxProcessor<_>) = q.Post <| Msg.CreateFreeMsg this
+
+        member this.ToHostAndFree(q: MailboxProcessor<_>) =
+            let result = this.ToHost q
+            this.Free q
+
+            result
+
         member this.Size = this.Length
 
     type 'a ``[]`` with