add: ClArray.choose

Author: IgorErin

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

@@ -4,6 +4,7 @@ open Brahma.FSharp
 open Microsoft.FSharp.Quotations
 open GraphBLAS.FSharp.Backend.Objects.ClContext
 open GraphBLAS.FSharp.Backend.Objects.ClCell
+open GraphBLAS.FSharp.Backend.Quotes
 
 module ClArray =
     let init (clContext: ClContext) workGroupSize (initializer: Expr<int -> 'a>) =
@@ -365,3 +366,35 @@ module ClArray =
             map2 processor leftArray rightArray resultArray
 
             resultArray
+
+    let choose<'a, 'b> (clContext: ClContext) workGroupSize (predicate: Expr<'a -> 'b option>) =
+        let getBitmap = map<'a, int> clContext workGroupSize <| Map.chooseBitmap predicate
+
+        let getOptionValues = map<'a, 'b option> clContext workGroupSize predicate
+
+        let getValues = map<'b option, 'b> clContext workGroupSize <| Map.optionToValueOrZero Unchecked.defaultof<'b>
+
+        let prefixSum = prefixSumExcludeInplace <@ (+) @> clContext workGroupSize
+
+        let scatter = Scatter.runInplace clContext workGroupSize
+
+        fun (processor: MailboxProcessor<_>) allocationMode (array: ClArray<'a>) ->
+
+            let positions = getBitmap processor DeviceOnly array
+
+            let resultLength =
+                (prefixSum processor positions 0)
+                    .ToHostAndFree(processor)
+
+            let optionValues = getOptionValues processor DeviceOnly array
+
+            let values = getValues processor DeviceOnly optionValues
+
+            let result =
+                clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength)
+
+            scatter processor positions values result
+
+            result
+
+

src/GraphBLAS-sharp.Backend/Quotes/Map.fs

@@ -1,5 +1,7 @@
 namespace GraphBLAS.FSharp.Backend.Quotes
 
+open FSharp.Quotations
+
 module Map =
     let optionToValueOrZero<'a> zero =
         <@ fun (item: 'a option) ->
@@ -13,3 +15,10 @@ module Map =
         | None -> onNone @>
 
     let id<'a> = <@ fun (item: 'a) -> item @>
+
+    let chooseBitmap<'a, 'b> (map: Expr<'a -> 'b option>) =
+        <@ fun (item: 'a) ->
+            match (%map) item with
+            | Some _ -> 1
+            | None -> 0 @>
+

tests/GraphBLAS-sharp.Tests/Common/Choose.fs

@@ -0,0 +1,52 @@
+module GraphBLAS.FSharp.Tests.Backend.Common.Choose
+
+open GraphBLAS.FSharp.Backend.Common
+open Expecto
+open GraphBLAS.FSharp.Tests
+open GraphBLAS.FSharp.Tests.Context
+open GraphBLAS.FSharp.Backend.Objects.ClContext
+open Brahma.FSharp
+open GraphBLAS.FSharp.Backend.Quotes
+
+let workGroupSize = Utils.defaultWorkGroupSize
+
+let config = Utils.defaultConfig
+
+let makeTest<'a, 'b> testContext choose mapFun isEqual (array: 'a []) =
+    if array.Length > 0 then
+        let context = testContext.ClContext
+        let q = testContext.Queue
+
+        let clArray = context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, array)
+
+        let (clResult: ClArray<'b>) = choose q HostInterop clArray
+
+        let hostResult = Array.zeroCreate clResult.Length
+        q.PostAndReply(fun ch -> Msg.CreateToHostMsg(clResult, hostResult, ch)) |> ignore
+
+        let expectedResult = Array.choose mapFun array
+
+        "Result should be the same"
+        |> Utils.compareArrays isEqual hostResult expectedResult
+
+let createTest<'a, 'b> testContext mapFun mapFunQ isEqual =
+    let context = testContext.ClContext
+
+    let choose = ClArray.choose context workGroupSize mapFunQ
+
+    makeTest<'a, 'b> testContext choose mapFun isEqual
+    |> testPropertyWithConfig config $"Correctness on %A{typeof<'a>} -> %A{typeof<'b>}"
+
+let testFixtures testContext =
+    let device = testContext.ClContext.ClDevice
+
+    [ createTest<int option, int> testContext id Map.id (=)
+      createTest<byte option, byte> testContext id Map.id (=)
+      createTest<bool option, bool> testContext id Map.id (=)
+
+      if Utils.isFloat64Available device then
+        createTest<float option, float> testContext id Map.id Utils.floatIsEqual
+
+      createTest<float32 option, float32> testContext id Map.id Utils.float32IsEqual ]
+
+let tests = TestCases.gpuTests "ClArray.choose id tests" testFixtures

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

@@ -57,7 +57,7 @@ let testFixtures plus plusQ zero name =
     let reduce = Reduce.reduce context wgSize plusQ
 
     makeTest reduce plus zero
-    |> testPropertyWithConfig config (sprintf "Correctness on %s" name)
+    |> testPropertyWithConfig config $"Correctness on %s{name}"
 
 let tests =
     q.Error.Add(fun e -> failwithf "%A" e)

tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj

@@ -27,6 +27,7 @@
         <Compile Include="Common/Exists.fs" />
         <Compile Include="Common/Map.fs" />
         <Compile Include="Common/Map2.fs" />
+        <Compile Include="Common\Choose.fs" />
         <!--Compile Include="MatrixOperationsTests/GetTuplesTests.fs" /-->
         <!--Compile Include="MatrixOperationsTests/MxvTests.fs" /-->
         <!--Compile Include="MatrixOperationsTests/VxmTests.fs" /-->

tests/GraphBLAS-sharp.Tests/Program.fs

@@ -27,7 +27,8 @@ let commonTests =
           Common.Exists.tests
           Common.Map.tests
           Common.Map2.addTests
-          Common.Map2.mulTests ]
+          Common.Map2.mulTests
+          Common.Choose.tests ]
     |> testSequenced
 
 let vectorTests =