refactor: Reduce.fs

Author: IgorErin

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

@@ -36,6 +36,23 @@ module SubSum =
 
     let treeSum<'a> opAdd = sumGeneral<'a> <| treeAccess<'a> opAdd
 
+module SubReduce =
+    let run opAdd =
+        <@ fun length wgSize gid lid (localValues: 'a []) ->
+            let mutable step = 2
+
+            while step <= wgSize do
+                if (gid + wgSize / step) < length
+                   && lid < wgSize / step then
+                    let firstValue = localValues.[lid]
+                    let secondValue = localValues.[lid + wgSize / step]
+
+                    localValues.[lid] <- (%opAdd) firstValue secondValue
+
+                step <- step <<< 1
+
+                barrierLocal () @>
+
 module PreparePositions =
     let both<'c> =
         <@ fun index (result: 'c option) (rawPositionsBuffer: ClArray<int>) (allValuesBuffer: ClArray<'c>) ->

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

@@ -1,6 +1,7 @@
 namespace GraphBLAS.FSharp.Backend.Common
 
 open Brahma.FSharp
+open GraphBLAS.FSharp.Backend
 open Microsoft.FSharp.Control
 open Microsoft.FSharp.Quotations
 
@@ -20,20 +21,9 @@ module Reduce =
 
                 barrierLocal ()
 
-                let mutable step = 2
-
                 if gid < length then
-                    while step <= workGroupSize do
-                        if (gid + workGroupSize / step) < length
-                           && lid < workGroupSize / step then
-                            let firstValue = localValues.[lid]
-                            let secondValue = localValues.[lid + workGroupSize / step]
-
-                            localValues.[lid] <- (%opAdd) firstValue secondValue
-
-                        step <- step <<< 1
 
-                        barrierLocal ()
+                    (%SubReduce.run opAdd) length workGroupSize gid lid localValues
 
                     if lid = 0 then
                         resultArray.[gid / workGroupSize] <- localValues.[0] @>
@@ -53,10 +43,53 @@ module Reduce =
 
             processor.Post(Msg.CreateRunMsg<_, _>(kernel))
 
+    let private scanToCell<'a when 'a: struct>
+        (clContext: ClContext)
+        (workGroupSize: int)
+        (opAdd: Expr<'a -> 'a -> 'a>)
+        =
+
+        let scan =
+            <@ fun (ndRange: Range1D) length (inputArray: ClArray<'a>) (resultValue: ClCell<'a>) ->
+
+                let gid = ndRange.GlobalID0
+                let lid = ndRange.LocalID0
+
+                let localValues = localArray<'a> workGroupSize
+
+                if gid < length then
+                    localValues.[lid] <- inputArray.[gid]
+
+                barrierLocal ()
+
+                if gid < length then
+
+                    (%SubReduce.run opAdd) length workGroupSize gid lid localValues
+
+                    if lid = 0 then
+                        resultValue.Value <- localValues.[0] @>
+
+        let kernel = clContext.Compile(scan)
+
+        fun (processor: MailboxProcessor<_>) (valuesArray: ClArray<'a>) valuesLength (resultValue: ClCell<'a>) ->
+
+            let ndRange =
+                Range1D.CreateValid(valuesArray.Length, workGroupSize)
+
+            let kernel = kernel.GetKernel()
+
+            processor.Post(
+                Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange valuesLength valuesArray resultValue)
+            )
+
+            processor.Post(Msg.CreateRunMsg<_, _>(kernel))
+
     let run<'a when 'a: struct> (clContext: ClContext) (workGroupSize: int) (opAdd: Expr<'a -> 'a -> 'a>) =
 
         let scan = scan clContext workGroupSize opAdd
 
+        let scanToCell = scanToCell clContext workGroupSize opAdd
+
         fun (processor: MailboxProcessor<_>) (inputArray: ClArray<'a>) ->
 
             let scan = scan processor
@@ -101,14 +134,9 @@ module Reduce =
             let fstVertices = fst verticesArrays
 
             let result =
-                clContext.CreateClArray(
-                    1,
-                    hostAccessMode = HostAccessMode.NotAccessible,
-                    deviceAccessMode = DeviceAccessMode.ReadWrite,
-                    allocationMode = AllocationMode.Default
-                )
+                clContext.CreateClCell Unchecked.defaultof<'a>
 
-            scan fstVertices verticesLength result
+            scanToCell processor fstVertices verticesLength result
 
             processor.Post(Msg.CreateFreeMsg(firstVerticesArray))
             processor.Post(Msg.CreateFreeMsg(secondVerticesArray))

tests/GraphBLAS-sharp.Tests/BackendCommonTests/ReduceTests.fs

@@ -14,7 +14,7 @@ let context = Context.defaultContext.ClContext
 
 let makeTest
     (q: MailboxProcessor<_>)
-    (reduce: MailboxProcessor<_> -> ClArray<'a> -> ClArray<'a>)
+    (reduce: MailboxProcessor<_> -> ClArray<'a> -> ClCell<'a>)
     plus
     zero
     (filter: 'a [] -> 'a [])

tests/GraphBLAS-sharp.Tests/Vector/Reduce.fs

@@ -27,7 +27,7 @@ let correctnessGenericTest
     zero
     op
     opQ
-    (reduce: Expr<'a -> 'a -> 'a> -> MailboxProcessor<_> -> ClVector<'a> -> ClArray<'a>)
+    (reduce: Expr<'a -> 'a -> 'a> -> MailboxProcessor<_> -> ClVector<'a> -> ClCell<'a>)
     filter
     case
     (array: 'a [])