diff --git a/.github/workflows/build-and-benchmark.yml b/.github/workflows/build-and-benchmark.yml index ff8e88b4..2bde3398 100644 --- a/.github/workflows/build-and-benchmark.yml +++ b/.github/workflows/build-and-benchmark.yml @@ -36,7 +36,7 @@ jobs: with: name: BFS tool: 'benchmarkdotnet' - output-file-path: BenchmarkDotNet.Artifacts/results/GraphBLAS.FSharp.Benchmarks.BFSBenchmarksWithoutDataTransfer-report-brief.json + output-file-path: BenchmarkDotNet.Artifacts/results/GraphBLAS.FSharp.Benchmarks.BFSWithoutTransferBenchmarkInt32-report-brief.json # Access token to deploy GitHub Pages branch github-token: ${{ secrets._GITHUB_TOKEN }} # Push and deploy GitHub pages branch automatically diff --git a/README.md b/README.md index 964b619f..6ddbc2c0 100644 --- a/README.md +++ b/README.md @@ -19,32 +19,38 @@ GraphBLAS# is a GPGPU-based [GraphBLAS](https://graphblas.org/)-like API impleme | Left of 't1 | Right of 't2 ``` - So, type of matrix-matrix elementwise oertion is ```Matrix> -> Matrix> -> (AtLeastOne<'t1,'t2> -> Option<'t3>) -> Matrix>```. -- No semirings. Just functions. Ofcourse one can implement semirings on the top of provided API. + So, type of matrix-matrix elementwise operation is ```Matrix> -> Matrix> -> (AtLeastOne<'t1,'t2> -> Option<'t3>) -> Matrix>```. +- No semirings. Just functions. Of course one can implement semirings on the top of provided API. - Minimal core: high-order functions allows us to minimaze core by functions unification. For example, such functions as matrix-matrix addition, matrix-matrix element-wise multiplication, masking all are partial case of `map2` function. ### Operations - **Matrix-Matrix** - - [x] COO-COO element-wize - - [x] CSR-CSR element-wize - - [ ] CSR-CSR multiplication - - [ ] COO transpose - - [ ] CSR transpose + - [x] CSR-CSR `map2` + - [x] CSR-CSR `map2AtLeastOne` + - [x] COO-COO `map2` + - [x] COO-COO `map2AtLeastOne` + - [x] CSR-CSR multiplication - **Vector-Matrix** - [x] Dense-CSR multiplication - - [ ] COO-CSR multiplication + - [ ] Sparse-CSR multiplication - **Vector-Vector** - - [x] Dense-Dense element-wise + - [x] Dense-Dense `map2` + - [x] Dense-Dense `map2AtLeastOne` + - [x] Sparse-Sparse `map2` + - [x] Sparse-Sparse `map2AtLeastOne` - [ ] ... - **Matrix** - - [ ] `map` - - [ ] `iter` + - [x] `copy` + - [x] `map` + - [x] COO transpose + - [x] CSR transpose + - [x] CSC transpose - [ ] ... - **Vector** - - [ ] `map` - - [ ] `iter` - - [ ] `filter` - - [ ] `contains` + - [x] `zeroCreate` + - [x] `ofList` + - [x] `copy` + - [x] `reduce` - [ ] ... ### Graph Analysis Algorithms diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Algorithms/BFS.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Algorithms/BFS.fs new file mode 100644 index 00000000..7115a90c --- /dev/null +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Algorithms/BFS.fs @@ -0,0 +1,178 @@ +namespace GraphBLAS.FSharp.Benchmarks.Algorithms.BFS + +open System.IO +open BenchmarkDotNet.Attributes +open GraphBLAS.FSharp +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.IO +open Brahma.FSharp +open Backend.Algorithms.BFS +open Microsoft.FSharp.Core +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Benchmarks +open GraphBLAS.FSharp.Backend.Objects + +[] +[] +[] +[)>] +type Benchmarks<'elem when 'elem : struct>( + buildFunToBenchmark, + converter: string -> 'elem, + binaryConverter, + vertex: int) + = + + let mutable funToBenchmark = None + let mutable matrix = Unchecked.defaultof> + let mutable matrixHost = Unchecked.defaultof<_> + + member val ResultLevels = Unchecked.defaultof> with get,set + + [] + member val OclContextInfo = Unchecked.defaultof with get, set + + [] + member val InputMatrixReader = Unchecked.defaultof with get, set + + member this.OclContext = (fst this.OclContextInfo).ClContext + member this.WorkGroupSize = snd this.OclContextInfo + + member this.Processor = + let p = (fst this.OclContextInfo).Queue + p.Error.Add(fun e -> failwithf "%A" e) + p + + static member AvailableContexts = Utils.availableContexts + + static member InputMatrixProviderBuilder pathToConfig = + let datasetFolder = "BFS" + pathToConfig + |> Utils.getMatricesFilenames + |> Seq.map + (fun matrixFilename -> + printfn "%A" matrixFilename + + match Path.GetExtension matrixFilename with + | ".mtx" -> MtxReader(Utils.getFullPathToMatrix datasetFolder matrixFilename) + | _ -> failwith "Unsupported matrix format") + + member this.FunToBenchmark = + match funToBenchmark with + | None -> + let x = buildFunToBenchmark this.OclContext this.WorkGroupSize + funToBenchmark <- Some x + x + | Some x -> x + + member this.BFS() = + this.ResultLevels <- this.FunToBenchmark this.Processor matrix vertex + + member this.ClearInputMatrix() = + (matrix :> IDeviceMemObject).Dispose this.Processor + + member this.ClearResult() = this.ResultLevels.FreeAndWait this.Processor + + member this.ReadMatrix() = + let converter = + match this.InputMatrixReader.Field with + | Pattern -> binaryConverter + | _ -> converter + + matrixHost <- this.InputMatrixReader.ReadMatrix converter + + member this.LoadMatrixToGPU() = + matrix <- matrixHost.ToCSR.ToDevice this.OclContext + + abstract member GlobalSetup : unit -> unit + + abstract member IterationCleanup : unit -> unit + + abstract member GlobalCleanup : unit -> unit + + abstract member Benchmark : unit -> unit + +type WithoutTransferBenchmark<'elem when 'elem : struct>( + buildFunToBenchmark, + converter: string -> 'elem, + boolConverter, + vertex) = + + inherit Benchmarks<'elem>( + buildFunToBenchmark, + converter, + boolConverter, + vertex) + + [] + override this.GlobalSetup() = + this.ReadMatrix() + this.LoadMatrixToGPU() + + [] + override this.IterationCleanup() = + this.ClearResult() + + [] + override this.GlobalCleanup() = + this.ClearInputMatrix() + + [] + override this.Benchmark() = + this.BFS() + this.Processor.PostAndReply Msg.MsgNotifyMe + +type BFSWithoutTransferBenchmarkInt32() = + + inherit WithoutTransferBenchmark( + (singleSource ArithmeticOperations.intSumOption ArithmeticOperations.intMulOption), + int32, + (fun _ -> Utils.nextInt (System.Random())), + 0) + + static member InputMatrixProvider = + Benchmarks<_>.InputMatrixProviderBuilder "BFSBenchmarks.txt" + +type WithTransferBenchmark<'elem when 'elem : struct>( + buildFunToBenchmark, + converter: string -> 'elem, + boolConverter, + vertex) = + + inherit Benchmarks<'elem>( + buildFunToBenchmark, + converter, + boolConverter, + vertex) + + [] + override this.GlobalSetup() = + this.ReadMatrix() + + [] + override this.GlobalCleanup() = + this.ClearResult() + + [] + override this.IterationCleanup() = + this.ClearInputMatrix() + this.ClearResult() + + [] + override this.Benchmark() = + this.LoadMatrixToGPU() + this.BFS() + this.ResultLevels.ToHost this.Processor |> ignore + this.Processor.PostAndReply Msg.MsgNotifyMe + +type BFSWithTransferBenchmarkInt32() = + + inherit WithTransferBenchmark( + (singleSource ArithmeticOperations.intSumOption ArithmeticOperations.intMulOption), + int32, + (fun _ -> Utils.nextInt (System.Random())), + 0) + + static member InputMatrixProvider = + Benchmarks<_>.InputMatrixProviderBuilder "BFSBenchmarks.txt" + diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksBFS.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksBFS.fs deleted file mode 100644 index 618b99ca..00000000 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksBFS.fs +++ /dev/null @@ -1,164 +0,0 @@ -namespace GraphBLAS.FSharp.Benchmarks - -open System.IO -open GraphBLAS.FSharp.Backend.Quotes -open GraphBLAS.FSharp.IO -open BenchmarkDotNet.Attributes -open BenchmarkDotNet.Configs -open BenchmarkDotNet.Columns -open Brahma.FSharp -open GraphBLAS.FSharp.Objects -open GraphBLAS.FSharp.Backend.Objects -open GraphBLAS.FSharp.Backend.Algorithms -open MatrixExtensions -open ArraysExtensions - -[] -[] -[] -[)>] -type BFSBenchmarks<'matrixT, 'elem when 'matrixT :> IDeviceMemObject and 'elem : struct>( - buildFunToBenchmark, - converter: string -> 'elem, - converterBool, - buildMatrix) = - - let mutable funToBenchmark = None - let mutable matrix = Unchecked.defaultof<'matrixT> - let mutable matrixHost = Unchecked.defaultof<_> - - let source = 0 - - member val ResultVector = Unchecked.defaultof> with get,set - - [] - member val OclContextInfo = Unchecked.defaultof with get, set - - [] - member val InputMatrixReader = Unchecked.defaultof with get, set - - member this.OclContext:ClContext = (fst this.OclContextInfo).ClContext - member this.WorkGroupSize = snd this.OclContextInfo - - member this.Processor = - let p = (fst this.OclContextInfo).Queue - p.Error.Add(fun e -> failwithf "%A" e) - p - - static member AvaliableContexts = Utils.avaliableContexts - - static member InputMatricesProviderBuilder pathToConfig = - let datasetFolder = "" - pathToConfig - |> Utils.getMatricesFilenames - |> Seq.map - (fun matrixFilename -> - printfn "%A" matrixFilename - - match Path.GetExtension matrixFilename with - | ".mtx" -> - MtxReader(Utils.getFullPathToMatrix datasetFolder matrixFilename) - | _ -> failwith "Unsupported matrix format") - - member this.FunToBenchmark = - match funToBenchmark with - | None -> - let x = buildFunToBenchmark this.OclContext this.WorkGroupSize - funToBenchmark <- Some x - x - | Some x -> x - - member this.ReadMatrix (reader:MtxReader) = - let converter = - match reader.Field with - | Pattern -> converterBool - | _ -> converter - - reader.ReadMatrix converter - - member this.BFS() = - this.ResultVector <- this.FunToBenchmark this.Processor matrix source - - member this.ClearInputMatrix() = - (matrix :> IDeviceMemObject).Dispose this.Processor - - member this.ClearResult() = - this.ResultVector.Dispose this.Processor - - member this.ReadMatrix() = - let matrixReader = this.InputMatrixReader - matrixHost <- this.ReadMatrix matrixReader - - member this.LoadMatrixToGPU() = - matrix <- buildMatrix this.OclContext matrixHost - - abstract member GlobalSetup : unit -> unit - - abstract member IterationCleanup : unit -> unit - - abstract member GlobalCleanup : unit -> unit - - abstract member Benchmark : unit -> unit - -type BFSBenchmarksWithoutDataTransfer() = - - inherit BFSBenchmarks, int>( - (fun context wgSize -> BFS.singleSource context ArithmeticOperations.intSum ArithmeticOperations.intMul wgSize), - int, - (fun _ -> Utils.nextInt (System.Random())), - Matrix.ToBackendCSR) - - static member InputMatricesProvider = - BFSBenchmarks<_,_>.InputMatricesProviderBuilder "BFSBenchmarks.txt" - - [] - override this.GlobalSetup() = - this.ReadMatrix () - this.LoadMatrixToGPU () - - [] - override this.IterationCleanup() = - this.ClearResult() - - [] - override this.GlobalCleanup() = - this.ClearInputMatrix() - - [] - override this.Benchmark() = - this.BFS() - this.Processor.PostAndReply(Msg.MsgNotifyMe) - -type BFSBenchmarksWithDataTransfer<'matrixT, 'elem when 'matrixT :> IDeviceMemObject and 'elem : struct>( - buildFunToBenchmark, - converter: string -> 'elem, - converterBool, - buildMatrix, - resultToHost) = - - inherit BFSBenchmarks<'matrixT, 'elem>( - buildFunToBenchmark, - converter, - converterBool, - buildMatrix) - - [] - override this.GlobalSetup() = - this.ReadMatrix() - - [] - override this.GlobalCleanup() = () - - [] - override this.IterationCleanup() = - this.ClearInputMatrix() - this.ClearResult() - - [] - override this.Benchmark() = - this.LoadMatrixToGPU() - this.BFS() - this.Processor.PostAndReply Msg.MsgNotifyMe - let res = resultToHost this.ResultVector this.Processor - this.Processor.PostAndReply Msg.MsgNotifyMe - diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksEWiseAdd.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksEWiseAdd.fs deleted file mode 100644 index a941dbe9..00000000 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksEWiseAdd.fs +++ /dev/null @@ -1,308 +0,0 @@ -namespace GraphBLAS.FSharp.Benchmarks - -open System.IO -open GraphBLAS.FSharp.Backend.Quotes -open GraphBLAS.FSharp.IO -open BenchmarkDotNet.Attributes -open BenchmarkDotNet.Configs -open BenchmarkDotNet.Columns -open Brahma.FSharp -open GraphBLAS.FSharp.Objects -open GraphBLAS.FSharp.Backend.Objects -open GraphBLAS.FSharp.Backend.Matrix.COO -open GraphBLAS.FSharp.Backend.Matrix.CSR -open GraphBLAS.FSharp.Objects.Matrix -open GraphBLAS.FSharp.Benchmarks.MatrixExtensions -open GraphBLAS.FSharp.Backend.Objects.ClContext - -[] -[] -[] -[)>] -type EWiseAddBenchmarks<'matrixT, 'elem when 'matrixT :> IDeviceMemObject and 'elem : struct>( - buildFunToBenchmark, - converter: string -> 'elem, - converterBool, - buildMatrix) = - - let mutable funToBenchmark = None - let mutable firstMatrix = Unchecked.defaultof<'matrixT> - let mutable secondMatrix = Unchecked.defaultof<'matrixT> - let mutable firstMatrixHost = Unchecked.defaultof<_> - let mutable secondMatrixHost = Unchecked.defaultof<_> - - member val ResultMatrix = Unchecked.defaultof<'matrixT> with get,set - - [] - member val OclContextInfo = Unchecked.defaultof with get, set - - [] - member val InputMatrixReader = Unchecked.defaultof with get, set - - member this.OclContext:ClContext = (fst this.OclContextInfo).ClContext - member this.WorkGroupSize = snd this.OclContextInfo - - member this.Processor = - let p = (fst this.OclContextInfo).Queue - p.Error.Add(fun e -> failwithf "%A" e) - p - - static member AvaliableContexts = Utils.avaliableContexts - - static member InputMatricesProviderBuilder pathToConfig = - let datasetFolder = "EWiseAdd" - pathToConfig - |> Utils.getMatricesFilenames - |> Seq.map - (fun matrixFilename -> - printfn "%A" matrixFilename - - match Path.GetExtension matrixFilename with - | ".mtx" -> - MtxReader(Utils.getFullPathToMatrix datasetFolder matrixFilename) - , MtxReader(Utils.getFullPathToMatrix datasetFolder ("squared_" + matrixFilename)) - | _ -> failwith "Unsupported matrix format") - - member this.FunToBenchmark = - match funToBenchmark with - | None -> - let x = buildFunToBenchmark this.OclContext this.WorkGroupSize - funToBenchmark <- Some x - x - | Some x -> x - - member this.ReadMatrix (reader:MtxReader) = - let converter = - match reader.Field with - | Pattern -> converterBool - | _ -> converter - - reader.ReadMatrix converter - - member this.EWiseAddition() = - this.ResultMatrix <- this.FunToBenchmark this.Processor HostInterop firstMatrix secondMatrix - - member this.ClearInputMatrices() = - (firstMatrix :> IDeviceMemObject).Dispose this.Processor - (secondMatrix :> IDeviceMemObject).Dispose this.Processor - - member this.ClearResult() = - (this.ResultMatrix :> IDeviceMemObject).Dispose this.Processor - - member this.ReadMatrices() = - let leftMatrixReader = fst this.InputMatrixReader - let rightMatrixReader = snd this.InputMatrixReader - firstMatrixHost <- this.ReadMatrix leftMatrixReader - secondMatrixHost <- this.ReadMatrix rightMatrixReader - - member this.LoadMatricesToGPU () = - firstMatrix <- buildMatrix this.OclContext firstMatrixHost - secondMatrix <- buildMatrix this.OclContext secondMatrixHost - - abstract member GlobalSetup : unit -> unit - - abstract member IterationCleanup : unit -> unit - - abstract member GlobalCleanup : unit -> unit - - abstract member Benchmark : unit -> unit - -type EWiseAddBenchmarksWithoutDataTransfer<'matrixT, 'elem when 'matrixT :> IDeviceMemObject and 'elem : struct>( - buildFunToBenchmark, - converter: string -> 'elem, - converterBool, - buildMatrix) = - - inherit EWiseAddBenchmarks<'matrixT, 'elem>( - buildFunToBenchmark, - converter, - converterBool, - buildMatrix) - - [] - override this.GlobalSetup() = - this.ReadMatrices () - this.LoadMatricesToGPU () - - [] - override this.IterationCleanup () = - this.ClearResult() - - [] - override this.GlobalCleanup () = - this.ClearInputMatrices() - - [] - override this.Benchmark () = - this.EWiseAddition() - this.Processor.PostAndReply(Msg.MsgNotifyMe) - -type EWiseAddBenchmarksWithDataTransfer<'matrixT, 'elem when 'matrixT :> IDeviceMemObject and 'elem : struct>( - buildFunToBenchmark, - converter: string -> 'elem, - converterBool, - buildMatrix, - resultToHost) = - - inherit EWiseAddBenchmarks<'matrixT, 'elem>( - buildFunToBenchmark, - converter, - converterBool, - buildMatrix) - - [] - override this.GlobalSetup () = - this.ReadMatrices () - - [] - override this.GlobalCleanup () = () - - [] - override this.IterationCleanup () = - this.ClearInputMatrices() - this.ClearResult() - - [] - override this.Benchmark () = - this.LoadMatricesToGPU() - this.EWiseAddition() - this.Processor.PostAndReply Msg.MsgNotifyMe - let res = resultToHost this.ResultMatrix this.Processor - this.Processor.PostAndReply Msg.MsgNotifyMe - -module M = - let resultToHostCOO (resultMatrix: ClMatrix.COO<'a>) (processor :MailboxProcessor<_>) = - let cols = - let a = Array.zeroCreate resultMatrix.ColumnCount - processor.Post(Msg.CreateToHostMsg<_>(resultMatrix.Columns,a)) - a - let rows = - let a = Array.zeroCreate resultMatrix.RowCount - processor.Post(Msg.CreateToHostMsg(resultMatrix.Rows,a)) - a - let vals = - let a = Array.zeroCreate resultMatrix.Values.Length - processor.Post(Msg.CreateToHostMsg(resultMatrix.Values,a)) - a - { - RowCount = resultMatrix.RowCount - ColumnCount = resultMatrix.ColumnCount - Rows = rows - Columns = cols - Values = vals - } - - -type EWiseAddBenchmarks4Float32COOWithoutDataTransfer() = - - inherit EWiseAddBenchmarksWithoutDataTransfer,float32>( - (fun context wgSize -> COOMatrix.map2 context ArithmeticOperations.float32Sum wgSize), - float32, - (fun _ -> Utils.nextSingle (System.Random())), - Matrix.ToBackendCOO - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_,_>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32COO.txt" - -type EWiseAddBenchmarks4Float32COOWithDataTransfer() = - - inherit EWiseAddBenchmarksWithDataTransfer,float32>( - (fun context wgSize -> COOMatrix.map2 context ArithmeticOperations.float32Sum wgSize), - float32, - (fun _ -> Utils.nextSingle (System.Random())), - Matrix.ToBackendCOO, - M.resultToHostCOO - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_,_>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32COO.txt" - - -type EWiseAddBenchmarks4BoolCOOWithoutDataTransfer() = - - inherit EWiseAddBenchmarksWithoutDataTransfer,bool>( - (fun context wgSize -> COOMatrix.map2 context ArithmeticOperations.boolSum wgSize), - (fun _ -> true), - (fun _ -> true), - Matrix.ToBackendCOO - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4BoolCOO.txt" - - -type EWiseAddBenchmarks4Float32CSRWithoutDataTransfer() = - - inherit EWiseAddBenchmarksWithoutDataTransfer,float32>( - (fun context wgSize -> CSRMatrix.map2 context ArithmeticOperations.float32Sum wgSize), - float32, - (fun _ -> Utils.nextSingle (System.Random())), - Matrix.ToBackendCSR - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32CSR.txt" - - -type EWiseAddBenchmarks4BoolCSRWithoutDataTransfer() = - - inherit EWiseAddBenchmarksWithoutDataTransfer,bool>( - (fun context wgSize -> CSRMatrix.map2 context ArithmeticOperations.boolSum wgSize), - (fun _ -> true), - (fun _ -> true), - Matrix.ToBackendCSR - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4BoolCSR.txt" - -// With AtLeastOne - -type EWiseAddAtLeastOneBenchmarks4BoolCOOWithoutDataTransfer() = - - inherit EWiseAddBenchmarksWithoutDataTransfer,bool>( - (fun context wgSize -> COOMatrix.map2AtLeastOne context ArithmeticOperations.boolSumAtLeastOne wgSize), - (fun _ -> true), - (fun _ -> true), - Matrix.ToBackendCOO - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4BoolCSR.txt" - -type EWiseAddAtLeastOneBenchmarks4BoolCSRWithoutDataTransfer() = - - inherit EWiseAddBenchmarksWithoutDataTransfer,bool>( - (fun context wgSize -> CSRMatrix.map2AtLeastOne context ArithmeticOperations.boolSumAtLeastOne wgSize), - (fun _ -> true), - (fun _ -> true), - Matrix.ToBackendCSR - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4BoolCSR.txt" - -type EWiseAddAtLeastOneBenchmarks4Float32COOWithoutDataTransfer() = - - inherit EWiseAddBenchmarksWithoutDataTransfer,float32>( - (fun context wgSize -> COOMatrix.map2AtLeastOne context ArithmeticOperations.float32SumAtLeastOne wgSize), - float32, - (fun _ -> Utils.nextSingle (System.Random())), - Matrix.ToBackendCOO - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_,_>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32COO.txt" - -type EWiseAddAtLeastOneBenchmarks4Float32CSRWithoutDataTransfer() = - - inherit EWiseAddBenchmarksWithoutDataTransfer,float32>( - (fun context wgSize -> CSRMatrix.map2AtLeastOne context ArithmeticOperations.float32SumAtLeastOne wgSize), - float32, - (fun _ -> Utils.nextSingle (System.Random())), - Matrix.ToBackendCSR - ) - - static member InputMatricesProvider = - EWiseAddBenchmarks<_,_>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32COO.txt" diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMxv.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMxv.fs deleted file mode 100644 index 62dade8a..00000000 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMxv.fs +++ /dev/null @@ -1,77 +0,0 @@ -namespace GraphBLAS.FSharp.Benchmarks - -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Backend -open BenchmarkDotNet.Attributes -open GraphBLAS.FSharp.Backend.Objects -open GraphBLAS.FSharp.Objects - -[)>] -type MxvBenchmarks() = - let rand = System.Random() - - let mutable matrix = Unchecked.defaultof> - let mutable vector = Unchecked.defaultof> - let semiring = Predefined.AddMult.float - - //TODO fix me - (*[] - member val OclContext = Unchecked.defaultof with get, set - member this.Context = - let (ClContext context) = this.OclContext - context - - [] - member val InputMatrixReader = Unchecked.defaultof with get, set - - [] - member this.BuildMatrix() = - let inputMatrix = this.InputMatrixReader.ReadMatrixReal(float) - - matrix <- - graphblas { - return! Matrix.switch CSR inputMatrix - >>= Matrix.synchronizeAndReturn - } - |> EvalGB.withClContext this.Context - |> EvalGB.runSync - - [] - member this.BuildVector() = - vector <- - graphblas { - return! - [ for i = 0 to matrix.ColumnCount - 1 do if rand.Next() % 2 = 0 then yield (i, 1.) ] - |> Vector.ofList matrix.ColumnCount - // >>= Vector.synchronizeAndReturn - } - |> EvalGB.withClContext this.Context - |> EvalGB.runSync - - [] - member this.Mxv() = - Matrix.mxv semiring matrix vector - |> EvalGB.withClContext this.Context - |> EvalGB.runSync - - [] - member this.ClearBuffers() = - this.Context.Provider.CloseAllBuffers() - - [] - member this.ClearContext() = - let (ClContext context) = this.OclContext - context.Provider.Dispose() - - static member AvaliableContextsProvider = Utils.avaliableContexts - - static member InputMatricesProvider = - "Common.txt" - |> Utils.getMatricesFilenames - |> Seq.map - (fun matrixFilename -> - match Path.GetExtension matrixFilename with - | ".mtx" -> MtxReader(Utils.getFullPathToMatrix "Common" matrixFilename) - | _ -> failwith "Unsupported matrix format" - ) -*) diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksTranspose.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksTranspose.fs deleted file mode 100644 index 92a60f38..00000000 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksTranspose.fs +++ /dev/null @@ -1,68 +0,0 @@ -namespace GraphBLAS.FSharp.Benchmarks - -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Algorithms -open BenchmarkDotNet.Attributes -open BenchmarkDotNet.Configs -open BenchmarkDotNet.Columns -open System.IO -open System -open System.Text.RegularExpressions -open Brahma.FSharp.OpenCL -open OpenCL.Net -open GraphBLAS.FSharp.IO - -[)>] -type TransposeBenchmarks() = - let mutable matrix = Unchecked.defaultof> - - //TODO fix me - (* - [] - member val OclContext = Unchecked.defaultof with get, set - member this.Context = - let (ClContext context) = this.OclContext - context - - [] - member val InputMatrixReader = Unchecked.defaultof with get, set - - [] - member this.BuildMatrix() = - let inputMatrix = this.InputMatrixReader.ReadMatrixReal(float) - - matrix <- - graphblas { - return! Matrix.switch CSR inputMatrix - >>= Matrix.synchronizeAndReturn - } - |> EvalGB.withClContext this.Context - |> EvalGB.runSync - - [] - member this.Transpose() = - Matrix.transpose matrix - |> EvalGB.withClContext this.Context - |> EvalGB.runSync - - [] - member this.ClearBuffers() = - this.Context.Provider.CloseAllBuffers() - - [] - member this.ClearContext() = - let (ClContext context) = this.OclContext - context.Provider.Dispose() - - static member AvaliableContextsProvider = Utils.avaliableContexts - - static member InputMatricesProvider = - "Common.txt" - |> Utils.getMatricesFilenames - |> Seq.map - (fun matrixFilename -> - match Path.GetExtension matrixFilename with - | ".mtx" -> MtxReader(Utils.getFullPathToMatrix "Common" matrixFilename) - | _ -> failwith "Unsupported matrix format" - ) -*) \ No newline at end of file diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Columns.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Columns.fs new file mode 100644 index 00000000..0b2173ae --- /dev/null +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Columns.fs @@ -0,0 +1,41 @@ +namespace GraphBLAS.FSharp.Benchmarks.Columns + +open BenchmarkDotNet.Columns +open BenchmarkDotNet.Reports +open BenchmarkDotNet.Running +open GraphBLAS.FSharp.IO + +type CommonColumn<'a>(benchmarkCaseConvert, columnName: string, getShape: 'a -> _) = + interface IColumn with + member this.AlwaysShow = true + member this.Category = ColumnCategory.Params + member this.ColumnName = columnName + + member this.GetValue(_: Summary, benchmarkCase: BenchmarkCase) = + benchmarkCaseConvert benchmarkCase + |> getShape + |> sprintf "%A" + + member this.GetValue(summary: Summary, benchmarkCase: BenchmarkCase, _: SummaryStyle) = + (this :> IColumn).GetValue(summary, benchmarkCase) + + member this.Id = sprintf $"%s{columnName}" + + member this.IsAvailable(_: Summary) = true + member this.IsDefault(_: Summary, _: BenchmarkCase) = false + member this.IsNumeric = true + member this.Legend = sprintf $"%s{columnName}" + member this.PriorityInCategory = 1 + member this.UnitType = UnitType.Size + +type MatrixColumn(name, getShape) = + inherit CommonColumn( + (fun benchmarkCase -> benchmarkCase.Parameters.["InputMatrixReader"] :?> MtxReader), + name, + getShape) + +type Matrix2Column(name, getShape) = + inherit CommonColumn( + (fun benchmarkCase -> benchmarkCase.Parameters.["InputMatrixReader"] :?> MtxReader * MtxReader), + name, + getShape) diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Configs.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Configs.fs new file mode 100644 index 00000000..8f22f19f --- /dev/null +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Configs.fs @@ -0,0 +1,77 @@ +module GraphBLAS.FSharp.Benchmarks.Configs + +open BenchmarkDotNet.Columns +open BenchmarkDotNet.Toolchains.InProcess.Emit +open GraphBLAS.FSharp.IO +open BenchmarkDotNet.Configs +open BenchmarkDotNet.Jobs +open GraphBLAS.FSharp.Benchmarks.Columns + +type Matrix2() = + inherit ManualConfig() + + do + base.AddColumn( + Matrix2Column("RowCount", (fun (matrix,_) -> matrix.ReadMatrixShape().RowCount)) :> IColumn, + Matrix2Column("ColumnCount", (fun (matrix,_) -> matrix.ReadMatrixShape().ColumnCount)) :> IColumn, + Matrix2Column( + "NNZ", + fun (matrix,_) -> + match matrix.Format with + | Coordinate -> matrix.ReadMatrixShape().NNZ + | Array -> 0 + ) + :> IColumn, + Matrix2Column( + "SqrNNZ", + fun (_,matrix) -> + match matrix.Format with + | Coordinate -> matrix.ReadMatrixShape().NNZ + | Array -> 0 + ) + :> IColumn, + StatisticColumn.Min, + StatisticColumn.Max + ) + |> ignore + +type Matrix() = + inherit ManualConfig() + + do + base.AddColumn( + MatrixColumn("RowCount", (fun matrix -> matrix.ReadMatrixShape().RowCount)) :> IColumn, + MatrixColumn("ColumnCount", (fun matrix -> matrix.ReadMatrixShape().ColumnCount)) :> IColumn, + MatrixColumn( + "NNZ", + fun matrix -> + match matrix.Format with + | Coordinate -> matrix.ReadMatrixShape().NNZ + | Array -> 0 + ) + :> IColumn, + StatisticColumn.Min, + StatisticColumn.Max + ) + |> ignore + + base.AddJob( + Job + .Dry + .WithToolchain(InProcessEmitToolchain.Instance) + .WithWarmupCount(3) + .WithIterationCount(10) + .WithInvocationCount(3) + ) + |> ignore + +type MinMaxMean() = + inherit ManualConfig() + + do + base.AddColumn( + StatisticColumn.Min, + StatisticColumn.Max, + StatisticColumn.Mean + ) + |> ignore diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Configs/SpGeMM.txt b/benchmarks/GraphBLAS-sharp.Benchmarks/Configs/SpGeMM.txt new file mode 100644 index 00000000..9a294a4a --- /dev/null +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Configs/SpGeMM.txt @@ -0,0 +1 @@ +hollywood-2009.mtx diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/GraphBLAS-sharp.Benchmarks.fsproj b/benchmarks/GraphBLAS-sharp.Benchmarks/GraphBLAS-sharp.Benchmarks.fsproj index 689d84c0..6e8486b0 100644 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/GraphBLAS-sharp.Benchmarks.fsproj +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/GraphBLAS-sharp.Benchmarks.fsproj @@ -16,16 +16,17 @@ - - - - - - - - + + + + + + + + + \ No newline at end of file diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Helpers.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Helpers.fs index 734d9b15..6ce43002 100644 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/Helpers.fs +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Helpers.fs @@ -1,135 +1,19 @@ namespace rec GraphBLAS.FSharp.Benchmarks -open BenchmarkDotNet.Columns -open BenchmarkDotNet.Reports -open BenchmarkDotNet.Running +namespace GraphBLAS.FSharp.Benchmarks + open Brahma.FSharp open Brahma.FSharp.OpenCL.Translator +open Brahma.FSharp.OpenCL.Translator.QuotationTransformers +open GraphBLAS.FSharp.Backend.Objects open OpenCL.Net -open GraphBLAS.FSharp.IO open System.IO open System.Text.RegularExpressions -open BenchmarkDotNet.Configs -open BenchmarkDotNet.Jobs open GraphBLAS.FSharp.Tests open FsCheck open Expecto open GraphBLAS.FSharp.Test -type CommonConfig() = - inherit ManualConfig() - - do - base.AddColumn( - MatrixShapeColumn("RowCount", (fun (mtxReader, _) -> mtxReader.ReadMatrixShape().RowCount)) :> IColumn, - MatrixShapeColumn("ColumnCount", (fun (mtxReader, _) -> mtxReader.ReadMatrixShape().ColumnCount)) :> IColumn, - MatrixShapeColumn("NNZ", (fun (mtxReader, _) -> mtxReader.ReadMatrixShape().Nnz)) :> IColumn, - MatrixShapeColumn("SqrNNZ", (fun (_, mtxReader) -> mtxReader.ReadMatrixShape().Nnz)) :> IColumn, - TEPSColumn(fun (parameters: obj) -> parameters :?> MtxReader * MtxReader |> fst) :> IColumn, - StatisticColumn.Min, - StatisticColumn.Max - ) - |> ignore - - base.AddJob( - Job - .Dry - .WithWarmupCount(3) - .WithIterationCount(10) - .WithInvocationCount(3) - ) - |> ignore - -type AlgorithmConfig() = - inherit ManualConfig() - - do - base.AddColumn( - MatrixShapeColumn("RowCount", (fun (mtxReader) -> mtxReader.ReadMatrixShape().RowCount)) :> IColumn, - MatrixShapeColumn("ColumnCount", (fun (mtxReader) -> mtxReader.ReadMatrixShape().ColumnCount)) :> IColumn, - MatrixShapeColumn("NNZ", (fun (mtxReader) -> mtxReader.ReadMatrixShape().Nnz)) :> IColumn, - TEPSColumn(fun (parameters: obj) -> parameters :?> MtxReader) :> IColumn, - StatisticColumn.Min, - StatisticColumn.Max - ) - |> ignore - - base.AddJob( - Job - .Dry - .WithWarmupCount(3) - .WithIterationCount(10) - .WithInvocationCount(3) - ) - |> ignore - -type MatrixShapeColumn<'shape>(columnName: string, getShape: 'shape -> int) = - interface IColumn with - member this.AlwaysShow: bool = true - member this.Category: ColumnCategory = ColumnCategory.Params - member this.ColumnName: string = columnName - - member this.GetValue(summary: Summary, benchmarkCase: BenchmarkCase) : string = - let inputMatrix = - benchmarkCase.Parameters.["InputMatrixReader"] :?> 'shape - - sprintf "%i" <| getShape inputMatrix - - member this.GetValue(summary: Summary, benchmarkCase: BenchmarkCase, style: SummaryStyle) : string = - (this :> IColumn).GetValue(summary, benchmarkCase) - - member this.Id: string = - sprintf "%s.%s" "MatrixShapeColumn" columnName - - member this.IsAvailable(summary: Summary) : bool = true - member this.IsDefault(summary: Summary, benchmarkCase: BenchmarkCase) : bool = false - member this.IsNumeric: bool = true - member this.Legend: string = sprintf "%s of input matrix" columnName - member this.PriorityInCategory: int = 1 - member this.UnitType: UnitType = UnitType.Size - -type TEPSColumn(getMtxReader: obj -> MtxReader) = - interface IColumn with - member this.AlwaysShow: bool = true - member this.Category: ColumnCategory = ColumnCategory.Statistics - member this.ColumnName: string = "TEPS" - - member this.GetValue(summary: Summary, benchmarkCase: BenchmarkCase) : string = - let inputMatrixReader = getMtxReader benchmarkCase.Parameters.["InputMatrixReader"] - - let matrixShape = inputMatrixReader.ReadMatrixShape() - - let (nrows, ncols) = - matrixShape.RowCount, matrixShape.ColumnCount - - let (vertices, edges) = - match inputMatrixReader.Format with - | Coordinate -> - if nrows = ncols then - (nrows, matrixShape.Nnz) - else - (ncols, nrows) - | _ -> failwith "Unsupported" - - if isNull summary.[benchmarkCase].ResultStatistics then - "NA" - else - let meanTime = - summary.[benchmarkCase].ResultStatistics.Mean - - sprintf "%f" <| float edges / (meanTime * 1e-6) - - member this.GetValue(summary: Summary, benchmarkCase: BenchmarkCase, style: SummaryStyle) : string = - (this :> IColumn).GetValue(summary, benchmarkCase) - - member this.Id: string = "TEPSColumn" - member this.IsAvailable(summary: Summary) : bool = true - member this.IsDefault(summary: Summary, benchmarkCase: BenchmarkCase) : bool = false - member this.IsNumeric: bool = true - member this.Legend: string = "Traversed edges per second" - member this.PriorityInCategory: int = 0 - member this.UnitType: UnitType = UnitType.Dimensionless - module Utils = type BenchmarkContext = { ClContext: Brahma.FSharp.ClContext @@ -154,7 +38,7 @@ module Utils = datasetsFolder matrixFilename |] - let avaliableContexts = + let availableContexts = let pathToConfig = Path.Combine [| __SOURCE_DIRECTORY__ "Configs" @@ -213,18 +97,6 @@ module Utils = .ToString() |> Platform.Custom - let deviceType = - Cl - .GetDeviceInfo(device, DeviceInfo.Type, &e) - .CastTo() - - let clDeviceType = - match deviceType with - | DeviceType.Cpu -> ClDeviceType.Cpu - | DeviceType.Gpu -> ClDeviceType.Gpu - | DeviceType.Default -> ClDeviceType.Default - | _ -> failwith "Unsupported" - let device = ClDevice.GetFirstAppropriateDevice(clPlatform) @@ -236,7 +108,6 @@ module Utils = let queue = context.QueueProvider.CreateQueue() { ClContext = context; Queue = queue }) - seq { for wgSize in workGroupSizes do for context in contexts do @@ -248,6 +119,13 @@ module Utils = random.NextBytes buffer System.BitConverter.ToSingle(buffer, 0) + let normalFloatGenerator = + (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + + let fIsEqual x y = abs (x - y) < Accuracy.medium.absolute || x.Equals y + let nextInt (random: System.Random) = random.Next() @@ -268,37 +146,8 @@ module VectorGenerator = |> pairOfVectorsOfEqualSize Arb.generate let floatPair format = - let normalFloatGenerator = - (Arb.Default.NormalFloat() - |> Arb.toGen - |> Gen.map float) - let fIsEqual x y = abs (x - y) < Accuracy.medium.absolute || x = y let createVector array = Utils.createVectorFromArray format array (fIsEqual 0.0) - pairOfVectorsOfEqualSize normalFloatGenerator createVector - -module MatrixGenerator = - let private pairOfMatricesOfEqualSizeGenerator (valuesGenerator: Gen<'a>) createMatrix = - gen { - let! nrows, ncols = Generators.dimension2DGenerator - let! matrixA = valuesGenerator |> Gen.array2DOfDim (nrows, ncols) - let! matrixB = valuesGenerator |> Gen.array2DOfDim (nrows, ncols) - return (createMatrix matrixA, createMatrix matrixB) - } - - let intPairOfEqualSizes format = - fun array -> Utils.createMatrixFromArray2D format array ((=) 0) - |> pairOfMatricesOfEqualSizeGenerator Arb.generate - - let floatPairOfEqualSizes format = - let normalFloatGenerator = - (Arb.Default.NormalFloat() - |> Arb.toGen - |> Gen.map float) - - let fIsEqual x y = abs (x - y) < Accuracy.medium.absolute || x = y - - fun array -> Utils.createMatrixFromArray2D format array (fIsEqual 0.0) - |> pairOfMatricesOfEqualSizeGenerator normalFloatGenerator + pairOfVectorsOfEqualSize Utils.normalFloatGenerator createVector diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/Map2/Map2.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/Map2/Map2.fs new file mode 100644 index 00000000..2e2582f1 --- /dev/null +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/Map2/Map2.fs @@ -0,0 +1,285 @@ +namespace GraphBLAS.FSharp.Benchmarks.Matrix.Map2 + +open System.IO +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.IO +open BenchmarkDotNet.Attributes +open Brahma.FSharp +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Objects.MatrixExtensions +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Benchmarks + +[] +[] +[] +[)>] +type Benchmarks<'matrixT, 'elem when 'matrixT :> IDeviceMemObject and 'elem : struct>( + buildFunToBenchmark, + converter: string -> 'elem, + converterBool, + buildMatrix: Matrix.COO<_> -> Matrix<_>) = + + let mutable funToBenchmark = None + let mutable firstMatrix = Unchecked.defaultof> + let mutable secondMatrix = Unchecked.defaultof> + let mutable firstMatrixHost = Unchecked.defaultof<_> + let mutable secondMatrixHost = Unchecked.defaultof<_> + + member val ResultMatrix = Unchecked.defaultof> with get,set + + [] + member val OclContextInfo = Unchecked.defaultof with get, set + + [] + member val InputMatrixReader = Unchecked.defaultof with get, set + + member this.OclContext: ClContext = (fst this.OclContextInfo).ClContext + member this.WorkGroupSize = snd this.OclContextInfo + + member this.Processor = + let p = (fst this.OclContextInfo).Queue + p.Error.Add(fun e -> failwithf "%A" e) + p + + static member AvailableContexts = Utils.availableContexts + + static member InputMatricesProviderBuilder pathToConfig = + let datasetFolder = "EWiseAdd" + pathToConfig + |> Utils.getMatricesFilenames + |> Seq.map + (fun matrixFilename -> + printfn "%A" matrixFilename + + match Path.GetExtension matrixFilename with + | ".mtx" -> + MtxReader(Utils.getFullPathToMatrix datasetFolder matrixFilename) + , MtxReader(Utils.getFullPathToMatrix datasetFolder ("squared_" + matrixFilename)) + | _ -> failwith "Unsupported matrix format") + + member this.FunToBenchmark = + match funToBenchmark with + | None -> + let x = buildFunToBenchmark this.OclContext this.WorkGroupSize + funToBenchmark <- Some x + x + | Some x -> x + + member this.ReadMatrix (reader: MtxReader) = + let converter = + match reader.Field with + | Pattern -> converterBool + | _ -> converter + + reader.ReadMatrix converter + + member this.EWiseAddition() = + this.ResultMatrix <- this.FunToBenchmark this.Processor HostInterop firstMatrix secondMatrix + + member this.ClearInputMatrices() = + firstMatrix.Dispose this.Processor + secondMatrix.Dispose this.Processor + + member this.ClearResult() = + this.ResultMatrix.Dispose this.Processor + + member this.ReadMatrices() = + firstMatrixHost <- this.ReadMatrix <| fst this.InputMatrixReader + secondMatrixHost <- this.ReadMatrix <| snd this.InputMatrixReader + + member this.LoadMatricesToGPU () = + firstMatrix <- (buildMatrix firstMatrixHost).ToDevice this.OclContext + secondMatrix <- (buildMatrix secondMatrixHost).ToDevice this.OclContext + + abstract member GlobalSetup: unit -> unit + + abstract member Benchmark: unit -> unit + + abstract member IterationCleanup: unit -> unit + + abstract member GlobalCleanup: unit -> unit + +module WithoutTransfer = + type Benchmark<'matrixT, 'elem when 'matrixT :> IDeviceMemObject and 'elem : struct>( + buildFunToBenchmark, + converter: string -> 'elem, + converterBool, + buildMatrix) = + + inherit Benchmarks<'matrixT, 'elem>( + buildFunToBenchmark, + converter, + converterBool, + buildMatrix) + + [] + override this.GlobalSetup() = + this.ReadMatrices () + this.LoadMatricesToGPU () + this.Processor.PostAndReply(Msg.MsgNotifyMe) + + [] + override this.Benchmark () = + this.EWiseAddition() + this.Processor.PostAndReply(Msg.MsgNotifyMe) + + [] + override this.IterationCleanup () = + this.ClearResult() + + [] + override this.GlobalCleanup () = + this.ClearInputMatrices() + + module COO = + type Float32() = + + inherit Benchmark,float32>( + (Matrix.map2 ArithmeticOperations.float32SumOption), + float32, + (fun _ -> Utils.nextSingle (System.Random())), + Matrix.COO + ) + + static member InputMatricesProvider = + Benchmarks<_,_>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32COO.txt" + + type Bool() = + + inherit Benchmark,bool>( + (Matrix.map2 ArithmeticOperations.boolSumOption), + (fun _ -> true), + (fun _ -> true), + Matrix.COO + ) + + static member InputMatricesProvider = + Benchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4BoolCOO.txt" + + module CSR = + type Float32() = + + inherit Benchmark,float32>( + (Matrix.map2 ArithmeticOperations.float32SumOption), + float32, + (fun _ -> Utils.nextSingle (System.Random())), + (fun matrix -> Matrix.CSR matrix.ToCSR) + ) + + static member InputMatricesProvider = + Benchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32CSR.txt" + + type Bool() = + + inherit Benchmark,bool>( + (Matrix.map2 ArithmeticOperations.boolSumOption), + (fun _ -> true), + (fun _ -> true), + (fun matrix -> Matrix.CSR matrix.ToCSR) + ) + + static member InputMatricesProvider = + Benchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4BoolCSR.txt" + + module AtLeastOne = + module COO = + type Bool() = + + inherit Benchmark,bool>( + (Matrix.map2AtLeastOne ArithmeticOperations.boolSumAtLeastOne), + (fun _ -> true), + (fun _ -> true), + Matrix.COO + ) + + static member InputMatricesProvider = + Benchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4BoolCOO.txt" + + type Float32() = + + inherit Benchmark,float32>( + (Matrix.map2AtLeastOne ArithmeticOperations.float32SumAtLeastOne), + float32, + (fun _ -> Utils.nextSingle (System.Random())), + Matrix.COO + ) + + static member InputMatricesProvider = + Benchmarks<_,_>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32COO.txt" + + module CSR = + type Bool() = + + inherit Benchmark,bool>( + (Matrix.map2AtLeastOne ArithmeticOperations.boolSumAtLeastOne), + (fun _ -> true), + (fun _ -> true), + (fun matrix -> Matrix.CSR matrix.ToCSR) + ) + + static member InputMatricesProvider = + Benchmarks<_, _>.InputMatricesProviderBuilder "EWiseAddBenchmarks4BoolCSR.txt" + + type Float32() = + + inherit Benchmark,float32>( + (Matrix.map2AtLeastOne ArithmeticOperations.float32SumAtLeastOne), + float32, + (fun _ -> Utils.nextSingle (System.Random())), + (fun matrix -> Matrix.CSR matrix.ToCSR) + ) + + static member InputMatricesProvider = + Benchmarks<_,_>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32COO.txt" + +module WithTransfer = + type Benchmark<'matrixT, 'elem when 'matrixT :> IDeviceMemObject and 'elem : struct>( + buildFunToBenchmark, + converter: string -> 'elem, + converterBool, + buildMatrix, + resultToHost) = + + inherit Benchmarks<'matrixT, 'elem>( + buildFunToBenchmark, + converter, + converterBool, + buildMatrix) + + [] + override this.GlobalSetup() = + this.ReadMatrices() + + [] + override this.GlobalCleanup() = () + + [] + override this.IterationCleanup() = + this.ClearInputMatrices() + this.ClearResult() + + [] + override this.Benchmark() = + this.LoadMatricesToGPU() + this.EWiseAddition() + this.Processor.PostAndReply Msg.MsgNotifyMe + resultToHost this.ResultMatrix this.Processor |> ignore + this.Processor.PostAndReply Msg.MsgNotifyMe + + module COO = + type Float32() = + + inherit Benchmark,float32>( + (Matrix.map2 ArithmeticOperations.float32SumOption), + float32, + (fun _ -> Utils.nextSingle (System.Random())), + Matrix.COO, + (fun matrix -> matrix.ToHost) + ) + + static member InputMatricesProvider = + Benchmarks<_,_>.InputMatricesProviderBuilder "EWiseAddBenchmarks4Float32COO.txt" + diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMathNET.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/Map2/MathNET.fs similarity index 88% rename from benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMathNET.fs rename to benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/Map2/MathNET.fs index a2d8a564..b0577154 100644 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMathNET.fs +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/Map2/MathNET.fs @@ -1,4 +1,4 @@ -namespace GraphBLAS.FSharp.Benchmarks +namespace GraphBLAS.FSharp.Benchmarks.Matrix.Map2 open System.IO open GraphBLAS.FSharp.Objects @@ -7,12 +7,13 @@ open BenchmarkDotNet.Attributes open MathNet.Numerics.LinearAlgebra open MathNet.Numerics open Microsoft.FSharp.Core +open GraphBLAS.FSharp.Benchmarks [] [] [] -[)>] -type MathNETBenchmark<'elem when 'elem: struct and 'elem :> System.IEquatable<'elem> and 'elem :> System.IFormattable and 'elem :> System.ValueType and 'elem: (new : +[)>] +type MathNET<'elem when 'elem: struct and 'elem :> System.IEquatable<'elem> and 'elem :> System.IFormattable and 'elem :> System.ValueType and 'elem: (new : unit -> 'elem)>(converter: string -> 'elem, converterBool) = do Control.UseNativeMKL() @@ -35,8 +36,8 @@ type MathNETBenchmark<'elem when 'elem: struct and 'elem :> System.IEquatable<'e | Pattern -> converterBool | _ -> converter - let gbMatrix = reader.ReadMatrix converter - MathNETBenchmark<_>.COOMatrixToMathNETSparse gbMatrix + Matrix.COO (reader.ReadMatrix converter) + |> MathNET<_>.COOMatrixToMathNETSparse abstract member GlobalSetup : unit -> unit @@ -46,7 +47,7 @@ type MathNETBenchmark<'elem when 'elem: struct and 'elem :> System.IEquatable<'e type BinOpMathNETBenchmark<'elem when 'elem: struct and 'elem :> System.IEquatable<'elem> and 'elem :> System.IFormattable and 'elem :> System.ValueType and 'elem: (new : unit -> 'elem)>(funToBenchmark, converter: string -> 'elem, converterBool) = - inherit MathNETBenchmark<'elem>(converter, converterBool) + inherit MathNET<'elem>(converter, converterBool) let mutable firstMatrix = Unchecked.defaultof> let mutable secondMatrix = Unchecked.defaultof> diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/SpGeMM/Expand.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/SpGeMM/Expand.fs new file mode 100644 index 00000000..0a7193e7 --- /dev/null +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/SpGeMM/Expand.fs @@ -0,0 +1,149 @@ +module GraphBLAS.FSharp.Benchmarks.Matrix.SpGeMM.Expand + +open System.IO +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.IO +open BenchmarkDotNet.Attributes +open Brahma.FSharp +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Benchmarks +open GraphBLAS.FSharp.Backend + +[] +[] +[] +[)>] +type Benchmarks<'elem when 'elem : struct>( + buildFunToBenchmark, + converter: string -> 'elem, + converterBool, + buildMatrix) = + + let mutable funToBenchmark = None + + let mutable firstMatrix = Unchecked.defaultof> + let mutable secondMatrix = Unchecked.defaultof> + + let mutable firstMatrixHost = Unchecked.defaultof<_> + let mutable secondMatrixHost = Unchecked.defaultof<_> + + member val ResultMatrix = Unchecked.defaultof option> with get, set + + [] + member val OclContextInfo = Unchecked.defaultof with get, set + + [] + member val InputMatrixReader = Unchecked.defaultof with get, set + + member this.OclContext:ClContext = (fst this.OclContextInfo).ClContext + member this.WorkGroupSize = snd this.OclContextInfo + + member this.Processor = + let p = (fst this.OclContextInfo).Queue + p.Error.Add(fun e -> failwithf "%A" e) + p + + static member AvailableContexts = Utils.availableContexts + + static member InputMatrixProviderBuilder pathToConfig = + let datasetFolder = "" + pathToConfig + |> Utils.getMatricesFilenames + |> Seq.map + (fun matrixFilename -> + printfn "%A" matrixFilename + + match Path.GetExtension matrixFilename with + | ".mtx" -> + MtxReader(Utils.getFullPathToMatrix datasetFolder matrixFilename) + | _ -> failwith "Unsupported matrix format") + + member this.FunToBenchmark = + match funToBenchmark with + | None -> + let x = buildFunToBenchmark this.OclContext this.WorkGroupSize + funToBenchmark <- Some x + x + | Some x -> x + + member this.ReadMatrix (reader: MtxReader) = + let converter = + match reader.Field with + | Pattern -> converterBool + | _ -> converter + + reader.ReadMatrix converter + + member this.Mxm() = + this.ResultMatrix <- this.FunToBenchmark this.Processor DeviceOnly firstMatrix secondMatrix + + member this.ClearInputMatrices() = + firstMatrix.Dispose this.Processor + secondMatrix.Dispose this.Processor + + member this.ClearResult() = + match this.ResultMatrix with + | Some matrix -> matrix.Dispose this.Processor + | None -> () + + member this.ReadMatrices() = + firstMatrixHost <- this.ReadMatrix this.InputMatrixReader + secondMatrixHost <- this.ReadMatrix this.InputMatrixReader + + member this.LoadMatricesToGPU () = + firstMatrix <- buildMatrix this.OclContext firstMatrixHost + secondMatrix <- buildMatrix this.OclContext secondMatrixHost + + abstract member GlobalSetup : unit -> unit + + abstract member Benchmark : unit -> unit + + abstract member IterationCleanup : unit -> unit + + abstract member GlobalCleanup : unit -> unit + +module WithoutTransfer = + type Benchmark<'elem when 'elem : struct>( + buildFunToBenchmark, + converter: string -> 'elem, + converterBool, + buildMatrix) = + + inherit Benchmarks<'elem>( + buildFunToBenchmark, + converter, + converterBool, + buildMatrix) + + [] + override this.GlobalSetup() = + this.ReadMatrices() + this.LoadMatricesToGPU() + + [] + override this.Benchmark() = + this.Mxm() + this.Processor.PostAndReply(Msg.MsgNotifyMe) + + [] + override this.IterationCleanup () = + this.ClearResult() + + [] + override this.GlobalCleanup () = + this.ClearInputMatrices() + + type Float32() = + + inherit Benchmark( + Matrix.SpGeMM.expand (fst ArithmeticOperations.float32Add) (fst ArithmeticOperations.float32Mul), + float32, + (fun _ -> Utils.nextSingle (System.Random())), + (fun context matrix -> ClMatrix.CSR <| matrix.ToCSR.ToDevice context) + ) + + static member InputMatrixProvider = + Benchmarks<_>.InputMatrixProviderBuilder "SpGeMM.txt" diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMxm.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/SpGeMM/Masked.fs similarity index 68% rename from benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMxm.fs rename to benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/SpGeMM/Masked.fs index a886736b..2a164021 100644 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/BenchmarksMxm.fs +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Matrix/SpGeMM/Masked.fs @@ -1,20 +1,22 @@ -namespace GraphBLAS.FSharp.Benchmarks +namespace GraphBLAS.FSharp.Benchmarks.Matrix.SpGeMM open System.IO +open GraphBLAS.FSharp.Backend.Quotes open GraphBLAS.FSharp.IO open BenchmarkDotNet.Attributes open Brahma.FSharp open GraphBLAS.FSharp.Objects open GraphBLAS.FSharp.Backend.Objects open GraphBLAS.FSharp.Backend.Matrix -open GraphBLAS.FSharp.Benchmarks.MatrixExtensions open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Benchmarks +open GraphBLAS.FSharp.Backend [] [] [] -[)>] -type MxmBenchmarks<'elem when 'elem : struct>( +[)>] +type Masked<'elem when 'elem : struct>( buildFunToBenchmark, converter: string -> 'elem, converterBool, @@ -48,7 +50,7 @@ type MxmBenchmarks<'elem when 'elem : struct>( p.Error.Add(fun e -> failwithf "%A" e) p - static member AvaliableContexts = Utils.avaliableContexts + static member AvaliableContexts = Utils.availableContexts static member InputMatrixProviderBuilder pathToConfig = let datasetFolder = "Mxm" @@ -75,7 +77,7 @@ type MxmBenchmarks<'elem when 'elem : struct>( member this.FunCSR2CSC = match funCSR2CSC with | None -> - let x = Matrix.toCSCInplace this.OclContext this.WorkGroupSize + let x = Matrix.toCSCInPlace this.OclContext this.WorkGroupSize funCSR2CSC <- Some x x | Some x -> x @@ -83,12 +85,12 @@ type MxmBenchmarks<'elem when 'elem : struct>( member this.FunCSC2CSR = match funCSC2CSR with | None -> - let x = Matrix.toCSRInplace this.OclContext this.WorkGroupSize + let x = Matrix.toCSRInPlace this.OclContext this.WorkGroupSize funCSC2CSR <- Some x x | Some x -> x - member this.ReadMatrix (reader:MtxReader) = + member this.ReadMatrix (reader: MtxReader) = let converter = match reader.Field with | Pattern -> converterBool @@ -108,7 +110,7 @@ type MxmBenchmarks<'elem when 'elem : struct>( this.ResultMatrix.Dispose this.Processor member this.ReadMask(maskReader) = - maskHost <- this.ReadMatrix maskReader + maskHost <- Matrix.COO <| this.ReadMatrix maskReader member this.ReadMatrices() = let matrixReader, maskReader = this.InputMatrixReader @@ -129,19 +131,19 @@ type MxmBenchmarks<'elem when 'elem : struct>( abstract member GlobalSetup : unit -> unit + abstract member Benchmark : unit -> unit + abstract member IterationCleanup : unit -> unit abstract member GlobalCleanup : unit -> unit - abstract member Benchmark : unit -> unit - type MxmBenchmarksMultiplicationOnly<'elem when 'elem : struct>( buildFunToBenchmark, converter: string -> 'elem, converterBool, buildMatrix) = - inherit MxmBenchmarks<'elem>( + inherit Masked<'elem>( buildFunToBenchmark, converter, converterBool, @@ -153,6 +155,11 @@ type MxmBenchmarksMultiplicationOnly<'elem when 'elem : struct>( this.LoadMatricesToGPU () this.ConvertSecondMatrixToCSC() + [] + override this.Benchmark () = + this.Mxm() + this.Processor.PostAndReply(Msg.MsgNotifyMe) + [] override this.IterationCleanup () = this.ClearResult() @@ -161,139 +168,107 @@ type MxmBenchmarksMultiplicationOnly<'elem when 'elem : struct>( override this.GlobalCleanup () = this.ClearInputMatrices() - [] - override this.Benchmark () = - this.Mxm() - this.Processor.PostAndReply(Msg.MsgNotifyMe) - type MxmBenchmarksWithTransposing<'elem when 'elem : struct>( buildFunToBenchmark, converter: string -> 'elem, converterBool, buildMatrix) = - inherit MxmBenchmarks<'elem>( + inherit Masked<'elem>( buildFunToBenchmark, converter, converterBool, buildMatrix) [] - override this.GlobalSetup () = - this.ReadMatrices () + override this.GlobalSetup() = + this.ReadMatrices() this.LoadMatricesToGPU () - [] - override this.GlobalCleanup () = - this.ClearInputMatrices() - - [] - override this.IterationCleanup () = - this.ClearResult() - this.ConvertSecondMatrixToCSR() - [] - override this.Benchmark () = + override this.Benchmark() = this.ConvertSecondMatrixToCSC() this.Mxm() this.Processor.PostAndReply(Msg.MsgNotifyMe) -module Operations = - let add = <@ fun x y -> Some (x + y) @> - - let addWithFilter = <@ fun x y -> - let res = x + y - if abs res < 1e-8f then None else Some res - @> - - let mult = <@ fun x y -> Some (x * y) @> - let logicalOr = <@ fun x y -> - let mutable res = None - - match x, y with - | false, false -> res <- None - | _ -> res <- Some true - - res @> - - let logicalAnd = <@ fun x y -> - let mutable res = None - - match x, y with - | true, true -> res <- Some true - | _ -> res <- None + [] + override this.IterationCleanup() = + this.ClearResult() + this.ConvertSecondMatrixToCSR() - res @> + [] + override this.GlobalCleanup() = + this.ClearInputMatrices() -type MxmBenchmarks4Float32MultiplicationOnly() = +type Mxm4Float32MultiplicationOnlyBenchmark() = inherit MxmBenchmarksMultiplicationOnly( - (Matrix.mxm Operations.add Operations.mult), + Matrix.SpGeMM.masked (fst ArithmeticOperations.float32Add) (fst ArithmeticOperations.float32Mul), float32, (fun _ -> Utils.nextSingle (System.Random())), - (fun context matrix -> ClMatrix.CSR (Matrix.ToBackendCSR context matrix)) + (fun context matrix -> ClMatrix.CSR <| matrix.ToCSR.ToDevice context) ) static member InputMatrixProvider = - MxmBenchmarks<_>.InputMatrixProviderBuilder "MxmBenchmarks4Float32.txt" + Masked<_>.InputMatrixProviderBuilder "MxmBenchmarks4Float32.txt" -type MxmBenchmarks4Float32WithTransposing() = +type Mxm4Float32WithTransposingBenchmark() = inherit MxmBenchmarksWithTransposing( - (Matrix.mxm Operations.add Operations.mult), + Matrix.SpGeMM.masked (fst ArithmeticOperations.float32Add) (fst ArithmeticOperations.float32Mul), float32, (fun _ -> Utils.nextSingle (System.Random())), - (fun context matrix -> ClMatrix.CSR (Matrix.ToBackendCSR context matrix)) + (fun context matrix -> ClMatrix.CSR <| matrix.ToCSR.ToDevice context) ) static member InputMatrixProvider = - MxmBenchmarks<_>.InputMatrixProviderBuilder "MxmBenchmarks4Float32.txt" + Masked<_>.InputMatrixProviderBuilder "MxmBenchmarks4Float32.txt" -type MxmBenchmarks4BoolMultiplicationOnly() = +type Mxm4BoolMultiplicationOnlyBenchmark() = inherit MxmBenchmarksMultiplicationOnly( - (Matrix.mxm Operations.logicalOr Operations.logicalAnd), + (Matrix.SpGeMM.masked (fst ArithmeticOperations.boolAdd) (fst ArithmeticOperations.boolMul)), (fun _ -> true), (fun _ -> true), - (fun context matrix -> ClMatrix.CSR (Matrix.ToBackendCSR context matrix)) + (fun context matrix -> ClMatrix.CSR <| matrix.ToCSR.ToDevice context) ) static member InputMatrixProvider = - MxmBenchmarks<_>.InputMatrixProviderBuilder "MxmBenchmarks4Bool.txt" + Masked<_>.InputMatrixProviderBuilder "MxmBenchmarks4Bool.txt" -type MxmBenchmarks4BoolWithTransposing() = +type Mxm4BoolWithTransposingBenchmark() = inherit MxmBenchmarksWithTransposing( - (Matrix.mxm Operations.logicalOr Operations.logicalAnd), + (Matrix.SpGeMM.masked (fst ArithmeticOperations.boolAdd) (fst ArithmeticOperations.boolMul)), (fun _ -> true), (fun _ -> true), - (fun context matrix -> ClMatrix.CSR (Matrix.ToBackendCSR context matrix)) + (fun context matrix -> ClMatrix.CSR <| matrix.ToCSR.ToDevice context) ) static member InputMatrixProvider = - MxmBenchmarks<_>.InputMatrixProviderBuilder "MxmBenchmarks4Bool.txt" + Masked<_>.InputMatrixProviderBuilder "MxmBenchmarks4Bool.txt" -type MxmBenchmarks4Float32MultiplicationOnlyWithZerosFilter() = +type Mxm4Float32MultiplicationOnlyWithZerosFilterBenchmark() = inherit MxmBenchmarksMultiplicationOnly( - (Matrix.mxm Operations.addWithFilter Operations.mult), + (Matrix.SpGeMM.masked (fst ArithmeticOperations.float32Add) (fst ArithmeticOperations.float32Mul)), float32, (fun _ -> Utils.nextSingle (System.Random())), - (fun context matrix -> ClMatrix.CSR (Matrix.ToBackendCSR context matrix)) + (fun context matrix -> ClMatrix.CSR <| matrix.ToCSR.ToDevice context) ) static member InputMatrixProvider = - MxmBenchmarks<_>.InputMatrixProviderBuilder "MxmBenchmarks4Float32.txt" + Masked<_>.InputMatrixProviderBuilder "MxmBenchmarks4Float32.txt" -type MxmBenchmarks4Float32WithTransposingWithZerosFilter() = +type Mxm4Float32WithTransposingWithZerosFilterBenchmark() = inherit MxmBenchmarksWithTransposing( - (Matrix.mxm Operations.addWithFilter Operations.mult), + Matrix.SpGeMM.masked (fst ArithmeticOperations.float32Add) (fst ArithmeticOperations.float32Mul), float32, (fun _ -> Utils.nextSingle (System.Random())), - (fun context matrix -> ClMatrix.CSR (Matrix.ToBackendCSR context matrix)) + (fun context matrix -> ClMatrix.CSR <| matrix.ToCSR.ToDevice context) ) static member InputMatrixProvider = - MxmBenchmarks<_>.InputMatrixProviderBuilder "MxmBenchmarks4Float32.txt" + Masked<_>.InputMatrixProviderBuilder "MxmBenchmarks4Float32.txt" diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/MatrixExtensions.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/MatrixExtensions.fs deleted file mode 100644 index ed84bcee..00000000 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/MatrixExtensions.fs +++ /dev/null @@ -1,91 +0,0 @@ -namespace GraphBLAS.FSharp.Benchmarks - -open GraphBLAS.FSharp.Objects -open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Objects.ClMatrix - -module MatrixExtensions = - type Matrix<'a when 'a : struct> with - static member ToBackendCOO (context: ClContext) matrix = - match matrix with - | Matrix.COO m -> - let rows = - context.CreateClArray( - m.Rows, - hostAccessMode = HostAccessMode.ReadOnly, - deviceAccessMode = DeviceAccessMode.ReadOnly, - allocationMode = AllocationMode.CopyHostPtr - ) - - let cols = - context.CreateClArray( - m.Columns, - hostAccessMode = HostAccessMode.ReadOnly, - deviceAccessMode = DeviceAccessMode.ReadOnly, - allocationMode = AllocationMode.CopyHostPtr - ) - - let vals = - context.CreateClArray( - m.Values, - hostAccessMode = HostAccessMode.ReadOnly, - deviceAccessMode = DeviceAccessMode.ReadOnly, - allocationMode = AllocationMode.CopyHostPtr - ) - - { Context = context - RowCount = m.RowCount - ColumnCount = m.ColumnCount - Rows = rows - Columns = cols - Values = vals } - - | _ -> failwith "Unsupported matrix format: %A" - - static member ToBackendCSR (context: ClContext) matrix = - let rowIndices2rowPointers (rowIndices: int []) rowCount = - let nnzPerRow = Array.zeroCreate rowCount - let rowPointers = Array.zeroCreate rowCount - - Array.iter (fun rowIndex -> nnzPerRow.[rowIndex] <- nnzPerRow.[rowIndex] + 1) rowIndices - - for i in 1 .. rowCount - 1 do - rowPointers.[i] <- rowPointers.[i - 1] + nnzPerRow.[i - 1] - - rowPointers - - match matrix with - | Matrix.COO m -> - let rowPointers = - context.CreateClArray( - rowIndices2rowPointers m.Rows m.RowCount, - hostAccessMode = HostAccessMode.ReadOnly, - deviceAccessMode = DeviceAccessMode.ReadOnly, - allocationMode = AllocationMode.CopyHostPtr - ) - - let cols = - context.CreateClArray( - m.Columns, - hostAccessMode = HostAccessMode.ReadOnly, - deviceAccessMode = DeviceAccessMode.ReadOnly, - allocationMode = AllocationMode.CopyHostPtr - ) - - let vals = - context.CreateClArray( - m.Values, - hostAccessMode = HostAccessMode.ReadOnly, - deviceAccessMode = DeviceAccessMode.ReadOnly, - allocationMode = AllocationMode.CopyHostPtr - ) - - { Context = context - RowCount = m.RowCount - ColumnCount = m.ColumnCount - RowPointers = rowPointers - Columns = cols - Values = vals } - - | _ -> failwith "Unsupported matrix format: %A" - diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Program.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Program.fs index 20749b67..5a3ccf37 100644 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/Program.fs +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Program.fs @@ -4,7 +4,7 @@ open BenchmarkDotNet.Running [] let main argv = let benchmarks = - BenchmarkSwitcher [| typeof |] + BenchmarkSwitcher [| typeof |] benchmarks.Run argv |> ignore 0 diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/Vector/Map2.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/Vector/Map2.fs new file mode 100644 index 00000000..523f5185 --- /dev/null +++ b/benchmarks/GraphBLAS-sharp.Benchmarks/Vector/Map2.fs @@ -0,0 +1,201 @@ +module GraphBLAS.FSharp.Benchmarks.Vector.Map2 + +open FsCheck +open BenchmarkDotNet.Attributes + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Benchmarks +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Objects.ClVectorExtensions +open GraphBLAS.FSharp.Backend.Vector +open GraphBLAS.FSharp.Backend.Objects.ClContext + +[] +[] +[] +[)>] +type Benchmarks<'elem when 'elem : struct>( + buildFunToBenchmark, + generator: Gen * Vector<'elem>>) = + + let mutable funToBenchmark = None + + let mutable firstVector = Unchecked.defaultof> + + let mutable secondVector = Unchecked.defaultof> + + member val HostVectorPair = Unchecked.defaultof * Vector<'elem>> with get, set + + member val ResultVector = Unchecked.defaultof> with get,set + + [] + member val OclContextInfo = Unchecked.defaultof with get, set + + [] + member val Size = Unchecked.defaultof with get, set + + member this.OclContext: ClContext = (fst this.OclContextInfo).ClContext + member this.WorkGroupSize = snd this.OclContextInfo + + member this.Processor = + let p = (fst this.OclContextInfo).Queue + p.Error.Add(fun e -> failwithf $"%A{e}") + p + + static member AvailableContexts = Utils.availableContexts + + member this.FunToBenchmark = + match funToBenchmark with + | None -> + let x = buildFunToBenchmark this.OclContext this.WorkGroupSize + funToBenchmark <- Some x + x + | Some x -> x + + member this.Map2() = + try + + this.ResultVector <- this.FunToBenchmark this.Processor HostInterop firstVector secondVector + + with + | ex when ex.Message = "InvalidBufferSize" -> () + | ex -> raise ex + + member this.ClearInputVectors()= + firstVector.Dispose this.Processor + secondVector.Dispose this.Processor + + member this.ClearResult() = + this.ResultVector.Dispose this.Processor + + member this.CreateVectors() = + this.HostVectorPair <- List.last (Gen.sample this.Size 1 generator) + + member this.LoadVectorsToGPU() = + firstVector <- (fst this.HostVectorPair).ToDevice this.OclContext + secondVector <- (snd this.HostVectorPair).ToDevice this.OclContext + + abstract member GlobalSetup: unit -> unit + + abstract member IterationSetup: unit -> unit + + abstract member Benchmark: unit -> unit + + abstract member IterationCleanup: unit -> unit + + abstract member GlobalCleanup: unit -> unit + +module WithoutTransfer = + type Benchmark<'elem when 'elem : struct>( + buildFunToBenchmark, + generator) = + + inherit Benchmarks<'elem>( + buildFunToBenchmark, + generator) + + [] + override this.GlobalSetup() = () + + [] + override this.IterationSetup() = + this.CreateVectors() + this.LoadVectorsToGPU() + this.Processor.PostAndReply Msg.MsgNotifyMe + + [] + override this.Benchmark() = + this.Map2() + this.Processor.PostAndReply Msg.MsgNotifyMe + + [] + override this.IterationCleanup() = + this.ClearResult() + this.ClearInputVectors() + + [] + override this.GlobalCleanup() = () + + type Float() = + + inherit Benchmark( + (Vector.map2 ArithmeticOperations.floatSumOption), + VectorGenerator.floatPair Sparse) + + type Int32() = + + inherit Benchmark( + (Vector.map2 ArithmeticOperations.intSumOption), + VectorGenerator.intPair Sparse) + + module AtLeastOne = + type Float() = + + inherit Benchmark( + (Vector.map2AtLeastOne ArithmeticOperations.floatSumAtLeastOne), + VectorGenerator.floatPair Sparse) + + type Int32() = + + inherit Benchmark( + (Vector.map2AtLeastOne ArithmeticOperations.intSumAtLeastOne), + VectorGenerator.intPair Sparse) + +module WithTransfer = + type Benchmark<'elem when 'elem : struct>( + buildFunToBenchmark, + generator) = + + inherit Benchmarks<'elem>( + buildFunToBenchmark, + generator) + + [] + override this.GlobalSetup() = () + + [] + override this.IterationSetup() = + this.CreateVectors() + + [] + override this.Benchmark () = + this.LoadVectorsToGPU() + this.Map2() + this.ResultVector.ToHost this.Processor |> ignore + this.Processor.PostAndReply Msg.MsgNotifyMe + + [] + override this.IterationCleanup () = + this.ClearInputVectors() + this.ClearResult() + + [] + override this.GlobalCleanup() = () + + type Float() = + + inherit Benchmark( + (Vector.map2 ArithmeticOperations.floatSumOption), + VectorGenerator.floatPair Sparse) + + type Int32() = + + inherit Benchmark( + (Vector.map2 ArithmeticOperations.intSumOption), + VectorGenerator.intPair Sparse) + + module AtLeastOne = + type Float() = + + inherit Benchmark( + (Vector.map2AtLeastOne ArithmeticOperations.floatSumAtLeastOne), + VectorGenerator.floatPair Sparse) + + type Int32() = + + inherit Benchmark( + (Vector.map2AtLeastOne ArithmeticOperations.intSumAtLeastOne), + VectorGenerator.intPair Sparse) diff --git a/benchmarks/GraphBLAS-sharp.Benchmarks/VectorEWiseAddGen.fs b/benchmarks/GraphBLAS-sharp.Benchmarks/VectorEWiseAddGen.fs deleted file mode 100644 index 935ca206..00000000 --- a/benchmarks/GraphBLAS-sharp.Benchmarks/VectorEWiseAddGen.fs +++ /dev/null @@ -1,211 +0,0 @@ -namespace GraphBLAS.FSharp.Benchmarks - -open Expecto -open FsCheck -open BenchmarkDotNet.Attributes -open BenchmarkDotNet.Configs -open BenchmarkDotNet.Columns -open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Objects -open GraphBLAS.FSharp.Backend.Quotes -open GraphBLAS.FSharp.Tests -open GraphBLAS.FSharp.Objects -open GraphBLAS.FSharp.Objects.ClVectorExtensions -open GraphBLAS.FSharp.Backend.Vector -open GraphBLAS.FSharp.Backend.Objects.ClContext - -type VectorConfig() = - inherit ManualConfig() - - do - base.AddColumn( - StatisticColumn.Min, - StatisticColumn.Max - ) - |> ignore - -[] -[] -[] -[)>] -type VectorEWiseBenchmarks<'elem when 'elem : struct>( - buildFunToBenchmark, - generator: Gen * Vector<'elem>>) = - - let mutable funToBenchmark = None - - let mutable firstVector = Unchecked.defaultof> - - let mutable secondVector = Unchecked.defaultof> - - member val HostVectorPair = Unchecked.defaultof * Vector<'elem>> with get, set - - member val ResultVector = Unchecked.defaultof> with get,set - - [] - member val OclContextInfo = Unchecked.defaultof with get, set - - [] - member val Size = Unchecked.defaultof with get, set - - member this.OclContext: ClContext = (fst this.OclContextInfo).ClContext - member this.WorkGroupSize = snd this.OclContextInfo - - member this.Processor = - let p = (fst this.OclContextInfo).Queue - p.Error.Add(fun e -> failwithf "%A" e) - p - - static member AvaliableContexts = Utils.avaliableContexts - - member this.FunToBenchmark = - match funToBenchmark with - | None -> - let x = buildFunToBenchmark this.OclContext this.WorkGroupSize - funToBenchmark <- Some x - x - | Some x -> x - - member this.EWiseAddition() = - this.ResultVector <- this.FunToBenchmark this.Processor HostInterop firstVector secondVector - - member this.ClearInputVectors()= - firstVector.Dispose this.Processor - secondVector.Dispose this.Processor - - member this.ClearResult() = - this.ResultVector.Dispose this.Processor - - member this.CreateVectors() = - this.HostVectorPair <- List.last (Gen.sample this.Size 1 generator) - - member this.LoadVectorsToGPU() = - firstVector <- (fst this.HostVectorPair).ToDevice this.OclContext - secondVector <- (snd this.HostVectorPair).ToDevice this.OclContext - - abstract member GlobalSetup : unit -> unit - - abstract member IterationSetup: unit -> unit - - abstract member Benchmark : unit -> unit - - abstract member IterationCleanup : unit -> unit - - abstract member GlobalCleanup : unit -> unit - - -type VectorEWiseBenchmarksWithoutDataTransfer<'elem when 'elem : struct>( - buildFunToBenchmark, - generator) = - - inherit VectorEWiseBenchmarks<'elem>( - buildFunToBenchmark, - generator) - - [] - override this.GlobalSetup() = () - - [] - override this.IterationSetup() = - this.CreateVectors () - this.LoadVectorsToGPU () - - [] - override this.Benchmark () = - this.EWiseAddition() - this.Processor.PostAndReply(Msg.MsgNotifyMe) - - [] - override this.IterationCleanup () = - this.ClearResult() - this.ClearInputVectors() - - [] - override this.GlobalCleanup() = () - -type VectorEWiseBenchmarksWithDataTransfer<'elem when 'elem : struct>( - buildFunToBenchmark, - generator) = - - inherit VectorEWiseBenchmarks<'elem>( - buildFunToBenchmark, - generator) - - [] - override this.GlobalSetup() = () - - [] - override this.IterationSetup() = - this.CreateVectors() - - [] - override this.Benchmark () = - this.LoadVectorsToGPU() - this.EWiseAddition() - this.Processor.PostAndReply Msg.MsgNotifyMe - this.ResultVector.ToHost this.Processor |> ignore - this.Processor.PostAndReply Msg.MsgNotifyMe - - [] - override this.IterationCleanup () = - this.ClearInputVectors() - this.ClearResult() - - [] - override this.GlobalCleanup() = () - -/// Without data transfer - -type VectorEWiseBenchmarks4FloatSparseWithoutDataTransfer() = - - inherit VectorEWiseBenchmarksWithoutDataTransfer( - (fun context -> Vector.map2 context ArithmeticOperations.floatSum), - VectorGenerator.floatPair Sparse) - -type VectorEWiseBenchmarks4Int32SparseWithoutDataTransfer() = - - inherit VectorEWiseBenchmarksWithoutDataTransfer( - (fun context -> Vector.map2 context ArithmeticOperations.intSum), - VectorGenerator.intPair Sparse) - -/// General - -type VectorEWiseGeneralBenchmarks4FloatSparseWithoutDataTransfer() = - - inherit VectorEWiseBenchmarksWithoutDataTransfer( - (fun context -> Vector.map2General context ArithmeticOperations.floatSum), - VectorGenerator.floatPair Sparse) - -type VectorEWiseGeneralBenchmarks4Int32SparseWithoutDataTransfer() = - - inherit VectorEWiseBenchmarksWithoutDataTransfer( - (fun context -> Vector.map2General context ArithmeticOperations.intSum), - VectorGenerator.intPair Sparse) - -/// With data transfer - -type VectorEWiseBenchmarks4FloatSparseWithDataTransfer() = - - inherit VectorEWiseBenchmarksWithDataTransfer( - (fun context -> Vector.map2 context ArithmeticOperations.floatSum), - VectorGenerator.floatPair Sparse) - -type VectorEWiseBenchmarks4Int32SparseWithDataTransfer() = - - inherit VectorEWiseBenchmarksWithDataTransfer( - (fun context -> Vector.map2 context ArithmeticOperations.intSum), - VectorGenerator.intPair Sparse) - -/// General with data transfer - -type VectorEWiseGeneralBenchmarks4FloatSparseWithDataTransfer() = - - inherit VectorEWiseBenchmarksWithDataTransfer( - (fun context -> Vector.map2General context ArithmeticOperations.floatSum), - VectorGenerator.floatPair Sparse) - -type VectorEWiseGeneralBenchmarks4Int32SparseWithDataTransfer() = - - inherit VectorEWiseBenchmarksWithDataTransfer( - (fun context -> Vector.map2General context ArithmeticOperations.intSum), - VectorGenerator.intPair Sparse) diff --git a/paket.dependencies b/paket.dependencies index c1c5211c..a434e23e 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -59,4 +59,4 @@ group Docs group Analyzers source https://www.nuget.org/api/v2 source https://api.nuget.org/v3/index.json - nuget BinaryDefense.FSharp.Analyzers.Hashing 0.2.2 + nuget BinaryDefense.FSharp.Analyzers.Hashing 0.2.2 \ No newline at end of file diff --git a/src/GraphBLAS-sharp.Backend/Algorithms/BFS.fs b/src/GraphBLAS-sharp.Backend/Algorithms/BFS.fs index 570688cc..9896a557 100644 --- a/src/GraphBLAS-sharp.Backend/Algorithms/BFS.fs +++ b/src/GraphBLAS-sharp.Backend/Algorithms/BFS.fs @@ -14,14 +14,14 @@ open GraphBLAS.FSharp.Backend.Objects.ClCell module BFS = let singleSource - (clContext: ClContext) (add: Expr int option -> int option>) (mul: Expr<'a option -> int option -> int option>) + (clContext: ClContext) workGroupSize = let spMVTo = - SpMV.runTo clContext add mul workGroupSize + SpMV.runTo add mul clContext workGroupSize let zeroCreate = ClArray.zeroCreate clContext workGroupSize @@ -29,13 +29,13 @@ module BFS = let ofList = Vector.ofList clContext workGroupSize let maskComplementedTo = - DenseVector.map2Inplace clContext Mask.complementedOp workGroupSize + Vector.map2InPlace Mask.complementedOp clContext workGroupSize let fillSubVectorTo = - DenseVector.assignByMaskInplace clContext (Convert.assignToOption Mask.assign) workGroupSize + Vector.assignByMaskInPlace (Convert.assignToOption Mask.assign) clContext workGroupSize let containsNonZero = - ClArray.exists clContext workGroupSize Predicates.isSome + ClArray.exists Predicates.isSome clContext workGroupSize fun (queue: MailboxProcessor) (matrix: ClMatrix.CSR<'a>) (source: int) -> let vertexCount = matrix.RowCount @@ -67,7 +67,7 @@ module BFS = not <| (containsNonZero queue front).ToHostAndFree queue - front.Dispose queue + front.Free queue levels | _ -> failwith "Not implemented" diff --git a/src/GraphBLAS-sharp.Backend/COOVector/AssignSubVector.fs b/src/GraphBLAS-sharp.Backend/COOVector/AssignSubVector.fs deleted file mode 100644 index 83667528..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/AssignSubVector.fs +++ /dev/null @@ -1,45 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.COOVector.Utilities -open GraphBLAS.FSharp.Backend.COOVector.Utilities.AssignSubVector - -module internal AssignSubVector = - let private runNotEmpty - (leftIndices: int []) - (leftValues: 'a []) - (rightIndices: int []) - (rightValues: 'a []) - (maskIndices: int []) - : ClTask = - opencl { - let! bitmap, maskValues = intersect rightIndices rightValues maskIndices - - let! resultIndices, resultValues, rawPositions = filter leftIndices leftValues maskIndices maskValues bitmap - - let! rawPositions = preparePositions resultIndices rawPositions - - return! setPositions resultIndices resultValues rawPositions - } - - let run - (leftIndices: int []) - (leftValues: 'a []) - (rightIndices: int []) - (rightValues: 'a []) - (maskIndices: int []) - : ClTask = - if leftValues.Length = 0 then - opencl { - let! resultIndices = Copy.copyArray rightIndices - let! resultValues = Copy.copyArray rightValues - - return resultIndices, resultValues - } - - elif rightIndices.Length = 0 then - opencl { return leftIndices, leftValues } - - else - runNotEmpty leftIndices leftValues rightIndices rightValues maskIndices diff --git a/src/GraphBLAS-sharp.Backend/COOVector/EWiseAdd.fs b/src/GraphBLAS-sharp.Backend/COOVector/EWiseAdd.fs deleted file mode 100644 index 791670e3..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/EWiseAdd.fs +++ /dev/null @@ -1,52 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.COOVector.Utilities -open GraphBLAS.FSharp.Backend.COOVector.Utilities.EWiseAdd - -module internal EWiseAdd = - let private runNonEmpty - (leftIndices: int []) - (leftValues: 'a []) - (rightIndices: int []) - (rightValues: 'a []) - (mask: Mask1D option) - (semiring: ISemiring<'a>) - : ClTask = - opencl { - let! allIndices, allValues = merge leftIndices leftValues rightIndices rightValues mask - - let (ClosedBinaryOp plus) = semiring.Plus - let! rawPositions = preparePositions allIndices allValues plus - - return! setPositions allIndices allValues rawPositions - } - - let run - (leftIndices: int []) - (leftValues: 'a []) - (rightIndices: int []) - (rightValues: 'a []) - (mask: Mask1D option) - (semiring: ISemiring<'a>) - : ClTask = - if leftValues.Length = 0 then - opencl { - let! resultIndices = Copy.copyArray rightIndices - let! resultValues = Copy.copyArray rightValues - - return resultIndices, resultValues - } - - elif rightIndices.Length = 0 then - opencl { - let! resultIndices = Copy.copyArray leftIndices - let! resultValues = Copy.copyArray leftValues - - return resultIndices, resultValues - } - - else - runNonEmpty leftIndices leftValues rightIndices rightValues mask semiring diff --git a/src/GraphBLAS-sharp.Backend/COOVector/FillSubVector.fs b/src/GraphBLAS-sharp.Backend/COOVector/FillSubVector.fs deleted file mode 100644 index f28a20f7..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/FillSubVector.fs +++ /dev/null @@ -1,36 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.COOVector.Utilities -open GraphBLAS.FSharp.Backend.COOVector.Utilities.FillSubVector - -module internal FillSubVector = - let private runNotEmpty - (leftIndices: int []) - (leftValues: 'a []) - (rightIndices: int []) - (scalar: 'a []) - : ClTask = - opencl { - let! allIndices, allValues = merge leftIndices leftValues rightIndices scalar - - let! rawPositions = preparePositions allIndices - - return! setPositions allIndices allValues rawPositions - } - - let run (leftIndices: int []) (leftValues: 'a []) (rightIndices: int []) (scalar: 'a []) : ClTask = - if leftValues.Length = 0 then - opencl { - let! resultIndices = Copy.copyArray rightIndices - let! resultValues = Replicate.run rightIndices.Length scalar - - return resultIndices, resultValues - } - - elif rightIndices.Length = 0 then - opencl { return leftIndices, leftValues } - - else - runNotEmpty leftIndices leftValues rightIndices scalar diff --git a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/Filter.fs b/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/Filter.fs deleted file mode 100644 index 8d2daae1..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/Filter.fs +++ /dev/null @@ -1,161 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector.Utilities.AssignSubVector - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend.Common - -[] -module internal Filter = - let filter - (leftIndices: int []) - (leftValues: 'a []) - (rightIndices: int []) - (rightValues: 'a []) - (bitmap: bool []) - : ClTask = - opencl { - let workGroupSize = Utils.defaultWorkGroupSize - let firstSide = leftValues.Length - let secondSide = rightIndices.Length - let sumOfSides = firstSide + secondSide - - let merge = - <@ fun (ndRange: Range1D) (firstIndicesBuffer: int []) (firstValuesBuffer: 'a []) (secondIndicesBuffer: int []) (secondValuesBuffer: 'a []) (bitmapBuffer: bool []) (allIndicesBuffer: int []) (allValuesBuffer: 'a []) (rawPositionsBuffer: int []) -> - - let i = ndRange.GlobalID0 - - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 - - if localID < 2 then - let mutable x = localID * (workGroupSize - 1) + i - 1 - - if x >= sumOfSides then - x <- sumOfSides - 1 - - let diagonalNumber = x - - let mutable leftEdge = diagonalNumber + 1 - secondSide - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstSide - 1 - - if rightEdge > diagonalNumber then - rightEdge <- diagonalNumber - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = firstIndicesBuffer.[middleIdx] - - let secondIndex = - secondIndicesBuffer.[diagonalNumber - middleIdx] - - if firstIndex <= secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge - - barrier () - - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength - - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx - - let secondLocalLength = x - - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize - - if localID < firstLocalLength then - localIndices.[localID] <- firstIndicesBuffer.[beginIdx + localID] - - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- secondIndicesBuffer.[i - beginIdx] - - barrier () - - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstLocalLength - 1 - - if rightEdge > localID then - rightEdge <- localID - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] - - let secondIndex = - localIndices.[firstLocalLength + localID - middleIdx] - - if firstIndex <= secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - let boundaryX = rightEdge - let boundaryY = localID - leftEdge - - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 - - let mutable fstIdx = 0 - - if isValidX then - fstIdx <- localIndices.[boundaryX] - - let mutable sndIdx = 0 - - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] - - if not isValidX || isValidY && fstIdx <= sndIdx then - allIndicesBuffer.[i] <- sndIdx - - if bitmapBuffer.[i - localID - beginIdx + boundaryY] then - allValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] - else - rawPositionsBuffer.[i] <- 0 - else - allIndicesBuffer.[i] <- fstIdx - allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] @> - - let resultValues = - Array.create sumOfSides Unchecked.defaultof<'a> - - let resultIndices = Array.zeroCreate sumOfSides - let rawPositions = Array.create sumOfSides 1 - - do! - runCommand merge - <| fun kernelPrepare -> - let ndRange = - Range1D(Utils.getDefaultGlobalSize sumOfSides, workGroupSize) - - kernelPrepare - ndRange - leftIndices - leftValues - rightIndices - rightValues - bitmap - resultIndices - resultValues - rawPositions - - return resultIndices, resultValues, rawPositions - } diff --git a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/Intersect.fs b/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/Intersect.fs deleted file mode 100644 index 78e562af..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/Intersect.fs +++ /dev/null @@ -1,140 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector.Utilities.AssignSubVector - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend.Common - -[] -module internal Intersect = - let intersect (leftIndices: int []) (leftValues: 'a []) (rightIndices: int []) : ClTask = - opencl { - let workGroupSize = Utils.defaultWorkGroupSize - let firstSide = leftValues.Length - let secondSide = rightIndices.Length - let sumOfSides = firstSide + secondSide - - let merge = - <@ fun (ndRange: Range1D) (firstIndicesBuffer: int []) (firstValuesBuffer: 'a []) (secondIndicesBuffer: int []) (bitmapBuffer: bool []) (resultValuesBuffer: 'a []) -> - - let i = ndRange.GlobalID0 - - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 - - if localID < 2 then - let mutable x = localID * (workGroupSize - 1) + i - 1 - - if x >= sumOfSides then - x <- sumOfSides - 1 - - let diagonalNumber = x - - let mutable leftEdge = diagonalNumber + 1 - secondSide - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstSide - 1 - - if rightEdge > diagonalNumber then - rightEdge <- diagonalNumber - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = firstIndicesBuffer.[middleIdx] - - let secondIndex = - secondIndicesBuffer.[diagonalNumber - middleIdx] - - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge - - barrier () - - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength - - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx - - let secondLocalLength = x - - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize - - if localID < firstLocalLength then - localIndices.[localID] <- firstIndicesBuffer.[beginIdx + localID] - - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- secondIndicesBuffer.[i - beginIdx] - - barrier () - - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstLocalLength - 1 - - if rightEdge > localID then - rightEdge <- localID - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] - - let secondIndex = - localIndices.[firstLocalLength + localID - middleIdx] - - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - let boundaryX = rightEdge - let boundaryY = localID - leftEdge - - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 - - let mutable fstIdx = 0 - - if isValidX then - fstIdx <- localIndices.[boundaryX] - - let mutable sndIdx = 0 - - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] - - if not isValidX || isValidY && fstIdx = sndIdx then - bitmapBuffer.[i - localID - beginIdx + boundaryY] <- true - - resultValuesBuffer.[i - localID - beginIdx + boundaryY] <- - firstValuesBuffer.[beginIdx + boundaryX] @> - - let bitmap = Array.zeroCreate secondSide - - let resultValues = - Array.create secondSide Unchecked.defaultof<'a> - - do! - runCommand merge - <| fun kernelPrepare -> - let ndRange = - Range1D(Utils.getDefaultGlobalSize sumOfSides, workGroupSize) - - kernelPrepare ndRange leftIndices leftValues rightIndices bitmap resultValues - - return bitmap, resultValues - } diff --git a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/PreparePositions.fs b/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/PreparePositions.fs deleted file mode 100644 index 19c97e64..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/AssignSubVector/PreparePositions.fs +++ /dev/null @@ -1,30 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector.Utilities.AssignSubVector - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend.Common - -[] -module internal PreparePositions = - let preparePositions (allIndices: int []) (rawPositions: int []) : ClTask = - opencl { - let length = allIndices.Length - - let preparePositions = - <@ fun (ndRange: Range1D) (allIndicesBuffer: int []) (rawPositionsBuffer: int []) -> - - let i = ndRange.GlobalID0 - - if i < length - 1 - && allIndicesBuffer.[i] = allIndicesBuffer.[i + 1] then - rawPositionsBuffer.[i] <- 0 @> - - do! - runCommand preparePositions - <| fun kernelPrepare -> - let ndRange = - Range1D(Utils.getDefaultGlobalSize (length - 1), Utils.defaultWorkGroupSize) - - kernelPrepare ndRange allIndices rawPositions - - return rawPositions - } diff --git a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/EWiseAdd/Merge.fs b/src/GraphBLAS-sharp.Backend/COOVector/Utilities/EWiseAdd/Merge.fs deleted file mode 100644 index 0a654596..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/EWiseAdd/Merge.fs +++ /dev/null @@ -1,148 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector.Utilities.EWiseAdd - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Backend.Common - -[] -module internal Merge = - let merge - (leftIndices: int []) - (leftValues: 'a []) - (rightIndices: int []) - (rightValues: 'a []) - (mask: Mask1D option) - : ClTask = - opencl { - let workGroupSize = Utils.defaultWorkGroupSize - let firstSide = leftValues.Length - let secondSide = rightValues.Length - let sumOfSides = firstSide + secondSide - - let merge = - <@ fun (ndRange: Range1D) (firstIndicesBuffer: int []) (firstValuesBuffer: 'a []) (secondIndicesBuffer: int []) (secondValuesBuffer: 'a []) (allIndicesBuffer: int []) (allValuesBuffer: 'a []) -> - - let i = ndRange.GlobalID0 - - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 - - if localID < 2 then - let mutable x = localID * (workGroupSize - 1) + i - 1 - - if x >= sumOfSides then - x <- sumOfSides - 1 - - let diagonalNumber = x - - let mutable leftEdge = diagonalNumber + 1 - secondSide - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstSide - 1 - - if rightEdge > diagonalNumber then - rightEdge <- diagonalNumber - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = firstIndicesBuffer.[middleIdx] - - let secondIndex = - secondIndicesBuffer.[diagonalNumber - middleIdx] - - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge - - barrier () - - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength - - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx - - let secondLocalLength = x - - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize - - if localID < firstLocalLength then - localIndices.[localID] <- firstIndicesBuffer.[beginIdx + localID] - - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- secondIndicesBuffer.[i - beginIdx] - - barrier () - - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstLocalLength - 1 - - if rightEdge > localID then - rightEdge <- localID - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] - - let secondIndex = - localIndices.[firstLocalLength + localID - middleIdx] - - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - let boundaryX = rightEdge - let boundaryY = localID - leftEdge - - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 - - let mutable fstIdx = 0 - - if isValidX then - fstIdx <- localIndices.[boundaryX] - - let mutable sndIdx = 0 - - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] - - if not isValidX || isValidY && fstIdx < sndIdx then - allIndicesBuffer.[i] <- sndIdx - allValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] - else - allIndicesBuffer.[i] <- fstIdx - allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] @> - - let allIndices = Array.zeroCreate sumOfSides - - let allValues = - Array.create sumOfSides Unchecked.defaultof<'a> - - do! - runCommand merge - <| fun kernelPrepare -> - let ndRange = - Range1D(Utils.getDefaultGlobalSize sumOfSides, workGroupSize) - - kernelPrepare ndRange leftIndices leftValues rightIndices rightValues allIndices allValues - - return allIndices, allValues - } diff --git a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/EWiseAdd/PreparePositions.fs b/src/GraphBLAS-sharp.Backend/COOVector/Utilities/EWiseAdd/PreparePositions.fs deleted file mode 100644 index 08fc688b..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/EWiseAdd/PreparePositions.fs +++ /dev/null @@ -1,40 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector.Utilities.EWiseAdd - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend.Common -open Microsoft.FSharp.Quotations - -[] -module internal PreparePositions = - let preparePositions (allIndices: int []) (allValues: 'a []) (plus: Expr<'a -> 'a -> 'a>) : ClTask = - opencl { - let length = allValues.Length - - let preparePositions = - <@ fun (ndRange: Range1D) (allIndicesBuffer: int []) (allValuesBuffer: 'a []) (rawPositionsBuffer: int []) -> - - let i = ndRange.GlobalID0 - - if i < length - 1 - && allIndicesBuffer.[i] = allIndicesBuffer.[i + 1] then - rawPositionsBuffer.[i] <- 0 - - //Do not drop explicit zeroes - allValuesBuffer.[i + 1] <- (%plus) allValuesBuffer.[i] allValuesBuffer.[i + 1] @> - - //Drop explicit zeroes - // let localResultBuffer = (%plus) allValuesBuffer.[i] allValuesBuffer.[i + 1] - // if localResultBuffer = zero then rawPositionsBuffer.[i + 1] <- 0 else allValuesBuffer.[i + 1] <- localResultBuffer - - let rawPositions = Array.create length 1 - - do! - runCommand preparePositions - <| fun kernelPrepare -> - let ndRange = - Range1D(Utils.getDefaultGlobalSize (length - 1), Utils.defaultWorkGroupSize) - - kernelPrepare ndRange allIndices allValues rawPositions - - return rawPositions - } diff --git a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/FillSubVector/Merge.fs b/src/GraphBLAS-sharp.Backend/COOVector/Utilities/FillSubVector/Merge.fs deleted file mode 100644 index 1c561e16..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/FillSubVector/Merge.fs +++ /dev/null @@ -1,147 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector.Utilities.FillSubVector - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Backend.Common - -[] -module internal Merge = - let merge - (leftIndices: int []) - (leftValues: 'a []) - (rightIndices: int []) - (scalar: 'a []) - : ClTask = - opencl { - let workGroupSize = Utils.defaultWorkGroupSize - let firstSide = leftValues.Length - let secondSide = rightIndices.Length - let sumOfSides = firstSide + secondSide - - let merge = - <@ fun (ndRange: Range1D) (firstIndicesBuffer: int []) (firstValuesBuffer: 'a []) (secondIndicesBuffer: int []) (scalarBuffer: 'a []) (allIndicesBuffer: int []) (allValuesBuffer: 'a []) -> - - let i = ndRange.GlobalID0 - - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 - - if localID < 2 then - let mutable x = localID * (workGroupSize - 1) + i - 1 - - if x >= sumOfSides then - x <- sumOfSides - 1 - - let diagonalNumber = x - - let mutable leftEdge = diagonalNumber + 1 - secondSide - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstSide - 1 - - if rightEdge > diagonalNumber then - rightEdge <- diagonalNumber - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = firstIndicesBuffer.[middleIdx] - - let secondIndex = - secondIndicesBuffer.[diagonalNumber - middleIdx] - - if firstIndex <= secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge - - barrier () - - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength - - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx - - let secondLocalLength = x - - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize - - if localID < firstLocalLength then - localIndices.[localID] <- firstIndicesBuffer.[beginIdx + localID] - - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- secondIndicesBuffer.[i - beginIdx] - - barrier () - - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstLocalLength - 1 - - if rightEdge > localID then - rightEdge <- localID - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] - - let secondIndex = - localIndices.[firstLocalLength + localID - middleIdx] - - if firstIndex <= secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - let boundaryX = rightEdge - let boundaryY = localID - leftEdge - - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 - - let mutable fstIdx = 0 - - if isValidX then - fstIdx <- localIndices.[boundaryX] - - let mutable sndIdx = 0 - - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] - - if not isValidX || isValidY && fstIdx <= sndIdx then - allIndicesBuffer.[i] <- sndIdx - allValuesBuffer.[i] <- scalarBuffer.[0] - else - allIndicesBuffer.[i] <- fstIdx - allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] @> - - let allIndices = Array.zeroCreate sumOfSides - - let allValues = - Array.create sumOfSides Unchecked.defaultof<'a> - - do! - runCommand merge - <| fun kernelPrepare -> - let ndRange = - Range1D(Utils.getDefaultGlobalSize sumOfSides, workGroupSize) - - kernelPrepare ndRange leftIndices leftValues rightIndices scalar allIndices allValues - - return allIndices, allValues - } diff --git a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/FillSubVector/PreparePositions.fs b/src/GraphBLAS-sharp.Backend/COOVector/Utilities/FillSubVector/PreparePositions.fs deleted file mode 100644 index 14803f5d..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/FillSubVector/PreparePositions.fs +++ /dev/null @@ -1,32 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector.Utilities.FillSubVector - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend.Common - -[] -module internal PreparePositions = - let preparePositions (allIndices: int []) : ClTask = - opencl { - let length = allIndices.Length - - let preparePositions = - <@ fun (ndRange: Range1D) (allIndicesBuffer: int []) (rawPositionsBuffer: int []) -> - - let i = ndRange.GlobalID0 - - if i < length - 1 - && allIndicesBuffer.[i] = allIndicesBuffer.[i + 1] then - rawPositionsBuffer.[i] <- 0 @> - - let rawPositions = Array.create length 1 - - do! - runCommand preparePositions - <| fun kernelPrepare -> - let ndRange = - Range1D(Utils.getDefaultGlobalSize (length - 1), Utils.defaultWorkGroupSize) - - kernelPrepare ndRange allIndices rawPositions - - return rawPositions - } diff --git a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/SetPositions.fs b/src/GraphBLAS-sharp.Backend/COOVector/Utilities/SetPositions.fs deleted file mode 100644 index c63a3f6a..00000000 --- a/src/GraphBLAS-sharp.Backend/COOVector/Utilities/SetPositions.fs +++ /dev/null @@ -1,48 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.COOVector.Utilities - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend.Common - -[] -module internal SetPositions = - let setPositions (allIndices: int []) (allValues: 'a []) (positions: int []) : ClTask = - opencl { - let prefixSumArrayLength = positions.Length - - let setPositions = - <@ fun (ndRange: Range1D) (allIndicesBuffer: int []) (allValuesBuffer: 'a []) (prefixSumArrayBuffer: int []) (resultIndicesBuffer: int []) (resultValuesBuffer: 'a []) -> - - let i = ndRange.GlobalID0 - - if i = prefixSumArrayLength - 1 - || i < prefixSumArrayLength - && prefixSumArrayBuffer.[i] - <> prefixSumArrayBuffer.[i + 1] then - let index = prefixSumArrayBuffer.[i] - - resultIndicesBuffer.[index] <- allIndicesBuffer.[i] - resultValuesBuffer.[index] <- allValuesBuffer.[i] @> - - let resultLength = Array.zeroCreate 1 - - - failwith "FIX ME! And rewrite." - //do! PrefixSum.runExcludeInplace positions resultLength - //let! _ = ToHost resultLength - let resultLength = resultLength.[0] - - let resultIndices = Array.zeroCreate resultLength - - let resultValues = - Array.create resultLength Unchecked.defaultof<'a> - - do! - runCommand setPositions - <| fun kernelPrepare -> - let ndRange = - Range1D(Utils.getDefaultGlobalSize positions.Length, Utils.defaultWorkGroupSize) - - kernelPrepare ndRange allIndices allValues positions resultIndices resultValues - - return resultIndices, resultValues - } diff --git a/src/GraphBLAS-sharp.Backend/Common/ClArray.fs b/src/GraphBLAS-sharp.Backend/Common/ClArray.fs index 23dbb71a..d048c650 100644 --- a/src/GraphBLAS-sharp.Backend/Common/ClArray.fs +++ b/src/GraphBLAS-sharp.Backend/Common/ClArray.fs @@ -1,13 +1,16 @@ namespace GraphBLAS.FSharp.Backend.Common +open System.Collections.Generic open Brahma.FSharp open Microsoft.FSharp.Quotations open GraphBLAS.FSharp.Backend.Objects.ClContext open GraphBLAS.FSharp.Backend.Objects.ClCell open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Quotes module ClArray = - let init (clContext: ClContext) workGroupSize (initializer: Expr 'a>) = + let init (initializer: Expr 'a>) (clContext: ClContext) workGroupSize = let init = <@ fun (range: Range1D) (outputBuffer: ClArray<'a>) (length: int) -> @@ -62,7 +65,7 @@ module ClArray = outputArray - let zeroCreate (clContext: ClContext) workGroupSize = + let zeroCreate<'a> (clContext: ClContext) workGroupSize = let create = create clContext workGroupSize @@ -129,114 +132,179 @@ module ClArray = outputArray - /// - /// Exclude inplace prefix sum. - /// - /// - /// - /// let arr = [| 1; 1; 1; 1 |] - /// let sum = [| 0 |] - /// runExcludeInplace clContext workGroupSize processor arr sum <@ (+) @> 0 - /// |> ignore - /// ... - /// > val arr = [| 0; 1; 2; 3 |] - /// > val sum = [| 4 |] - /// - /// - ///Should be a power of 2 and greater than 1. - ///Associative binary operation. - ///Zero element for binary operation. - let prefixSumExcludeInplace = PrefixSum.runExcludeInplace + let map<'a, 'b> (op: Expr<'a -> 'b>) (clContext: ClContext) workGroupSize = - /// - /// Include inplace prefix sum. - /// - /// - /// - /// let arr = [| 1; 1; 1; 1 |] - /// let sum = [| 0 |] - /// runExcludeInplace clContext workGroupSize processor arr sum <@ (+) @> 0 - /// |> ignore - /// ... - /// > val arr = [| 1; 2; 3; 4 |] - /// > val sum = [| 4 |] - /// - /// - ///Should be a power of 2 and greater than 1. - ///Associative binary operation. - ///Zero element for binary operation. - let prefixSumIncludeInplace = PrefixSum.runIncludeInplace + let map = + <@ fun (ndRange: Range1D) lenght (inputArray: ClArray<'a>) (result: ClArray<'b>) -> - let prefixSumExclude plus (clContext: ClContext) workGroupSize = + let gid = ndRange.GlobalID0 - let runExcludeInplace = - prefixSumExcludeInplace plus clContext workGroupSize + if gid < lenght then + result.[gid] <- (%op) inputArray.[gid] @> - let copy = copy clContext workGroupSize + let kernel = clContext.Compile map - fun (processor: MailboxProcessor<_>) allocationMode (inputArray: ClArray<'a>) (zero: 'a) -> + fun (processor: MailboxProcessor<_>) allocationMode (inputArray: ClArray<'a>) -> - let outputArray = copy processor allocationMode inputArray + let result = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, inputArray.Length) - let totalSum = - runExcludeInplace processor outputArray zero + let ndRange = + Range1D.CreateValid(inputArray.Length, workGroupSize) - outputArray, totalSum + let kernel = kernel.GetKernel() - let prefixSumInclude plus (clContext: ClContext) workGroupSize = + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange inputArray.Length inputArray result)) - let runIncludeInplace = - prefixSumIncludeInplace plus clContext workGroupSize + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - let copy = copy clContext workGroupSize + result - fun (processor: MailboxProcessor<_>) allocationMode (inputArray: ClArray<'a>) (zero: 'a) -> + let mapWithValue<'a, 'b, 'c> (clContext: ClContext) workGroupSize (op: Expr<'a -> 'b -> 'c>) = - let outputArray = copy processor allocationMode inputArray + let map = + <@ fun (ndRange: Range1D) lenght (value: ClCell<'a>) (inputArray: ClArray<'b>) (result: ClArray<'c>) -> - let totalSum = - runIncludeInplace processor outputArray zero + let gid = ndRange.GlobalID0 - outputArray, totalSum + if gid < lenght then + result.[gid] <- (%op) value.Value inputArray.[gid] @> - let prefixSumBackwardsExcludeInplace plus = - PrefixSum.runBackwardsExcludeInplace plus + let kernel = clContext.Compile map - let prefixSumBackwardsIncludeInplace plus = - PrefixSum.runBackwardsIncludeInplace plus + fun (processor: MailboxProcessor<_>) allocationMode (value: 'a) (inputArray: ClArray<'b>) -> - let getUniqueBitmap (clContext: ClContext) workGroupSize = + let result = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, inputArray.Length) - let getUniqueBitmap = - <@ fun (ndRange: Range1D) (inputArray: ClArray<'a>) inputLength (isUniqueBitmap: ClArray) -> + let valueClCell = value |> clContext.CreateClCell - let i = ndRange.GlobalID0 + let ndRange = + Range1D.CreateValid(inputArray.Length, workGroupSize) - if i < inputLength - 1 - && inputArray.[i] = inputArray.[i + 1] then - isUniqueBitmap.[i] <- 0 - else - isUniqueBitmap.[i] <- 1 @> + let kernel = kernel.GetKernel() - let kernel = clContext.Compile(getUniqueBitmap) + processor.Post( + Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange inputArray.Length valueClCell inputArray result) + ) - fun (processor: MailboxProcessor<_>) allocationMode (inputArray: ClArray<'a>) -> + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - let inputLength = inputArray.Length + result - let ndRange = - Range1D.CreateValid(inputLength, workGroupSize) + let map2InPlace<'a, 'b, 'c> (map: Expr<'a -> 'b -> 'c>) (clContext: ClContext) workGroupSize = - let bitmap = - clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, inputLength) + let kernel = + <@ fun (ndRange: Range1D) length (leftArray: ClArray<'a>) (rightArray: ClArray<'b>) (resultArray: ClArray<'c>) -> + + let gid = ndRange.GlobalID0 + + if gid < length then + + resultArray.[gid] <- (%map) leftArray.[gid] rightArray.[gid] @> + + let kernel = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) (leftArray: ClArray<'a>) (rightArray: ClArray<'b>) (resultArray: ClArray<'c>) -> + + let ndRange = + Range1D.CreateValid(resultArray.Length, workGroupSize) let kernel = kernel.GetKernel() - processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange inputArray inputLength bitmap)) + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange resultArray.Length leftArray rightArray resultArray) + ) - processor.Post(Msg.CreateRunMsg<_, _> kernel) + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let map2<'a, 'b, 'c> map (clContext: ClContext) workGroupSize = + let map2 = + map2InPlace<'a, 'b, 'c> map clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (leftArray: ClArray<'a>) (rightArray: ClArray<'b>) -> + + let resultArray = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, leftArray.Length) + + map2 processor leftArray rightArray resultArray + + resultArray + + module Bitmap = + let private getUniqueBitmapGeneral predicate (clContext: ClContext) workGroupSize = + + let getUniqueBitmap = + <@ fun (ndRange: Range1D) (inputArray: ClArray<'a>) inputLength (isUniqueBitmap: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < inputLength then + let isUnique = (%predicate) gid inputLength inputArray // brahma error + + if isUnique then + isUniqueBitmap.[gid] <- 1 + else + isUniqueBitmap.[gid] <- 0 @> + + let kernel = clContext.Compile(getUniqueBitmap) + + fun (processor: MailboxProcessor<_>) allocationMode (inputArray: ClArray<'a>) -> + + let inputLength = inputArray.Length + + let ndRange = + Range1D.CreateValid(inputLength, workGroupSize) + + let bitmap = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, inputLength) + + let kernel = kernel.GetKernel() + + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange inputArray inputLength bitmap)) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + bitmap + + let firstOccurrence clContext = + getUniqueBitmapGeneral + <| Predicates.firstOccurrence () + <| clContext + + let lastOccurrence clContext = + getUniqueBitmapGeneral + <| Predicates.lastOccurrence () + <| clContext + + let private getUniqueBitmap2General<'a when 'a: equality> getUniqueBitmap (clContext: ClContext) workGroupSize = - bitmap + let map = + map2 <@ fun x y -> x ||| y @> clContext workGroupSize + + let firstGetBitmap = getUniqueBitmap clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (firstArray: ClArray<'a>) (secondArray: ClArray<'a>) -> + let firstBitmap = + firstGetBitmap processor DeviceOnly firstArray + + let secondBitmap = + firstGetBitmap processor DeviceOnly secondArray + + let result = + map processor allocationMode firstBitmap secondBitmap + + firstBitmap.Free processor + secondBitmap.Free processor + + result + + let firstOccurrence2 clContext = + getUniqueBitmap2General firstOccurrence clContext + + let lastOccurrence2 clContext = + getUniqueBitmap2General lastOccurrence clContext ///Remove duplicates form the given array. ///Computational context @@ -245,12 +313,13 @@ module ClArray = let removeDuplications (clContext: ClContext) workGroupSize = let scatter = - Scatter.runInplace clContext workGroupSize + Scatter.lastOccurrence clContext workGroupSize - let getUniqueBitmap = getUniqueBitmap clContext workGroupSize + let getUniqueBitmap = + Bitmap.lastOccurrence clContext workGroupSize let prefixSumExclude = - prefixSumExcludeInplace <@ (+) @> clContext workGroupSize + PrefixSum.runExcludeInPlace <@ (+) @> clContext workGroupSize fun (processor: MailboxProcessor<_>) (inputArray: ClArray<'a>) -> @@ -270,7 +339,7 @@ module ClArray = outputArray - let exists (clContext: ClContext) workGroupSize (predicate: Expr<'a -> bool>) = + let exists (predicate: Expr<'a -> bool>) (clContext: ClContext) workGroupSize = let exists = <@ fun (ndRange: Range1D) length (vector: ClArray<'a>) (result: ClCell) -> @@ -299,109 +368,454 @@ module ClArray = result - let map<'a, 'b> (clContext: ClContext) workGroupSize (op: Expr<'a -> 'b>) = + let assignOption (op: Expr<'a -> 'b option>) (clContext: ClContext) workGroupSize = - let map = - <@ fun (ndRange: Range1D) lenght (inputArray: ClArray<'a>) (result: ClArray<'b>) -> + let assign = + <@ fun (ndRange: Range1D) length (values: ClArray<'a>) (positions: ClArray) (result: ClArray<'b>) resultLength -> let gid = ndRange.GlobalID0 - if gid < lenght then - result.[gid] <- (%op) inputArray.[gid] @> + if gid < length then + let position = positions.[gid] + let value = values.[gid] - let kernel = clContext.Compile map + // seems like scatter (option scatter) ??? + if 0 <= position && position < resultLength then + match (%op) value with + | Some value -> result.[position] <- value + | None -> () @> - fun (processor: MailboxProcessor<_>) allocationMode (inputArray: ClArray<'a>) -> + let kernel = clContext.Compile assign - let result = - clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, inputArray.Length) + fun (processor: MailboxProcessor<_>) (values: ClArray<'a>) (positions: ClArray) (result: ClArray<'b>) -> + + if values.Length <> positions.Length then + failwith "lengths must be the same" let ndRange = - Range1D.CreateValid(inputArray.Length, workGroupSize) + Range1D.CreateValid(values.Length, workGroupSize) let kernel = kernel.GetKernel() - processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange inputArray.Length inputArray result)) + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange values.Length values positions result result.Length) + ) processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - result + let choose<'a, 'b> (predicate: Expr<'a -> 'b option>) (clContext: ClContext) workGroupSize = + let getBitmap = + map<'a, int> (Map.chooseBitmap predicate) clContext workGroupSize + + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize - let map2Inplace<'a, 'b, 'c> (clContext: ClContext) workGroupSize (map: Expr<'a -> 'b -> 'c>) = + let assignValues = + assignOption predicate clContext workGroupSize - let kernel = - <@ fun (ndRange: Range1D) length (leftArray: ClArray<'a>) (rightArray: ClArray<'b>) (resultArray: ClArray<'c>) -> + fun (processor: MailboxProcessor<_>) allocationMode (sourceValues: ClArray<'a>) -> + + let positions = + getBitmap processor DeviceOnly sourceValues + + let resultLength = + (prefixSum processor positions) + .ToHostAndFree(processor) + + if resultLength = 0 then + positions.Free processor + + None + else + let result = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + assignValues processor sourceValues positions result + + positions.Free processor + + Some result + + let assignOption2 (op: Expr<'a -> 'b -> 'c option>) (clContext: ClContext) workGroupSize = + + let assign = + <@ fun (ndRange: Range1D) length (firstValues: ClArray<'a>) (secondValues: ClArray<'b>) (positions: ClArray) (result: ClArray<'c>) resultLength -> let gid = ndRange.GlobalID0 if gid < length then + let position = positions.[gid] - resultArray.[gid] <- (%map) leftArray.[gid] rightArray.[gid] @> + let leftValue = firstValues.[gid] + let rightValue = secondValues.[gid] - let kernel = clContext.Compile kernel + // seems like scatter2 (option scatter2) ??? + if 0 <= position && position < resultLength then + match (%op) leftValue rightValue with + | Some value -> result.[position] <- value + | None -> () @> - fun (processor: MailboxProcessor<_>) (leftArray: ClArray<'a>) (rightArray: ClArray<'b>) (resultArray: ClArray<'c>) -> + let kernel = clContext.Compile assign + + fun (processor: MailboxProcessor<_>) (firstValues: ClArray<'a>) (secondValues: ClArray<'b>) (positions: ClArray) (result: ClArray<'c>) -> + + if firstValues.Length <> secondValues.Length + || secondValues.Length <> positions.Length then + failwith "lengths must be the same" let ndRange = - Range1D.CreateValid(resultArray.Length, workGroupSize) + Range1D.CreateValid(firstValues.Length, workGroupSize) let kernel = kernel.GetKernel() processor.Post( Msg.MsgSetArguments - (fun () -> kernel.KernelFunc ndRange resultArray.Length leftArray rightArray resultArray) + (fun () -> + kernel.KernelFunc + ndRange + firstValues.Length + firstValues + secondValues + positions + result + result.Length) ) processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - let map2<'a, 'b, 'c> (clContext: ClContext) workGroupSize map = - let map2 = - map2Inplace<'a, 'b, 'c> clContext workGroupSize map + let choose2 (predicate: Expr<'a -> 'b -> 'c option>) (clContext: ClContext) workGroupSize = + let getBitmap = + map2<'a, 'b, int> (Map.choose2Bitmap predicate) clContext workGroupSize - fun (processor: MailboxProcessor<_>) allocationMode (leftArray: ClArray<'a>) (rightArray: ClArray<'b>) -> + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize - let resultArray = - clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, leftArray.Length) + let assignValues = + assignOption2 predicate clContext workGroupSize - map2 processor leftArray rightArray resultArray + fun (processor: MailboxProcessor<_>) allocationMode (firstValues: ClArray<'a>) (secondValues: ClArray<'b>) -> - resultArray + let positions = + getBitmap processor DeviceOnly firstValues secondValues - let choose<'a, 'b> (clContext: ClContext) workGroupSize (predicate: Expr<'a -> 'b option>) = - let getBitmap = - map<'a, int> clContext workGroupSize - <| Map.chooseBitmap predicate + let resultLength = + (prefixSum processor positions) + .ToHostAndFree(processor) - let getOptionValues = - map<'a, 'b option> clContext workGroupSize predicate + let result = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) - let getValues = - map<'b option, 'b> clContext workGroupSize - <| Map.optionToValueOrZero Unchecked.defaultof<'b> + assignValues processor firstValues secondValues positions result - let prefixSum = - prefixSumExcludeInplace <@ (+) @> clContext workGroupSize + result - let scatter = - Scatter.runInplace clContext workGroupSize + let sub (clContext: ClContext) workGroupSize = - fun (processor: MailboxProcessor<_>) allocationMode (array: ClArray<'a>) -> + let kernel = + <@ fun (ndRange: Range1D) startIndex count (sourceArray: ClArray<'a>) (targetChunk: ClArray<'a>) -> - let positions = getBitmap processor DeviceOnly array + let gid = ndRange.GlobalID0 - let resultLength = - (prefixSum processor positions 0) - .ToHostAndFree(processor) + if gid < count then + let sourcePosition = gid + startIndex + + targetChunk.[gid] <- sourceArray.[sourcePosition] @> + + let kernel = clContext.Compile kernel - let optionValues = - getOptionValues processor DeviceOnly array + fun (processor: MailboxProcessor<_>) allocationMode (sourceArray: ClArray<'a>) startIndex count -> + if count <= 0 then + failwith "Count must be greater than zero" - let values = - getValues processor DeviceOnly optionValues + if startIndex < 0 then + failwith "startIndex must be greater then zero" + + if startIndex + count > sourceArray.Length then + failwith "startIndex and count sum is larger than the size of the array" + + let result = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, count) + + let ndRange = + Range1D.CreateValid(count, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange startIndex count sourceArray result)) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + result + + /// + /// Lazy divides the input array into chunks of size at most chunkSize. + /// + /// Cl context. + /// Work group size. + /// + /// Since calculations are performed lazily, the array should not change. + /// + let lazyChunkBySize (clContext: ClContext) workGroupSize = + + let sub = sub clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode chunkSize (sourceArray: ClArray<'a>) -> + if chunkSize <= 0 then + failwith "The size of the chunk cannot be less than 1" + + let chunkCount = (sourceArray.Length - 1) / chunkSize + 1 + + let sub = sub processor allocationMode sourceArray + + seq { + for i in 0 .. chunkCount - 1 do + let startIndex = i * chunkSize + + let count = + min chunkSize (sourceArray.Length - startIndex) + + yield lazy (sub startIndex count) + } + + /// + /// Divides the input array into chunks of size at most chunkSize. + /// + /// Cl context. + /// Work group size. + let chunkBySize (clContext: ClContext) workGroupSize = + + let chunkBySizeLazy = lazyChunkBySize clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode chunkSize (sourceArray: ClArray<'a>) -> + chunkBySizeLazy processor allocationMode chunkSize sourceArray + |> Seq.map (fun lazyValue -> lazyValue.Value) + |> Seq.toArray + + let blit<'a> (clContext: ClContext) workGroupSize = + + let assign = + <@ fun (ndRange: Range1D) sourceIndex (sourceArray: ClArray<'a>) (targetArray: ClArray<'a>) targetPosition count -> + + let gid = ndRange.GlobalID0 + + if gid < count then + let readPosition = gid + sourceIndex + let writePosition = gid + targetPosition + + targetArray.[writePosition] <- sourceArray.[readPosition] @> + + let kernel = clContext.Compile assign + + fun (processor: MailboxProcessor<_>) (sourceArray: ClArray<'a>) sourceIndex (targetArray: ClArray<'a>) targetIndex count -> + if count = 0 then + // nothing to do + () + else + if count < 0 then + failwith "Count must be greater than zero" + + if sourceIndex < 0 + && sourceIndex + count >= sourceArray.Length then + failwith "The source index does not match" + + if targetIndex < 0 + && targetIndex + count >= targetArray.Length then + failwith "The target index does not match" + + let ndRange = + Range1D.CreateValid(targetArray.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange sourceIndex sourceArray targetArray targetIndex count) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let concat (clContext: ClContext) workGroupSize = + + let blit = blit clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (sourceArrays: ClArray<'a> seq) -> + + let resultLength = + sourceArrays + |> Seq.sumBy (fun array -> array.Length) let result = clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) - scatter processor positions values result + // write each array to result + Seq.fold + (fun previousLength (array: ClArray<_>) -> + blit processor array 0 result previousLength array.Length + previousLength + array.Length) + 0 + sourceArrays + |> ignore result + + let fill (clContext: ClContext) workGroupSize = + + let fill = + <@ fun (ndRange: Range1D) firstPosition count (value: ClCell<'a>) (targetArray: ClArray<'a>) -> + + let gid = ndRange.GlobalID0 + let writePosition = gid + firstPosition + + if gid < count then + targetArray.[writePosition] <- value.Value @> + + let kernel = clContext.Compile fill + + fun (processor: MailboxProcessor<_>) value firstPosition count (targetArray: ClArray<'a>) -> + if count = 0 then + () + else + if count < 0 then + failwith "Count must be greater than zero" + + if firstPosition + count > targetArray.Length then + failwith "The array should fit completely" + + let ndRange = + Range1D.CreateValid(count, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange firstPosition count value targetArray) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let pairwise (clContext: ClContext) workGroupSize = + + let idGather = + Gather.runInit Map.id clContext workGroupSize + + let incGather = + Gather.runInit Map.inc clContext workGroupSize + + let map = + map2 <@ fun first second -> (first, second) @> clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (values: ClArray<'a>) -> + if values.Length > 1 then + let resultLength = values.Length - 1 + + let firstItems = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + idGather processor values firstItems + + let secondItems = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + incGather processor values secondItems + + let result = + map processor allocationMode firstItems secondItems + + firstItems.Free processor + secondItems.Free processor + + Some result + else + None + + let private bound<'a, 'b when 'a: equality and 'a: comparison> + (lowerBound: Expr<(int -> 'a -> ClArray<'a> -> 'b)>) + (clContext: ClContext) + workGroupSize + = + + let kernel = + <@ fun (ndRange: Range1D) length (values: ClArray<'a>) (value: ClCell<'a>) (result: ClCell<'b>) -> + + let value = value.Value + let gid = ndRange.GlobalID0 + + if gid = 0 then + + result.Value <- (%lowerBound) length value values @> + + let program = clContext.Compile(kernel) + + fun (processor: MailboxProcessor<_>) (values: ClArray<'a>) (value: ClCell<'a>) -> + let result = + clContext.CreateClCell Unchecked.defaultof<'b> + + let kernel = program.GetKernel() + + let ndRange = Range1D.CreateValid(1, workGroupSize) + + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange values.Length values value result)) + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + result + + let upperBoundAndValue<'a when 'a: comparison> clContext = + bound<'a, int * 'a> Search.Bin.lowerBoundAndValue clContext + + let upperBound<'a when 'a: comparison> clContext = + bound<'a, int> Search.Bin.lowerBound clContext + + let item<'a> (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) index (array: ClArray<'a>) (result: ClCell<'a>) -> + + let gid = ndRange.GlobalID0 + + if gid = 0 then + result.Value <- array.[index] @> + + let program = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) (index: int) (array: ClArray<'a>) -> + + if index < 0 || index >= array.Length then + failwith "Index out of range" + + let result = + clContext.CreateClCell Unchecked.defaultof<'a> + + let kernel = program.GetKernel() + + let ndRange = Range1D.CreateValid(1, workGroupSize) + + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange index array result)) + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + result + + let set<'a> (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) index (array: ClArray<'a>) (value: ClCell<'a>) -> + + let gid = ndRange.GlobalID0 + + if gid = 0 then + array.[index] <- value.Value @> + + let program = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) (array: ClArray<'a>) (index: int) (value: 'a) -> + + if index < 0 || index >= array.Length then + failwith "Index out of range" + + let value = clContext.CreateClCell value + + let kernel = program.GetKernel() + + let ndRange = Range1D.CreateValid(1, workGroupSize) + + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange index array value)) + processor.Post(Msg.CreateRunMsg<_, _> kernel) diff --git a/src/GraphBLAS-sharp.Backend/Common/Gather.fs b/src/GraphBLAS-sharp.Backend/Common/Gather.fs new file mode 100644 index 00000000..791c88de --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Common/Gather.fs @@ -0,0 +1,73 @@ +namespace GraphBLAS.FSharp.Backend.Common + +open Brahma.FSharp + +module internal Gather = + let runInit positionMap (clContext: ClContext) workGroupSize = + + let gather = + <@ fun (ndRange: Range1D) valuesLength (values: ClArray<'a>) (outputArray: ClArray<'a>) -> + + let gid = ndRange.GlobalID0 + + if gid < valuesLength then + let position = (%positionMap) gid + + if position >= 0 && position < valuesLength then + outputArray.[gid] <- values.[position] @> + + let program = clContext.Compile gather + + fun (processor: MailboxProcessor<_>) (values: ClArray<'a>) (outputArray: ClArray<'a>) -> + + let kernel = program.GetKernel() + + let ndRange = + Range1D.CreateValid(outputArray.Length, workGroupSize) + + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange values.Length values outputArray)) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + /// + /// Creates a new array obtained from positions replaced with values from the given array at these positions (indices). + /// + /// + /// + /// let positions = [| 2; 0; 2; 1 |] + /// let array = [| 1.4; 2.5; 3.6 |] + /// ... + /// > val result = [| 3.6; 1.4; 3.6; 2.5 |] + /// + /// + let run (clContext: ClContext) workGroupSize = + + let gather = + <@ fun (ndRange: Range1D) positionsLength valuesLength (positions: ClArray) (values: ClArray<'a>) (outputArray: ClArray<'a>) -> + + let gid = ndRange.GlobalID0 + + if gid < positionsLength then + let position = positions.[gid] + + if position >= 0 && position < valuesLength then + outputArray.[gid] <- values.[position] @> + + let program = clContext.Compile gather + + fun (processor: MailboxProcessor<_>) (positions: ClArray) (values: ClArray<'a>) (outputArray: ClArray<'a>) -> + + if positions.Length <> outputArray.Length then + failwith "Lengths must be the same" + + let kernel = program.GetKernel() + + let ndRange = + Range1D.CreateValid(positions.Length, workGroupSize) + + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange positions.Length values.Length positions values outputArray) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) diff --git a/src/GraphBLAS-sharp.Backend/Common/Merge.fs b/src/GraphBLAS-sharp.Backend/Common/Merge.fs new file mode 100644 index 00000000..07199ef2 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Common/Merge.fs @@ -0,0 +1,144 @@ +namespace GraphBLAS.FSharp.Backend.Common + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects.ClContext + +module Merge = + let run<'a, 'b when 'a: struct and 'b: struct and 'a: comparison> (clContext: ClContext) workGroupSize = + + let defaultValue = Unchecked.defaultof<'a> + + let merge = + <@ fun (ndRange: Range1D) (firstSide: int) (secondSide: int) (sumOfSides: int) (firstValues: ClArray<'a>) (secondValues: ClArray<'a>) (resultValues: ClArray<'a>) -> + + let gid = ndRange.GlobalID0 + let lid = ndRange.LocalID0 + + let mutable beginIdxLocal = local () + let mutable endIdxLocal = local () + + if lid < 2 then + // (n - 1) * wgSize - 1 for lid = 0 + // n * wgSize - 1 for lid = 1 + // where n in 1 .. wgGroupCount + let x = lid * (workGroupSize - 1) + gid - 1 + + let diagonalNumber = min (sumOfSides - 1) x + + let mutable leftEdge = max 0 (diagonalNumber + 1 - secondSide) + + let mutable rightEdge = min (firstSide - 1) diagonalNumber + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + + let firstIndex = firstValues.[middleIdx] + + let secondIndex = + secondValues.[diagonalNumber - middleIdx] + + if firstIndex <= secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 + + // Here localID equals either 0 or 1 + if lid = 0 then + beginIdxLocal <- leftEdge + else + endIdxLocal <- leftEdge + + barrierLocal () + + let beginIdx = beginIdxLocal + let endIdx = endIdxLocal + let firstLocalLength = endIdx - beginIdx + + let mutable x = workGroupSize - firstLocalLength + + if endIdx = firstSide then + x <- secondSide - gid + lid + beginIdx + + let secondLocalLength = x + + //First indices are from 0 to firstLocalLength - 1 inclusive + //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive + let localIndices = localArray<'a> workGroupSize + + if lid < firstLocalLength then + localIndices.[lid] <- firstValues.[beginIdx + lid] + + if lid < secondLocalLength then + localIndices.[firstLocalLength + lid] <- secondValues.[gid - beginIdx] + + barrierLocal () + + if gid < sumOfSides then + let mutable leftEdge = lid + 1 - secondLocalLength + if leftEdge < 0 then leftEdge <- 0 + + let mutable rightEdge = firstLocalLength - 1 + + rightEdge <- min rightEdge lid + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + let firstIndex = localIndices.[middleIdx] + + let secondIndex = + localIndices.[firstLocalLength + lid - middleIdx] + + if firstIndex <= secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 + + let boundaryX = rightEdge + let boundaryY = lid - leftEdge + + // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) + let isValidX = boundaryX >= 0 + let isValidY = boundaryY >= 0 + + let mutable fstIdx = defaultValue + + if isValidX then + fstIdx <- localIndices.[boundaryX] + + let mutable sndIdx = defaultValue + + if isValidY then + sndIdx <- localIndices.[firstLocalLength + boundaryY] + + if not isValidX || isValidY && fstIdx <= sndIdx then + resultValues.[gid] <- sndIdx + else + resultValues.[gid] <- fstIdx @> + + let kernel = clContext.Compile merge + + fun (processor: MailboxProcessor<_>) (firstValues: ClArray<'a>) (secondValues: ClArray<'a>) -> + + let firstSide = firstValues.Length + + let secondSide = secondValues.Length + + let sumOfSides = firstSide + secondSide + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'a>(DeviceOnly, sumOfSides) + + let ndRange = + Range1D.CreateValid(sumOfSides, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc ndRange firstSide secondSide sumOfSides firstValues secondValues resultValues) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + resultValues diff --git a/src/GraphBLAS-sharp.Backend/Common/PrefixSum.fs b/src/GraphBLAS-sharp.Backend/Common/PrefixSum.fs index 8d81eb3f..09cdfb5d 100644 --- a/src/GraphBLAS-sharp.Backend/Common/PrefixSum.fs +++ b/src/GraphBLAS-sharp.Backend/Common/PrefixSum.fs @@ -3,6 +3,8 @@ namespace GraphBLAS.FSharp.Backend.Common open Brahma.FSharp open FSharp.Quotations open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects.ClCell module PrefixSum = let private update (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = @@ -38,7 +40,7 @@ module PrefixSum = ) processor.Post(Msg.CreateRunMsg<_, _> kernel) - processor.Post(Msg.CreateFreeMsg(mirror)) + mirror.Free processor let private scanGeneral beforeLocalSumClear @@ -48,10 +50,8 @@ module PrefixSum = workGroupSize = - let subSum = SubSum.treeSum opAdd - let scan = - <@ fun (ndRange: Range1D) inputArrayLength verticesLength (resultBuffer: ClArray<'a>) (verticesBuffer: ClArray<'a>) (totalSumBuffer: ClCell<'a>) (zero: ClCell<'a>) (mirror: ClCell) -> + <@ fun (ndRange: Range1D) inputArrayLength verticesLength (inputArray: ClArray<'a>) (verticesBuffer: ClArray<'a>) (totalSumBuffer: ClCell<'a>) (zero: ClCell<'a>) (mirror: ClCell) -> let mirror = mirror.Value @@ -62,46 +62,34 @@ module PrefixSum = if mirror then i <- inputArrayLength - 1 - i - let localID = ndRange.LocalID0 + let lid = ndRange.LocalID0 let zero = zero.Value if gid < inputArrayLength then - resultLocalBuffer.[localID] <- resultBuffer.[i] + resultLocalBuffer.[lid] <- inputArray.[i] else - resultLocalBuffer.[localID] <- zero + resultLocalBuffer.[lid] <- zero barrierLocal () - (%subSum) workGroupSize localID resultLocalBuffer - - if localID = workGroupSize - 1 then - if verticesLength <= 1 && localID = gid then - totalSumBuffer.Value <- resultLocalBuffer.[localID] - - verticesBuffer.[gid / workGroupSize] <- resultLocalBuffer.[localID] - (%beforeLocalSumClear) resultBuffer resultLocalBuffer.[localID] inputArrayLength gid i - resultLocalBuffer.[localID] <- zero - - let mutable step = workGroupSize + // Local tree reduce + (%SubSum.upSweep opAdd) workGroupSize lid resultLocalBuffer - while step > 1 do - barrierLocal () + if lid = workGroupSize - 1 then + // if last iteration + if verticesLength <= 1 && lid = gid then + totalSumBuffer.Value <- resultLocalBuffer.[lid] - if localID < workGroupSize / step then - let i = step * (localID + 1) - 1 - let j = i - (step >>> 1) + verticesBuffer.[gid / workGroupSize] <- resultLocalBuffer.[lid] + (%beforeLocalSumClear) inputArray resultLocalBuffer.[lid] inputArrayLength gid i + resultLocalBuffer.[lid] <- zero - let tmp = resultLocalBuffer.[i] - let buff = (%opAdd) tmp resultLocalBuffer.[j] - resultLocalBuffer.[i] <- buff - resultLocalBuffer.[j] <- tmp - - step <- step >>> 1 + (%SubSum.downSweep opAdd) workGroupSize lid resultLocalBuffer barrierLocal () - (%writeData) resultBuffer resultLocalBuffer inputArrayLength workGroupSize gid i localID @> + (%writeData) inputArray resultLocalBuffer inputArrayLength workGroupSize gid i lid @> let program = clContext.Compile(scan) @@ -132,13 +120,14 @@ module PrefixSum = ) processor.Post(Msg.CreateRunMsg<_, _> kernel) - processor.Post(Msg.CreateFreeMsg(zero)) - processor.Post(Msg.CreateFreeMsg(mirror)) + + zero.Free processor + mirror.Free processor let private scanExclusive<'a when 'a: struct> = scanGeneral <@ fun (_: ClArray<'a>) (_: 'a) (_: int) (_: int) (_: int) -> () @> - <@ fun (resultBuffer: ClArray<'a>) (resultLocalBuffer: 'a []) (inputArrayLength: int) (smth: int) (gid: int) (i: int) (localID: int) -> + <@ fun (resultBuffer: ClArray<'a>) (resultLocalBuffer: 'a []) (inputArrayLength: int) (_: int) (gid: int) (i: int) (localID: int) -> if gid < inputArrayLength then resultBuffer.[i] <- resultLocalBuffer.[localID] @> @@ -155,7 +144,7 @@ module PrefixSum = && localID < workGroupSize - 1 then resultBuffer.[i] <- resultLocalBuffer.[localID + 1] @> - let private runInplace (mirror: bool) scan (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = + let private runInPlace (opAdd: Expr<'a -> 'a -> 'a>) (mirror: bool) scan (clContext: ClContext) workGroupSize = let scan = scan opAdd clContext workGroupSize @@ -206,15 +195,137 @@ module PrefixSum = verticesArrays <- swap verticesArrays verticesLength <- (verticesLength - 1) / workGroupSize + 1 - processor.Post(Msg.CreateFreeMsg(firstVertices)) - processor.Post(Msg.CreateFreeMsg(secondVertices)) + firstVertices.Free processor + secondVertices.Free processor totalSum - let runExcludeInplace plus = runInplace false scanExclusive plus + let runExcludeInPlace plus = runInPlace plus false scanExclusive + + let runIncludeInPlace plus = runInPlace plus false scanInclusive + + let runBackwardsExcludeInPlace plus = runInPlace plus true scanExclusive + + let runBackwardsIncludeInPlace plus = runInPlace plus true scanInclusive + + /// + /// Exclude inplace prefix sum. + /// + /// + /// + /// let arr = [| 1; 1; 1; 1 |] + /// let sum = [| 0 |] + /// runExcludeInplace clContext workGroupSize processor arr sum (+) 0 + /// |> ignore + /// ... + /// > val arr = [| 0; 1; 2; 3 |] + /// > val sum = [| 4 |] + /// + /// + ///ClContext. + ///Should be a power of 2 and greater than 1. + ///Associative binary operation. + ///Zero element for binary operation. + let standardExcludeInPlace (clContext: ClContext) workGroupSize = + + let scan = + runExcludeInPlace <@ (+) @> clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (inputArray: ClArray) -> + + scan processor inputArray 0 + + /// + /// Include inplace prefix sum. + /// + /// + /// + /// let arr = [| 1; 1; 1; 1 |] + /// let sum = [| 0 |] + /// runExcludeInplace clContext workGroupSize processor arr sum (+) 0 + /// |> ignore + /// ... + /// > val arr = [| 1; 2; 3; 4 |] + /// > val sum = [| 4 |] + /// + /// + ///ClContext. + ///Should be a power of 2 and greater than 1. + ///Associative binary operation. + ///Zero element for binary operation. + let standardIncludeInPlace (clContext: ClContext) workGroupSize = + + let scan = + runIncludeInPlace <@ (+) @> clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (inputArray: ClArray) -> + + scan processor inputArray 0 + + module ByKey = + let private sequentialSegments opWrite opAdd zero (clContext: ClContext) workGroupSize = - let runIncludeInplace plus = runInplace false scanInclusive plus + let kernel = + <@ fun (ndRange: Range1D) lenght uniqueKeysCount (values: ClArray<'a>) (keys: ClArray) (offsets: ClArray) -> + let gid = ndRange.GlobalID0 - let runBackwardsExcludeInplace plus = runInplace true scanExclusive plus + if gid < uniqueKeysCount then + let sourcePosition = offsets.[gid] + let sourceKey = keys.[sourcePosition] + + let mutable currentSum = zero + let mutable previousSum = zero + + let mutable currentPosition = sourcePosition + + while currentPosition < lenght + && keys.[currentPosition] = sourceKey do + + previousSum <- currentSum + currentSum <- (%opAdd) currentSum values.[currentPosition] + + values.[currentPosition] <- (%opWrite) previousSum currentSum + + currentPosition <- currentPosition + 1 @> + + let kernel = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) uniqueKeysCount (values: ClArray<'a>) (keys: ClArray) (offsets: ClArray) -> + + let kernel = kernel.GetKernel() + + let ndRange = + Range1D.CreateValid(values.Length, workGroupSize) + + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange values.Length uniqueKeysCount values keys offsets) + ) - let runBackwardsIncludeInplace plus = runInplace true scanInclusive plus + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + /// + /// Exclude scan by key. + /// + /// + /// + /// let arr = [| 1; 1; 1; 1; 1; 1|] + /// let keys = [| 1; 2; 2; 2; 3; 3 |] + /// ... + /// > val result = [| 0; 0; 1; 2; 0; 1 |] + /// + /// + let sequentialExclude op = sequentialSegments (Map.fst ()) op + + /// + /// Include scan by key. + /// + /// + /// + /// let arr = [| 1; 1; 1; 1; 1; 1|] + /// let keys = [| 1; 2; 2; 2; 3; 3 |] + /// ... + /// > val result = [| 1; 1; 2; 3; 1; 2 |] + /// + /// + let sequentialInclude op = sequentialSegments (Map.snd ()) op diff --git a/src/GraphBLAS-sharp.Backend/Common/Scatter.fs b/src/GraphBLAS-sharp.Backend/Common/Scatter.fs index a3d54dec..4f51cb93 100644 --- a/src/GraphBLAS-sharp.Backend/Common/Scatter.fs +++ b/src/GraphBLAS-sharp.Backend/Common/Scatter.fs @@ -1,8 +1,72 @@ namespace GraphBLAS.FSharp.Backend.Common open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Quotes module internal Scatter = + let private general<'a> predicate (clContext: ClContext) workGroupSize = + + let run = + <@ fun (ndRange: Range1D) (positions: ClArray) (positionsLength: int) (values: ClArray<'a>) (result: ClArray<'a>) (resultLength: int) -> + + let gid = ndRange.GlobalID0 + + if gid < positionsLength then + // positions lengths == values length + let predicateResult = + (%predicate) gid positionsLength positions + + let position = positions.[gid] + + if predicateResult + && 0 <= position + && position < resultLength then + + result.[positions.[gid]] <- values.[gid] @> + + let program = clContext.Compile(run) + + fun (processor: MailboxProcessor<_>) (positions: ClArray) (values: ClArray<'a>) (result: ClArray<'a>) -> + + if positions.Length <> values.Length then + failwith "Lengths must be the same" + + let positionsLength = positions.Length + + let ndRange = + Range1D.CreateValid(positionsLength, workGroupSize) + + let kernel = program.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange positions positionsLength values result result.Length) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + /// + /// Creates a new array from the given one where it is indicated by the array of positions at which position in the new array + /// should be a value from the given one. + /// + /// + /// Every element of the positions array must not be less than the previous one. + /// If there are several elements with the same indices, the FIRST one of them will be at the common index. + /// If index is out of bounds, the value will be ignored. + /// + /// + /// + /// let positions = [| 0; 0; 1; 1; 1; 2; 3; 3; 4 |] + /// let values = [| 1.9; 2.8; 3.7; 4.6; 5.5; 6.4; 7.3; 8.2; 9.1 |] + /// run clContext 32 processor positions values result + /// ... + /// > val result = [| 1,9; 3.7; 6.4; 7.3; 9.1 |] + /// + /// + let firstOccurrence clContext = + general + <| Predicates.firstOccurrence () + <| clContext /// /// Creates a new array from the given one where it is indicated by the array of positions at which position in the new array @@ -10,38 +74,46 @@ module internal Scatter = /// /// /// Every element of the positions array must not be less than the previous one. - /// If there are several elements with the same indices, the last one of them will be at the common index. + /// If there are several elements with the same indices, the LAST one of them will be at the common index. /// If index is out of bounds, the value will be ignored. /// /// /// /// let positions = [| 0; 0; 1; 1; 1; 2; 3; 3; 4 |] /// let values = [| 1.9; 2.8; 3.7; 4.6; 5.5; 6.4; 7.3; 8.2; 9.1 |] - /// let result = run clContext 32 processor positions values result + /// run clContext 32 processor positions values result /// ... /// > val result = [| 2.8; 5.5; 6.4; 8.2; 9.1 |] /// /// - let runInplace<'a> (clContext: ClContext) workGroupSize = + let lastOccurrence clContext = + general + <| Predicates.lastOccurrence () + <| clContext + + let private generalInit<'a> predicate valueMap (clContext: ClContext) workGroupSize = let run = - <@ fun (ndRange: Range1D) (positions: ClArray) (positionsLength: int) (values: ClArray<'a>) (result: ClArray<'a>) (resultLength: int) -> + <@ fun (ndRange: Range1D) (positions: ClArray) (positionsLength: int) (result: ClArray<'a>) (resultLength: int) -> + + let gid = ndRange.GlobalID0 + + if gid < positionsLength then + // positions lengths == values length + let predicateResult = + (%predicate) gid positionsLength positions - let i = ndRange.GlobalID0 + let position = positions.[gid] - if i < positionsLength then - let index = positions.[i] + if predicateResult + && 0 <= position + && position < resultLength then - if 0 <= index && index < resultLength then - if i < positionsLength - 1 then - if index <> positions.[i + 1] then - result.[index] <- values.[i] - else - result.[index] <- values.[i] @> + result.[positions.[gid]] <- (%valueMap) gid @> let program = clContext.Compile(run) - fun (processor: MailboxProcessor<_>) (positions: ClArray) (values: ClArray<'a>) (result: ClArray<'a>) -> + fun (processor: MailboxProcessor<_>) (positions: ClArray) (result: ClArray<'a>) -> let positionsLength = positions.Length @@ -51,8 +123,55 @@ module internal Scatter = let kernel = program.GetKernel() processor.Post( - Msg.MsgSetArguments - (fun () -> kernel.KernelFunc ndRange positions positionsLength values result result.Length) + Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange positions positionsLength result result.Length) ) processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + /// + /// Creates a new array from the given one where it is indicated by the array of positions at which position in the new array + /// should be a values obtained by applying the mapping to the global id. + /// + /// + /// Every element of the positions array must not be less than the previous one. + /// If there are several elements with the same indices, the FIRST one of them will be at the common index. + /// If index is out of bounds, the value will be ignored. + /// + /// + /// + /// let positions = [| 0; 0; 1; 1; 1; 2; 3; 3; 4 |] + /// let valueMap = id + /// run clContext 32 processor positions values result + /// ... + /// > val result = [| 0; 2; 5; 6; 8 |] + /// + /// + /// Maps global id to a value + let initFirsOccurrence<'a> valueMap = + generalInit<'a> + <| Predicates.firstOccurrence () + <| valueMap + + /// + /// Creates a new array from the given one where it is indicated by the array of positions at which position in the new array + /// should be a values obtained by applying the mapping to the global id. + /// + /// + /// Every element of the positions array must not be less than the previous one. + /// If there are several elements with the same indices, the LAST one of them will be at the common index. + /// If index is out of bounds, the value will be ignored. + /// + /// + /// + /// let positions = [| 0; 0; 1; 1; 1; 2; 3; 3; 4 |] + /// let valueMap = id + /// run clContext 32 processor positions values result + /// ... + /// > val result = [| 1; 4; 5; 7; 8 |] + /// + /// + /// Maps global id to a value + let initLastOccurrence<'a> valueMap = + generalInit<'a> + <| Predicates.lastOccurrence () + <| valueMap diff --git a/src/GraphBLAS-sharp.Backend/Common/BitonicSort.fs b/src/GraphBLAS-sharp.Backend/Common/Sort/Bitonic.fs similarity index 99% rename from src/GraphBLAS-sharp.Backend/Common/BitonicSort.fs rename to src/GraphBLAS-sharp.Backend/Common/Sort/Bitonic.fs index b2c0116c..db833874 100644 --- a/src/GraphBLAS-sharp.Backend/Common/BitonicSort.fs +++ b/src/GraphBLAS-sharp.Backend/Common/Sort/Bitonic.fs @@ -1,8 +1,9 @@ -namespace GraphBLAS.FSharp.Backend.Common +namespace GraphBLAS.FSharp.Backend.Common.Sort open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common -module internal BitonicSort = +module internal Bitonic = let private localBegin (clContext: ClContext) workGroupSize = let processedSize = workGroupSize * 2 diff --git a/src/GraphBLAS-sharp.Backend/Common/Sort/Radix.fs b/src/GraphBLAS-sharp.Backend/Common/Sort/Radix.fs new file mode 100644 index 00000000..29f9e26a --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Common/Sort/Radix.fs @@ -0,0 +1,331 @@ +namespace GraphBLAS.FSharp.Backend.Common.Sort + + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ClCell +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +module Radix = + // the number of bits considered per iteration + let defaultBitCount = 4 + + let keyBitCount = 32 + + let localPrefixSum = + <@ fun (lid: int) (workGroupSize: int) (array: int []) -> + let mutable offset = 1 + + while offset < workGroupSize do + barrierLocal () + let mutable value = array.[lid] + + if lid >= offset then + value <- value + array.[lid - offset] + + offset <- offset * 2 + + barrierLocal () + array.[lid] <- value @> + + let count (clContext: ClContext) workGroupSize mask = + + let bitCount = mask + 1 + + let kernel = + <@ fun (ndRange: Range1D) length (indices: ClArray) (workGroupCount: ClCell) (shift: ClCell) (globalOffsets: ClArray) (localOffsets: ClArray) -> + + let gid = ndRange.GlobalID0 + let lid = ndRange.LocalID0 + + let position = (indices.[gid] >>> shift.Value) &&& mask + + let localMask = localArray workGroupSize + + if gid < length then + localMask.[lid] <- position + else + localMask.[lid] <- 0 + + let localPositions = localArray workGroupSize + + for currentBit in 0 .. bitCount - 1 do + let isCurrentPosition = localMask.[lid] = currentBit + + if isCurrentPosition && gid < length then + localPositions.[lid] <- 1 + else + localPositions.[lid] <- 0 + + barrierLocal () + + (%localPrefixSum) lid workGroupSize localPositions + + barrierLocal () + + if gid < length && isCurrentPosition then + localOffsets.[gid] <- localPositions.[lid] - 1 + + if lid = 0 then + let processedItemsCount = localPositions.[workGroupSize - 1] + let wgId = gid / workGroupSize + + globalOffsets.[workGroupCount.Value * currentBit + wgId] <- processedItemsCount @> + + let kernel = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) (indices: ClArray) (clWorkGroupCount: ClCell) (shift: ClCell) -> + let ndRange = + Range1D.CreateValid(indices.Length, workGroupSize) + + let workGroupCount = (indices.Length - 1) / workGroupSize + 1 + + let globalOffsetsLength = bitCount * workGroupCount + + let globalOffsets = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, globalOffsetsLength) + + let localOffsets = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, indices.Length) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + indices.Length + indices + clWorkGroupCount + shift + globalOffsets + localOffsets) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + globalOffsets, localOffsets + + let scatter (clContext: ClContext) workGroupSize mask = + + let kernel = + <@ fun (ndRange: Range1D) length (keys: ClArray) (shift: ClCell) (workGroupCount: ClCell) (globalOffsets: ClArray) (localOffsets: ClArray) (result: ClArray) -> + + let gid = ndRange.GlobalID0 + let wgId = gid / workGroupSize + + let workGroupCount = workGroupCount.Value + + if gid < length then + let slot = (keys.[gid] >>> shift.Value) &&& mask + + let localOffset = localOffsets.[gid] + + let globalOffset = + globalOffsets.[workGroupCount * slot + wgId] + + let offset = globalOffset + localOffset + + result.[offset] <- keys.[gid] @> + + let kernel = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) (keys: ClArray) (shift: ClCell) (workGroupCount: ClCell) (globalOffset: ClArray) (localOffsets: ClArray) (result: ClArray) -> + + let ndRange = + Range1D.CreateValid(keys.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc ndRange keys.Length keys shift workGroupCount globalOffset localOffsets result) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let runKeysOnly (clContext: ClContext) workGroupSize bitCount = + let copy = ClArray.copy clContext workGroupSize + + let mask = (pown 2 bitCount) - 1 + + let count = count clContext workGroupSize mask + + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + let scatter = scatter clContext workGroupSize mask + + fun (processor: MailboxProcessor<_>) (keys: ClArray) -> + if keys.Length <= 1 then + copy processor DeviceOnly keys // TODO(allocation mode) + else + let firstKeys = copy processor DeviceOnly keys + + let secondKeys = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, keys.Length) + + let workGroupCount = + clContext.CreateClCell((keys.Length - 1) / workGroupSize + 1) + + let mutable pair = (firstKeys, secondKeys) + let swap (x, y) = y, x + + let highBound = keyBitCount / bitCount - 1 + + for i in 0 .. highBound do + let shift = clContext.CreateClCell(bitCount * i) + + let globalOffset, localOffset = + count processor (fst pair) workGroupCount shift + + (prefixSum processor globalOffset).Free processor + + scatter processor (fst pair) shift workGroupCount globalOffset localOffset (snd pair) + + pair <- swap pair + + globalOffset.Free processor + localOffset.Free processor + shift.Free processor + + (snd pair).Free processor + fst pair + + let standardRunKeysOnly clContext workGroupSize = + runKeysOnly clContext workGroupSize defaultBitCount + + let scatterByKey (clContext: ClContext) workGroupSize mask = + + let kernel = + <@ fun (ndRange: Range1D) length (keys: ClArray) (values: ClArray<'a>) (shift: ClCell) (workGroupCount: ClCell) (globalOffsets: ClArray) (localOffsets: ClArray) (resultKeys: ClArray) (resultValues: ClArray<'a>) -> + + let gid = ndRange.GlobalID0 + let wgId = gid / workGroupSize + + let workGroupCount = workGroupCount.Value + + if gid < length then + let slot = (keys.[gid] >>> shift.Value) &&& mask + + let localOffset = localOffsets.[gid] + + let globalOffset = + globalOffsets.[workGroupCount * slot + wgId] + + let offset = globalOffset + localOffset + + resultKeys.[offset] <- keys.[gid] + resultValues.[offset] <- values.[gid] @> + + let kernel = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) (keys: ClArray) (values: ClArray<'a>) (shift: ClCell) (workGroupCount: ClCell) (globalOffset: ClArray) (localOffsets: ClArray) (resultKeys: ClArray) (resultValues: ClArray<'a>) -> + + let ndRange = + Range1D.CreateValid(keys.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + keys.Length + keys + values + shift + workGroupCount + globalOffset + localOffsets + resultKeys + resultValues) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let runByKeys (clContext: ClContext) workGroupSize bitCount = + let copy = ClArray.copy clContext workGroupSize + + let dataCopy = ClArray.copy clContext workGroupSize + + let mask = (pown 2 bitCount) - 1 + + let count = count clContext workGroupSize mask + + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + let scatterByKey = + scatterByKey clContext workGroupSize mask + + fun (processor: MailboxProcessor<_>) allocationMode (keys: ClArray) (values: ClArray<'a>) -> + if values.Length <> keys.Length then + failwith "Mismatch of key lengths and value. Lengths must be the same" + + if values.Length <= 1 then + dataCopy processor allocationMode values + else + let firstKeys = copy processor DeviceOnly keys + + let secondKeys = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, keys.Length) + + let firstValues = dataCopy processor DeviceOnly values + + let secondValues = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values.Length) + + let workGroupCount = + clContext.CreateClCell((keys.Length - 1) / workGroupSize + 1) + + let mutable keysPair = (firstKeys, secondKeys) + let mutable valuesPair = (firstValues, secondValues) + + let swap (x, y) = y, x + // compute bound of iterations + let highBound = keyBitCount / bitCount - 1 + + for i in 0 .. highBound do + let shift = clContext.CreateClCell(bitCount * i) + + let currentKeys = fst keysPair + let resultKeysBuffer = snd keysPair + + let currentValues = fst valuesPair + let resultValuesBuffer = snd valuesPair + + let globalOffset, localOffset = + count processor currentKeys workGroupCount shift + + (prefixSum processor globalOffset).Free processor + + scatterByKey + processor + currentKeys + currentValues + shift + workGroupCount + globalOffset + localOffset + resultKeysBuffer + resultValuesBuffer + + keysPair <- swap keysPair + valuesPair <- swap valuesPair + + localOffset.Free processor + shift.Free processor + + (fst keysPair).Free processor + (snd keysPair).Free processor + (snd valuesPair).Free processor + + (fst valuesPair) + + let runByKeysStandard clContext workGroupSize = + runByKeys clContext workGroupSize defaultBitCount diff --git a/src/GraphBLAS-sharp.Backend/Common/Sum.fs b/src/GraphBLAS-sharp.Backend/Common/Sum.fs index ed80ee40..fe7feeb2 100644 --- a/src/GraphBLAS-sharp.Backend/Common/Sum.fs +++ b/src/GraphBLAS-sharp.Backend/Common/Sum.fs @@ -5,8 +5,13 @@ 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 +open GraphBLAS.FSharp.Backend.Objects.ClCell module Reduce = + /// + /// Generalized reduction pattern. + /// let private runGeneral (clContext: ClContext) workGroupSize scan scanToCell = fun (processor: MailboxProcessor<_>) (inputArray: ClArray<'a>) -> @@ -45,12 +50,12 @@ 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 - let private scanSum (clContext: ClContext) (workGroupSize: int) (opAdd: Expr<'a -> 'a -> 'a>) zero = + let private scanSum (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) (workGroupSize: int) zero = let subSum = SubSum.sequentialSum opAdd @@ -87,7 +92,7 @@ module Reduce = processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - let private scanToCellSum (clContext: ClContext) workGroupSize (opAdd: Expr<'a -> 'a -> 'a>) zero = + let private scanToCellSum (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize zero = let subSum = SubSum.sequentialSum opAdd @@ -127,12 +132,19 @@ module Reduce = resultCell - let sum (clContext: ClContext) workGroupSize op zero = + /// + /// Summarize array elements. + /// + /// ClContext. + /// Work group size. + /// Summation operation. + /// Neutral element for summation. + let sum op zero (clContext: ClContext) workGroupSize = - let scan = scanSum clContext workGroupSize op zero + let scan = scanSum op clContext workGroupSize zero let scanToCell = - scanToCellSum clContext workGroupSize op zero + scanToCellSum op clContext workGroupSize zero let run = runGeneral clContext workGroupSize scan scanToCell @@ -140,9 +152,9 @@ module Reduce = fun (processor: MailboxProcessor<_>) (array: ClArray<'a>) -> run processor array let private scanReduce<'a when 'a: struct> + (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) (workGroupSize: int) - (opAdd: Expr<'a -> 'a -> 'a>) = let scan = @@ -181,9 +193,9 @@ module Reduce = processor.Post(Msg.CreateRunMsg<_, _>(kernel)) let private scanToCellReduce<'a when 'a: struct> + (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) (workGroupSize: int) - (opAdd: Expr<'a -> 'a -> 'a>) = let scan = @@ -224,14 +236,644 @@ module Reduce = resultCell - let reduce (clContext: ClContext) workGroupSize op = + /// + /// Reduce an array of values. + /// + /// ClContext. + /// Work group size. + /// Reduction operation. + let reduce op (clContext: ClContext) workGroupSize = - let scan = scanReduce clContext workGroupSize op + let scan = scanReduce op clContext workGroupSize let scanToCell = - scanToCellReduce clContext workGroupSize op + scanToCellReduce op clContext workGroupSize let run = runGeneral clContext workGroupSize scan scanToCell fun (processor: MailboxProcessor<_>) (array: ClArray<'a>) -> run processor array + + /// + /// Reduction of an array of values by an array of keys. + /// + module ByKey = + /// + /// Reduce an array of values by key using a single work item. + /// + /// ClContext. + /// Work group size. + /// Operation for reducing values. + /// + /// The length of the result must be calculated in advance. + /// + let sequential (reduceOp: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) length (keys: ClArray) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (reducedKeys: ClArray) -> + + 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) (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)) + + reducedValues, reducedKeys + + /// + /// Reduces values by key. Each segment is reduced by one work item. + /// + /// ClContext. + /// Work group size. + /// Operation for reducing values. + /// + /// The length of the result must be calculated in advance. + /// + let segmentSequential (reduceOp: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) uniqueKeyCount keysLength (offsets: ClArray) (keys: ClArray) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (reducedKeys: ClArray) -> + + 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) (keys: ClArray) (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)) + + reducedValues, reducedKeys + + /// + /// Reduces values by key. One work group participates in the reduction. + /// + /// ClContext. + /// Work group size. + /// Operation for reducing values. + /// + /// Reduces an array of values that does not exceed the size of the workgroup. + /// The length of the result must be calculated in advance. + /// + let oneWorkGroupSegments (reduceOp: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) length (keys: ClArray) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (reducedKeys: ClArray) -> + + 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 workGroupSize + + if lid < length then + localKeys.[lid] <- keys.[lid] + + // get unique keys bitmap + let localBitmap = localArray workGroupSize + localBitmap.[lid] <- 0 + (%PreparePositions.getUniqueBitmapLocal) 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) (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)) + + reducedValues, reducedKeys + + module Option = + /// + /// Reduces values by key. Each segment is reduced by one work item. + /// + /// ClContext. + /// Work group size. + /// Operation for reducing values. + /// + /// The length of the result must be calculated in advance. + /// + let segmentSequential<'a> (reduceOp: Expr<'a -> 'a -> 'a option>) (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) uniqueKeyCount keysLength (offsets: ClArray) (keys: ClArray) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (firstReducedKeys: ClArray) (resultPositions: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < uniqueKeyCount then + let startPosition = offsets.[gid] + + let firstSourceKey = keys.[startPosition] + + let mutable sum = Some values.[startPosition] + + let mutable currentPosition = startPosition + 1 + + while currentPosition < keysLength + && firstSourceKey = keys.[currentPosition] do + + match sum with + | Some value -> + let result = + ((%reduceOp) value values.[currentPosition]) // brahma error + + sum <- result + | None -> sum <- Some values.[currentPosition] + + currentPosition <- currentPosition + 1 + + match sum with + | Some value -> + reducedValues.[gid] <- value + resultPositions.[gid] <- 1 + | None -> resultPositions.[gid] <- 0 + + firstReducedKeys.[gid] <- firstSourceKey @> + + let kernel = clContext.Compile kernel + + let scatterData = + Scatter.lastOccurrence clContext workGroupSize + + let scatterIndices = + Scatter.lastOccurrence clContext workGroupSize + + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (resultLength: int) (offsets: ClArray) (keys: ClArray) (values: ClArray<'a>) -> + + let reducedValues = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let reducedKeys = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultPositions = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, 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 + resultPositions) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let resultLength = + (prefixSum processor resultPositions) + .ToHostAndFree processor + + if resultLength = 0 then + None + else + // write values + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + scatterData processor resultPositions reducedValues resultValues + + reducedValues.Free processor + + // write keys + let resultKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + scatterIndices processor resultPositions reducedKeys resultKeys + + reducedKeys.Free processor + resultPositions.Free processor + + Some(resultValues, resultKeys) + + module ByKey2D = + /// + /// Reduce an array of values by 2D keys using a single work item. + /// + /// ClContext. + /// Work group size. + /// Operation for reducing values. + /// + /// The length of the result must be calculated in advance. + /// + let sequential (reduceOp: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) length (firstKeys: ClArray) (secondKeys: ClArray) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (firstReducedKeys: ClArray) (secondReducedKeys: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid = 0 then + let mutable firstCurrentKey = firstKeys.[0] + let mutable secondCurrentKey = secondKeys.[0] + + let mutable segmentResult = values.[0] + let mutable segmentCount = 0 + + for i in 1 .. length - 1 do + if firstCurrentKey = firstKeys.[i] + && secondCurrentKey = secondKeys.[i] then + segmentResult <- (%reduceOp) segmentResult values.[i] + else + reducedValues.[segmentCount] <- segmentResult + + firstReducedKeys.[segmentCount] <- firstCurrentKey + secondReducedKeys.[segmentCount] <- secondCurrentKey + + segmentCount <- segmentCount + 1 + firstCurrentKey <- firstKeys.[i] + secondCurrentKey <- secondKeys.[i] + segmentResult <- values.[i] + + firstReducedKeys.[segmentCount] <- firstCurrentKey + secondReducedKeys.[segmentCount] <- secondCurrentKey + + reducedValues.[segmentCount] <- segmentResult @> + + let kernel = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) allocationMode (resultLength: int) (firstKeys: ClArray) (secondKeys: ClArray) (values: ClArray<'a>) -> + + let reducedValues = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let firstReducedKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let secondReducedKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + firstKeys.Length + firstKeys + secondKeys + values + reducedValues + firstReducedKeys + secondReducedKeys) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + reducedValues, firstReducedKeys, secondReducedKeys + + /// + /// Reduces values by key. Each segment is reduced by one work item. + /// + /// ClContext. + /// Work group size. + /// Operation for reducing values. + /// + /// The length of the result must be calculated in advance. + /// + let segmentSequential<'a> (reduceOp: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) uniqueKeyCount keysLength (offsets: ClArray) (firstKeys: ClArray) (secondKeys: ClArray) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (firstReducedKeys: ClArray) (secondReducedKeys: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < uniqueKeyCount then + let startPosition = offsets.[gid] + + let firstSourceKey = firstKeys.[startPosition] + let secondSourceKey = secondKeys.[startPosition] + + let mutable sum = values.[startPosition] + + let mutable currentPosition = startPosition + 1 + + while currentPosition < keysLength + && firstSourceKey = firstKeys.[currentPosition] + && secondSourceKey = secondKeys.[currentPosition] do + + sum <- (%reduceOp) sum values.[currentPosition] + currentPosition <- currentPosition + 1 + + reducedValues.[gid] <- sum + firstReducedKeys.[gid] <- firstSourceKey + secondReducedKeys.[gid] <- secondSourceKey @> + + let kernel = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) allocationMode (resultLength: int) (offsets: ClArray) (firstKeys: ClArray) (secondKeys: ClArray) (values: ClArray<'a>) -> + + let reducedValues = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let firstReducedKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let secondReducedKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + resultLength + firstKeys.Length + offsets + firstKeys + secondKeys + values + reducedValues + firstReducedKeys + secondReducedKeys) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + reducedValues, firstReducedKeys, secondReducedKeys + + module Option = + /// + /// Reduces values by key. Each segment is reduced by one work item. + /// + /// ClContext. + /// Work group size. + /// Operation for reducing values. + /// + /// The length of the result must be calculated in advance. + /// + let segmentSequential<'a> (reduceOp: Expr<'a -> 'a -> 'a option>) (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) uniqueKeyCount keysLength (offsets: ClArray) (firstKeys: ClArray) (secondKeys: ClArray) (values: ClArray<'a>) (reducedValues: ClArray<'a>) (firstReducedKeys: ClArray) (secondReducedKeys: ClArray) (resultPositions: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < uniqueKeyCount then + let startPosition = offsets.[gid] + + let firstSourceKey = firstKeys.[startPosition] + let secondSourceKey = secondKeys.[startPosition] + + let mutable sum = Some values.[startPosition] + + let mutable currentPosition = startPosition + 1 + + while currentPosition < keysLength + && firstSourceKey = firstKeys.[currentPosition] + && secondSourceKey = secondKeys.[currentPosition] do + + match sum with + | Some value -> + let result = + ((%reduceOp) value values.[currentPosition]) // brahma error + + sum <- result + | None -> sum <- Some values.[currentPosition] + + currentPosition <- currentPosition + 1 + + match sum with + | Some value -> + reducedValues.[gid] <- value + resultPositions.[gid] <- 1 + | None -> resultPositions.[gid] <- 0 + + firstReducedKeys.[gid] <- firstSourceKey + secondReducedKeys.[gid] <- secondSourceKey @> + + let kernel = clContext.Compile kernel + + let scatterData = + Scatter.lastOccurrence clContext workGroupSize + + let scatterIndices = + Scatter.lastOccurrence clContext workGroupSize + + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (resultLength: int) (offsets: ClArray) (firstKeys: ClArray) (secondKeys: ClArray) (values: ClArray<'a>) -> + + let reducedValues = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let firstReducedKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let secondReducedKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let resultPositions = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + resultLength + firstKeys.Length + offsets + firstKeys + secondKeys + values + reducedValues + firstReducedKeys + secondReducedKeys + resultPositions) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let resultLength = + (prefixSum processor resultPositions) + .ToHostAndFree processor + + if resultLength = 0 then + None + else + // write value + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + scatterData processor resultPositions reducedValues resultValues + + reducedValues.Free processor + + // write first keys + let resultFirstKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + scatterIndices processor resultPositions firstReducedKeys resultFirstKeys + + firstReducedKeys.Free processor + + // write second keys + let resultSecondKeys = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + scatterIndices processor resultPositions secondReducedKeys resultSecondKeys + + secondReducedKeys.Free processor + + resultPositions.Free processor + + Some(resultValues, resultFirstKeys, resultSecondKeys) diff --git a/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj b/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj index 35d7e632..4709660f 100644 --- a/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj +++ b/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj @@ -18,6 +18,7 @@ + @@ -26,41 +27,42 @@ + + - + - - - + + + + + + + + + + + + + - - - - + + + + + + + + + + + + - - - - - + - - - - - diff --git a/src/GraphBLAS-sharp.Backend/Matrix/COO/Map.fs b/src/GraphBLAS-sharp.Backend/Matrix/COO/Map.fs new file mode 100644 index 00000000..7700b476 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/COO/Map.fs @@ -0,0 +1,116 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.COO + +open System +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Quotes +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Objects.ClMatrix +open GraphBLAS.FSharp.Backend.Objects.ClContext + +module internal Map = + let preparePositions<'a, 'b> opAdd (clContext: ClContext) workGroupSize = + + let preparePositions (op: Expr<'a option -> 'b option>) = + <@ fun (ndRange: Range1D) rowCount columnCount valuesLength (values: ClArray<'a>) (rows: ClArray) (columns: ClArray) (resultBitmap: ClArray) (resultValues: ClArray<'b>) (resultRows: ClArray) (resultColumns: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < rowCount * columnCount then + + let columnIndex = gid % columnCount + let rowIndex = gid / columnCount + + let index = + (uint64 rowIndex <<< 32) ||| (uint64 columnIndex) + + let value = + (%Search.Bin.byKey2D) valuesLength index rows columns values + + match (%op) value with + | Some resultValue -> + resultValues.[gid] <- resultValue + resultRows.[gid] <- rowIndex + resultColumns.[gid] <- columnIndex + + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = + clContext.Compile <| preparePositions opAdd + + fun (processor: MailboxProcessor<_>) rowCount columnCount (values: ClArray<'a>) (rowPointers: ClArray) (columns: ClArray) -> + + let (resultLength: int) = columnCount * rowCount + + let resultBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultRows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultColumns = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'b>(DeviceOnly, resultLength) + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + rowCount + columnCount + values.Length + values + rowPointers + columns + resultBitmap + resultValues + resultRows + resultColumns) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + resultBitmap, resultValues, resultRows, resultColumns + + let run<'a, 'b when 'a: struct and 'b: struct and 'b: equality> + (opAdd: Expr<'a option -> 'b option>) + (clContext: ClContext) + workGroupSize + = + + let map = + preparePositions opAdd clContext workGroupSize + + let setPositions = + Common.setPositions<'b> clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> + + let bitmap, values, rows, columns = + map queue matrix.RowCount matrix.ColumnCount matrix.Values matrix.Rows matrix.Columns + + let resultRows, resultColumns, resultValues, _ = + setPositions queue allocationMode rows columns values bitmap + + queue.Post(Msg.CreateFreeMsg<_>(bitmap)) + queue.Post(Msg.CreateFreeMsg<_>(values)) + queue.Post(Msg.CreateFreeMsg<_>(rows)) + queue.Post(Msg.CreateFreeMsg<_>(columns)) + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = resultRows + Columns = resultColumns + Values = resultValues } diff --git a/src/GraphBLAS-sharp.Backend/Matrix/COO/Map2.fs b/src/GraphBLAS-sharp.Backend/Matrix/COO/Map2.fs new file mode 100644 index 00000000..3d79eb9a --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/COO/Map2.fs @@ -0,0 +1,255 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.COO + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Matrix +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Objects.ClMatrix +open GraphBLAS.FSharp.Backend.Objects.ClContext + +module internal Map2 = + + let preparePositions<'a, 'b, 'c> opAdd (clContext: ClContext) workGroupSize = + + let preparePositions (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun (ndRange: Range1D) rowCount columnCount leftValuesLength rightValuesLength (leftValues: ClArray<'a>) (leftRows: ClArray) (leftColumns: ClArray) (rightValues: ClArray<'b>) (rightRows: ClArray) (rightColumn: ClArray) (resultBitmap: ClArray) (resultValues: ClArray<'c>) (resultRows: ClArray) (resultColumns: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < rowCount * columnCount then + + let columnIndex = gid % columnCount + let rowIndex = gid / columnCount + + let index = + (uint64 rowIndex <<< 32) ||| (uint64 columnIndex) + + let leftValue = + (%Search.Bin.byKey2D) leftValuesLength index leftRows leftColumns leftValues + + let rightValue = + (%Search.Bin.byKey2D) rightValuesLength index rightRows rightColumn rightValues + + match (%op) leftValue rightValue with + | Some value -> + resultValues.[gid] <- value + resultRows.[gid] <- rowIndex + resultColumns.[gid] <- columnIndex + + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = + clContext.Compile <| preparePositions opAdd + + fun (processor: MailboxProcessor<_>) rowCount columnCount (leftValues: ClArray<'a>) (leftRows: ClArray) (leftColumns: ClArray) (rightValues: ClArray<'b>) (rightRows: ClArray) (rightColumns: ClArray) -> + + let (resultLength: int) = columnCount * rowCount + + let resultBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultRows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultColumns = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, resultLength) + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + rowCount + columnCount + leftValues.Length + rightValues.Length + leftValues + leftRows + leftColumns + rightValues + rightRows + rightColumns + resultBitmap + resultValues + resultRows + resultColumns) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + resultBitmap, resultValues, resultRows, resultColumns + + ///. + ///. + ///Should be a power of 2 and greater than 1. + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (opAdd: Expr<'a option -> 'b option -> 'c option>) + (clContext: ClContext) + workGroupSize + = + + let map2 = + preparePositions opAdd clContext workGroupSize + + let setPositions = + Common.setPositions<'c> clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrixLeft: ClMatrix.COO<'a>) (matrixRight: ClMatrix.COO<'b>) -> + + let bitmap, values, rows, columns = + map2 + queue + matrixLeft.RowCount + matrixLeft.ColumnCount + matrixLeft.Values + matrixLeft.Rows + matrixLeft.Columns + matrixRight.Values + matrixRight.Rows + matrixRight.Columns + + let resultRows, resultColumns, resultValues, _ = + setPositions queue allocationMode rows columns values bitmap + + queue.Post(Msg.CreateFreeMsg<_>(bitmap)) + queue.Post(Msg.CreateFreeMsg<_>(values)) + queue.Post(Msg.CreateFreeMsg<_>(rows)) + queue.Post(Msg.CreateFreeMsg<_>(columns)) + + { Context = clContext + RowCount = matrixLeft.RowCount + ColumnCount = matrixLeft.ColumnCount + Rows = resultRows + Columns = resultColumns + Values = resultValues } + + module AtLeastOne = + let preparePositionsAtLeastOne<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (clContext: ClContext) + (opAdd: Expr<'a option -> 'b option -> 'c option>) + workGroupSize + = + + let preparePositions = + <@ fun (ndRange: Range1D) length (allRowsBuffer: ClArray) (allColumnsBuffer: ClArray) (leftValuesBuffer: ClArray<'a>) (rightValuesBuffer: ClArray<'b>) (allValuesBuffer: ClArray<'c>) (rawPositionsBuffer: ClArray) (isLeftBitmap: ClArray) -> + + let i = ndRange.GlobalID0 + + if (i < length - 1 + && allRowsBuffer.[i] = allRowsBuffer.[i + 1] + && allColumnsBuffer.[i] = allColumnsBuffer.[i + 1]) then + + let result = + (%opAdd) (Some leftValuesBuffer.[i + 1]) (Some rightValuesBuffer.[i]) + + (%PreparePositions.both) i result rawPositionsBuffer allValuesBuffer + elif (i > 0 + && i < length + && (allRowsBuffer.[i] <> allRowsBuffer.[i - 1] + || allColumnsBuffer.[i] <> allColumnsBuffer.[i - 1])) + || i = 0 then + + let leftResult = + (%opAdd) (Some leftValuesBuffer.[i]) None + + let rightResult = + (%opAdd) None (Some rightValuesBuffer.[i]) + + (%PreparePositions.leftRight) + i + leftResult + rightResult + isLeftBitmap + allValuesBuffer + rawPositionsBuffer @> + + let kernel = clContext.Compile(preparePositions) + + fun (processor: MailboxProcessor<_>) (allRows: ClArray) (allColumns: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isLeft: ClArray) -> + let length = leftValues.Length + + let ndRange = + Range1D.CreateValid(length, workGroupSize) + + let rawPositionsGpu = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, length) + + let allValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, length) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + length + allRows + allColumns + leftValues + rightValues + allValues + rawPositionsGpu + isLeft) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + rawPositionsGpu, allValues + + + ///. + ///. + ///Should be a power of 2 and greater than 1. + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (clContext: ClContext) + (opAdd: Expr<'a option -> 'b option -> 'c option>) + workGroupSize + = + + let merge = Merge.run clContext workGroupSize + + let preparePositions = + preparePositionsAtLeastOne clContext opAdd workGroupSize + + let setPositions = + Common.setPositions<'c> clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrixLeft: ClMatrix.COO<'a>) (matrixRight: ClMatrix.COO<'b>) -> + + let allRows, allColumns, leftMergedValues, rightMergedValues, isLeft = + merge queue matrixLeft matrixRight + + let rawPositions, allValues = + preparePositions queue allRows allColumns leftMergedValues rightMergedValues isLeft + + queue.Post(Msg.CreateFreeMsg<_>(leftMergedValues)) + queue.Post(Msg.CreateFreeMsg<_>(rightMergedValues)) + + let resultRows, resultColumns, resultValues, _ = + setPositions queue allocationMode allRows allColumns allValues rawPositions + + queue.Post(Msg.CreateFreeMsg<_>(isLeft)) + queue.Post(Msg.CreateFreeMsg<_>(rawPositions)) + queue.Post(Msg.CreateFreeMsg<_>(allRows)) + queue.Post(Msg.CreateFreeMsg<_>(allColumns)) + queue.Post(Msg.CreateFreeMsg<_>(allValues)) + + { Context = clContext + RowCount = matrixLeft.RowCount + ColumnCount = matrixLeft.ColumnCount + Rows = resultRows + Columns = resultColumns + Values = resultValues } diff --git a/src/GraphBLAS-sharp.Backend/Matrix/COO/Matrix.fs b/src/GraphBLAS-sharp.Backend/Matrix/COO/Matrix.fs new file mode 100644 index 00000000..fd0fc338 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/COO/Matrix.fs @@ -0,0 +1,159 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.COO + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Quotes +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClMatrix +open GraphBLAS.FSharp.Backend.Objects.ClCell +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects.ClContext + +module Matrix = + let map = Map.run + + let map2 = Map2.run + + ///. + ///. + ///Should be a power of 2 and greater than 1. + let rec map2AtLeastOne<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (clContext: ClContext) + (opAdd: Expr -> 'c option>) + workGroupSize + = + + Map2.AtLeastOne.run clContext (Convert.atLeastOneToOption opAdd) workGroupSize + + let getTuples (clContext: ClContext) workGroupSize = + + let copy = ClArray.copy clContext workGroupSize + + let copyData = ClArray.copy clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> + + let resultRows = + copy processor allocationMode matrix.Rows + + let resultColumns = + copy processor allocationMode matrix.Columns + + let resultValues = + copyData processor allocationMode matrix.Values + + { Context = clContext + RowIndices = resultRows + ColumnIndices = resultColumns + Values = resultValues } + + let private compressRows (clContext: ClContext) workGroupSize = + + let compressRows = + <@ fun (ndRange: Range1D) (rows: ClArray) (nnz: int) (rowPointers: ClArray) -> + + let i = ndRange.GlobalID0 + + if i < nnz then + let row = rows.[i] + + if i = 0 || row <> rows.[i - 1] then + rowPointers.[row] <- i @> + + let program = clContext.Compile(compressRows) + + let create = ClArray.create clContext workGroupSize + + let scan = + PrefixSum.runBackwardsIncludeInPlace <@ min @> clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (rowIndices: ClArray) rowCount -> + + let nnz = rowIndices.Length + + let rowPointers = + create processor allocationMode (rowCount + 1) nnz + + let kernel = program.GetKernel() + + let ndRange = Range1D.CreateValid(nnz, workGroupSize) + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange rowIndices nnz rowPointers)) + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + (scan processor rowPointers nnz).Free processor + + rowPointers + + let toCSR (clContext: ClContext) workGroupSize = + let prepare = compressRows clContext workGroupSize + + let copy = ClArray.copy clContext workGroupSize + + let copyData = ClArray.copy clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> + let rowPointers = + prepare processor allocationMode matrix.Rows matrix.RowCount + + let cols = + copy processor allocationMode matrix.Columns + + let values = + copyData processor allocationMode matrix.Values + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + RowPointers = rowPointers + Columns = cols + Values = values } + + let toCSRInPlace (clContext: ClContext) workGroupSize = + let prepare = compressRows clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> + let rowPointers = + prepare processor allocationMode matrix.Rows matrix.RowCount + + matrix.Rows.Free processor + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + RowPointers = rowPointers + Columns = matrix.Columns + Values = matrix.Values } + + let transposeInPlace (clContext: ClContext) workGroupSize = + + let sort = + Sort.Bitonic.sortKeyValuesInplace clContext workGroupSize + + fun (queue: MailboxProcessor<_>) (matrix: ClMatrix.COO<'a>) -> + sort queue matrix.Columns matrix.Rows matrix.Values + + { Context = clContext + RowCount = matrix.ColumnCount + ColumnCount = matrix.RowCount + Rows = matrix.Columns + Columns = matrix.Rows + Values = matrix.Values } + + let transpose (clContext: ClContext) workGroupSize = + + let transposeInPlace = transposeInPlace clContext workGroupSize + + let copy = ClArray.copy clContext workGroupSize + + let copyData = ClArray.copy clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = copy queue allocationMode matrix.Rows + Columns = copy queue allocationMode matrix.Columns + Values = copyData queue allocationMode matrix.Values } + |> transposeInPlace queue diff --git a/src/GraphBLAS-sharp.Backend/Matrix/COO/Merge.fs b/src/GraphBLAS-sharp.Backend/Matrix/COO/Merge.fs new file mode 100644 index 00000000..e9cbf08d --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/COO/Merge.fs @@ -0,0 +1,182 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.COO + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects + +module Merge = + let run<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) workGroupSize = + + let merge = + <@ fun (ndRange: Range1D) firstSide secondSide sumOfSides (firstRowsBuffer: ClArray) (firstColumnsBuffer: ClArray) (firstValuesBuffer: ClArray<'a>) (secondRowsBuffer: ClArray) (secondColumnsBuffer: ClArray) (secondValuesBuffer: ClArray<'b>) (allRowsBuffer: ClArray) (allColumnsBuffer: ClArray) (leftMergedValuesBuffer: ClArray<'a>) (rightMergedValuesBuffer: ClArray<'b>) (isLeftBitmap: ClArray) -> + + let i = ndRange.GlobalID0 + + let mutable beginIdxLocal = local () + let mutable endIdxLocal = local () + let localID = ndRange.LocalID0 + + if localID < 2 then + let x = localID * (workGroupSize - 1) + i - 1 + + let diagonalNumber = min (sumOfSides - 1) x + + let mutable leftEdge = diagonalNumber + 1 - secondSide + leftEdge <- max 0 leftEdge + + let mutable rightEdge = firstSide - 1 + + rightEdge <- min diagonalNumber rightEdge + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + + let firstIndex: uint64 = + ((uint64 firstRowsBuffer.[middleIdx]) <<< 32) + ||| (uint64 firstColumnsBuffer.[middleIdx]) + + let secondIndex: uint64 = + ((uint64 secondRowsBuffer.[diagonalNumber - middleIdx]) + <<< 32) + ||| (uint64 secondColumnsBuffer.[diagonalNumber - middleIdx]) + + if firstIndex < secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 + + // Here localID equals either 0 or 1 + if localID = 0 then + beginIdxLocal <- leftEdge + else + endIdxLocal <- leftEdge + + barrierLocal () + + let beginIdx = beginIdxLocal + let endIdx = endIdxLocal + let firstLocalLength = endIdx - beginIdx + let mutable x = workGroupSize - firstLocalLength + + if endIdx = firstSide then + x <- secondSide - i + localID + beginIdx + + let secondLocalLength = x + + //First indices are from 0 to firstLocalLength - 1 inclusive + //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive + let localIndices = localArray workGroupSize + + if localID < firstLocalLength then + localIndices.[localID] <- + ((uint64 firstRowsBuffer.[beginIdx + localID]) + <<< 32) + ||| (uint64 firstColumnsBuffer.[beginIdx + localID]) + + if localID < secondLocalLength then + localIndices.[firstLocalLength + localID] <- + ((uint64 secondRowsBuffer.[i - beginIdx]) <<< 32) + ||| (uint64 secondColumnsBuffer.[i - beginIdx]) + + barrierLocal () + + if i < sumOfSides then + let mutable leftEdge = localID + 1 - secondLocalLength + leftEdge <- max 0 leftEdge + + let mutable rightEdge = firstLocalLength - 1 + + rightEdge <- min localID rightEdge + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + let firstIndex = localIndices.[middleIdx] + + let secondIndex = + localIndices.[firstLocalLength + localID - middleIdx] + + if firstIndex < secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 + + let boundaryX = rightEdge + let boundaryY = localID - leftEdge + + // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) + let isValidX = boundaryX >= 0 + let isValidY = boundaryY >= 0 + + let mutable fstIdx = 0UL + + if isValidX then + fstIdx <- localIndices.[boundaryX] + + let mutable sndIdx = 0UL + + if isValidY then + sndIdx <- localIndices.[firstLocalLength + boundaryY] + + if not isValidX || isValidY && fstIdx < sndIdx then + allRowsBuffer.[i] <- int (sndIdx >>> 32) + allColumnsBuffer.[i] <- int sndIdx + rightMergedValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] + isLeftBitmap.[i] <- 0 + else + allRowsBuffer.[i] <- int (fstIdx >>> 32) + allColumnsBuffer.[i] <- int fstIdx + leftMergedValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] + isLeftBitmap.[i] <- 1 @> + + let kernel = clContext.Compile(merge) + + fun (processor: MailboxProcessor<_>) (leftMatrix: ClMatrix.COO<'a>) (rightMatrix: ClMatrix.COO<'b>) -> + + let firstSide = leftMatrix.Columns.Length + let secondSide = rightMatrix.Columns.Length + let sumOfSides = firstSide + secondSide + + let allRows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) + + let allColumns = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) + + let leftMergedValues = + clContext.CreateClArrayWithSpecificAllocationMode<'a>(DeviceOnly, sumOfSides) + + let rightMergedValues = + clContext.CreateClArrayWithSpecificAllocationMode<'b>(DeviceOnly, sumOfSides) + + let isLeft = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) + + let ndRange = + Range1D.CreateValid(sumOfSides, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + firstSide + secondSide + sumOfSides + leftMatrix.Rows + leftMatrix.Columns + leftMatrix.Values + rightMatrix.Rows + rightMatrix.Columns + rightMatrix.Values + allRows + allColumns + leftMergedValues + rightMergedValues + isLeft) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + allRows, allColumns, leftMergedValues, rightMergedValues, isLeft diff --git a/src/GraphBLAS-sharp.Backend/Matrix/COOMatrix/COOMatrix.fs b/src/GraphBLAS-sharp.Backend/Matrix/COOMatrix/COOMatrix.fs deleted file mode 100644 index 720ec20a..00000000 --- a/src/GraphBLAS-sharp.Backend/Matrix/COOMatrix/COOMatrix.fs +++ /dev/null @@ -1,455 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.Matrix.COO - -open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.Quotes -open Microsoft.FSharp.Quotations -open GraphBLAS.FSharp.Backend.Objects -open GraphBLAS.FSharp.Backend -open GraphBLAS.FSharp.Backend.Objects.ClMatrix -open GraphBLAS.FSharp.Backend.Objects.ClContext - -module COOMatrix = - let private preparePositions<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> - (clContext: ClContext) - (opAdd: Expr<'a option -> 'b option -> 'c option>) - workGroupSize - = - - let preparePositions = - <@ fun (ndRange: Range1D) length (allRowsBuffer: ClArray) (allColumnsBuffer: ClArray) (leftValuesBuffer: ClArray<'a>) (rightValuesBuffer: ClArray<'b>) (allValuesBuffer: ClArray<'c>) (rawPositionsBuffer: ClArray) (isLeftBitmap: ClArray) -> - - let i = ndRange.GlobalID0 - - if (i < length - 1 - && allRowsBuffer.[i] = allRowsBuffer.[i + 1] - && allColumnsBuffer.[i] = allColumnsBuffer.[i + 1]) then - - let result = - (%opAdd) (Some leftValuesBuffer.[i + 1]) (Some rightValuesBuffer.[i]) - - (%PreparePositions.both) i result rawPositionsBuffer allValuesBuffer - elif (i > 0 - && i < length - && (allRowsBuffer.[i] <> allRowsBuffer.[i - 1] - || allColumnsBuffer.[i] <> allColumnsBuffer.[i - 1])) - || i = 0 then - - let leftResult = - (%opAdd) (Some leftValuesBuffer.[i]) None - - let rightResult = - (%opAdd) None (Some rightValuesBuffer.[i]) - - (%PreparePositions.leftRight) - i - leftResult - rightResult - isLeftBitmap - allValuesBuffer - rawPositionsBuffer @> - - let kernel = clContext.Compile(preparePositions) - - fun (processor: MailboxProcessor<_>) (allRows: ClArray) (allColumns: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isLeft: ClArray) -> - let length = leftValues.Length - - let ndRange = - Range1D.CreateValid(length, workGroupSize) - - let rawPositionsGpu = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, length) - - let allValues = - clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, length) - - let kernel = kernel.GetKernel() - - processor.Post( - Msg.MsgSetArguments - (fun () -> - kernel.KernelFunc - ndRange - length - allRows - allColumns - leftValues - rightValues - allValues - rawPositionsGpu - isLeft) - ) - - processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - rawPositionsGpu, allValues - - let private merge<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) workGroupSize = - - let merge = - <@ fun (ndRange: Range1D) firstSide secondSide sumOfSides (firstRowsBuffer: ClArray) (firstColumnsBuffer: ClArray) (firstValuesBuffer: ClArray<'a>) (secondRowsBuffer: ClArray) (secondColumnsBuffer: ClArray) (secondValuesBuffer: ClArray<'b>) (allRowsBuffer: ClArray) (allColumnsBuffer: ClArray) (leftMergedValuesBuffer: ClArray<'a>) (rightMergedValuesBuffer: ClArray<'b>) (isLeftBitmap: ClArray) -> - - let i = ndRange.GlobalID0 - - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 - - if localID < 2 then - let x = localID * (workGroupSize - 1) + i - 1 - - let diagonalNumber = min (sumOfSides - 1) x - - let mutable leftEdge = diagonalNumber + 1 - secondSide - leftEdge <- max 0 leftEdge - - let mutable rightEdge = firstSide - 1 - - rightEdge <- min diagonalNumber rightEdge - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - - let firstIndex: uint64 = - ((uint64 firstRowsBuffer.[middleIdx]) <<< 32) - ||| (uint64 firstColumnsBuffer.[middleIdx]) - - let secondIndex: uint64 = - ((uint64 secondRowsBuffer.[diagonalNumber - middleIdx]) - <<< 32) - ||| (uint64 secondColumnsBuffer.[diagonalNumber - middleIdx]) - - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge - - barrierLocal () - - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength - - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx - - let secondLocalLength = x - - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize - - if localID < firstLocalLength then - localIndices.[localID] <- - ((uint64 firstRowsBuffer.[beginIdx + localID]) - <<< 32) - ||| (uint64 firstColumnsBuffer.[beginIdx + localID]) - - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- - ((uint64 secondRowsBuffer.[i - beginIdx]) <<< 32) - ||| (uint64 secondColumnsBuffer.[i - beginIdx]) - - barrierLocal () - - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength - leftEdge <- max 0 leftEdge - - let mutable rightEdge = firstLocalLength - 1 - - rightEdge <- min localID rightEdge - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] - - let secondIndex = - localIndices.[firstLocalLength + localID - middleIdx] - - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - let boundaryX = rightEdge - let boundaryY = localID - leftEdge - - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 - - let mutable fstIdx = 0UL - - if isValidX then - fstIdx <- localIndices.[boundaryX] - - let mutable sndIdx = 0UL - - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] - - if not isValidX || isValidY && fstIdx < sndIdx then - allRowsBuffer.[i] <- int (sndIdx >>> 32) - allColumnsBuffer.[i] <- int sndIdx - rightMergedValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] - isLeftBitmap.[i] <- 0 - else - allRowsBuffer.[i] <- int (fstIdx >>> 32) - allColumnsBuffer.[i] <- int fstIdx - leftMergedValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] - isLeftBitmap.[i] <- 1 @> - - let kernel = clContext.Compile(merge) - - fun (processor: MailboxProcessor<_>) (matrixLeftRows: ClArray) (matrixLeftColumns: ClArray) (matrixLeftValues: ClArray<'a>) (matrixRightRows: ClArray) (matrixRightColumns: ClArray) (matrixRightValues: ClArray<'b>) -> - - let firstSide = matrixLeftValues.Length - let secondSide = matrixRightValues.Length - let sumOfSides = firstSide + secondSide - - let allRows = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) - - let allColumns = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) - - let leftMergedValues = - clContext.CreateClArrayWithSpecificAllocationMode<'a>(DeviceOnly, sumOfSides) - - let rightMergedValues = - clContext.CreateClArrayWithSpecificAllocationMode<'b>(DeviceOnly, sumOfSides) - - let isLeft = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) - - let ndRange = - Range1D.CreateValid(sumOfSides, workGroupSize) - - let kernel = kernel.GetKernel() - - processor.Post( - Msg.MsgSetArguments - (fun () -> - kernel.KernelFunc - ndRange - firstSide - secondSide - sumOfSides - matrixLeftRows - matrixLeftColumns - matrixLeftValues - matrixRightRows - matrixRightColumns - matrixRightValues - allRows - allColumns - leftMergedValues - rightMergedValues - isLeft) - ) - - processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - - allRows, allColumns, leftMergedValues, rightMergedValues, isLeft - - ///. - ///. - ///Should be a power of 2 and greater than 1. - let map2<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> - (clContext: ClContext) - (opAdd: Expr<'a option -> 'b option -> 'c option>) - workGroupSize - = - - let merge = merge clContext workGroupSize - - let preparePositions = - preparePositions clContext opAdd workGroupSize - - let setPositions = - Matrix.Common.setPositions<'c> clContext workGroupSize - - fun (queue: MailboxProcessor<_>) allocationMode (matrixLeft: ClMatrix.COO<'a>) (matrixRight: ClMatrix.COO<'b>) -> - - let allRows, allColumns, leftMergedValues, rightMergedValues, isLeft = - merge - queue - matrixLeft.Rows - matrixLeft.Columns - matrixLeft.Values - matrixRight.Rows - matrixRight.Columns - matrixRight.Values - - let rawPositions, allValues = - preparePositions queue allRows allColumns leftMergedValues rightMergedValues isLeft - - queue.Post(Msg.CreateFreeMsg<_>(leftMergedValues)) - queue.Post(Msg.CreateFreeMsg<_>(rightMergedValues)) - - let resultRows, resultColumns, resultValues, _ = - setPositions queue allocationMode allRows allColumns allValues rawPositions - - queue.Post(Msg.CreateFreeMsg<_>(isLeft)) - queue.Post(Msg.CreateFreeMsg<_>(rawPositions)) - queue.Post(Msg.CreateFreeMsg<_>(allRows)) - queue.Post(Msg.CreateFreeMsg<_>(allColumns)) - queue.Post(Msg.CreateFreeMsg<_>(allValues)) - - { Context = clContext - RowCount = matrixLeft.RowCount - ColumnCount = matrixLeft.ColumnCount - Rows = resultRows - Columns = resultColumns - Values = resultValues } - - let getTuples (clContext: ClContext) workGroupSize = - - let copy = ClArray.copy clContext workGroupSize - - let copyData = ClArray.copy clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> - - let resultRows = - copy processor allocationMode matrix.Rows - - let resultColumns = - copy processor allocationMode matrix.Columns - - let resultValues = - copyData processor allocationMode matrix.Values - - { Context = clContext - RowIndices = resultRows - ColumnIndices = resultColumns - Values = resultValues } - - let private compressRows (clContext: ClContext) workGroupSize = - - let compressRows = - <@ fun (ndRange: Range1D) (rows: ClArray) (nnz: int) (rowPointers: ClArray) -> - - let i = ndRange.GlobalID0 - - if i < nnz then - let row = rows.[i] - - if i = 0 || row <> rows.[i - 1] then - rowPointers.[row] <- i @> - - let program = clContext.Compile(compressRows) - - let create = ClArray.create clContext workGroupSize - - let scan = - ClArray.prefixSumBackwardsIncludeInplace <@ min @> clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (rowIndices: ClArray) rowCount -> - - let nnz = rowIndices.Length - - let rowPointers = - create processor allocationMode (rowCount + 1) nnz - - let kernel = program.GetKernel() - - let ndRange = Range1D.CreateValid(nnz, workGroupSize) - processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange rowIndices nnz rowPointers)) - processor.Post(Msg.CreateRunMsg<_, _> kernel) - - let result = scan processor rowPointers nnz - processor.Post <| Msg.CreateFreeMsg(result) - - rowPointers - - let toCSR (clContext: ClContext) workGroupSize = - let prepare = compressRows clContext workGroupSize - - let copy = ClArray.copy clContext workGroupSize - - let copyData = ClArray.copy clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> - let rowPointers = - prepare processor allocationMode matrix.Rows matrix.RowCount - - let cols = - copy processor allocationMode matrix.Columns - - let vals = - copyData processor allocationMode matrix.Values - - { Context = clContext - RowCount = matrix.RowCount - ColumnCount = matrix.ColumnCount - RowPointers = rowPointers - Columns = cols - Values = vals } - - let toCSRInplace (clContext: ClContext) workGroupSize = - let prepare = compressRows clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> - let rowPointers = - prepare processor allocationMode matrix.Rows matrix.RowCount - - processor.Post(Msg.CreateFreeMsg(matrix.Rows)) - - { Context = clContext - RowCount = matrix.RowCount - ColumnCount = matrix.ColumnCount - RowPointers = rowPointers - Columns = matrix.Columns - Values = matrix.Values } - - ///. - ///. - ///Should be a power of 2 and greater than 1. - let map2AtLeastOne<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> - (clContext: ClContext) - (opAdd: Expr -> 'c option>) - workGroupSize - = - - map2 clContext (Convert.atLeastOneToOption opAdd) workGroupSize - - let transposeInplace (clContext: ClContext) workGroupSize = - - let sort = - BitonicSort.sortKeyValuesInplace clContext workGroupSize - - fun (queue: MailboxProcessor<_>) (matrix: ClMatrix.COO<'a>) -> - sort queue matrix.Columns matrix.Rows matrix.Values - - { Context = clContext - RowCount = matrix.ColumnCount - ColumnCount = matrix.RowCount - Rows = matrix.Columns - Columns = matrix.Rows - Values = matrix.Values } - - let transpose (clContext: ClContext) workGroupSize = - - let transposeInplace = transposeInplace clContext workGroupSize - - let copy = ClArray.copy clContext workGroupSize - - let copyData = ClArray.copy clContext workGroupSize - - fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.COO<'a>) -> - - { Context = clContext - RowCount = matrix.RowCount - ColumnCount = matrix.ColumnCount - Rows = copy queue allocationMode matrix.Rows - Columns = copy queue allocationMode matrix.Columns - Values = copyData queue allocationMode matrix.Values } - |> transposeInplace queue diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSR/Kronecker.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Kronecker.fs new file mode 100644 index 00000000..10151f41 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Kronecker.fs @@ -0,0 +1,457 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.CSR + +open FSharpx.Collections +open Microsoft.FSharp.Quotations +open FSharp.Quotations.Evaluator.QuotationEvaluationExtensions +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Matrix.COO +open GraphBLAS.FSharp.Backend.Matrix.CSR +open GraphBLAS.FSharp.Backend.Objects.ClCell +open GraphBLAS.FSharp.Backend.Objects.ClMatrix +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +module internal Kronecker = + let private updateBitmap (clContext: ClContext) workGroupSize op = + + let updateBitmap (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun (ndRange: Range1D) (operand: ClCell<'a>) valuesLength zeroCount (values: ClArray<'b>) (resultBitmap: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid = 0 then + + let item = resultBitmap.[0] + let newItem = item + zeroCount + + match (%op) (Some operand.Value) None with + | Some _ -> resultBitmap.[0] <- newItem + | _ -> () + + elif (gid - 1) < valuesLength then + + let item = resultBitmap.[gid] + let newItem = item + 1 + + match (%op) (Some operand.Value) (Some values.[gid - 1]) with + | Some _ -> resultBitmap.[gid] <- newItem + | _ -> () @> + + let updateBitmap = clContext.Compile <| updateBitmap op + + fun (processor: MailboxProcessor<_>) (operand: ClCell<'a>) (matrixRight: CSR<'b>) (bitmap: ClArray) -> + + let resultLength = matrixRight.NNZ + 1 + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let updateBitmap = updateBitmap.GetKernel() + + let numberOfZeros = + matrixRight.ColumnCount * matrixRight.RowCount + - matrixRight.NNZ + + processor.Post( + Msg.MsgSetArguments + (fun () -> + updateBitmap.KernelFunc ndRange operand matrixRight.NNZ numberOfZeros matrixRight.Values bitmap) + ) + + processor.Post(Msg.CreateRunMsg<_, _> updateBitmap) + + let private getAllocationSize (clContext: ClContext) workGroupSize op = + + let updateBitmap = updateBitmap clContext workGroupSize op + + let sum = + Reduce.sum <@ fun x y -> x + y @> 0 clContext workGroupSize + + let item = ClArray.item clContext workGroupSize + + let createClArray = + ClArray.zeroCreate clContext workGroupSize + + let opOnHost = op.Evaluate() + + fun (queue: MailboxProcessor<_>) (matrixZero: COO<'c> option) (matrixLeft: CSR<'a>) (matrixRight: CSR<'b>) -> + + let nnz = + match opOnHost None None with + | Some _ -> + let leftZeroCount = + matrixLeft.RowCount * matrixLeft.ColumnCount + - matrixLeft.NNZ + + let rightZeroCount = + matrixRight.RowCount * matrixRight.ColumnCount + - matrixRight.NNZ + + leftZeroCount * rightZeroCount + | _ -> 0 + + let bitmap = + createClArray queue DeviceOnly (matrixRight.NNZ + 1) + + for index in 0 .. matrixLeft.NNZ - 1 do + let value = item queue index matrixLeft.Values + + updateBitmap queue value matrixRight bitmap + + value.Free queue + + let bitmapSum = sum queue bitmap + + bitmap.Free queue + + let leftZeroCount = + matrixLeft.ColumnCount * matrixLeft.RowCount + - matrixLeft.NNZ + + match matrixZero with + | Some m -> m.NNZ * leftZeroCount + | _ -> 0 + + nnz + + bitmapSum.ToHostAndFree queue + + let private preparePositions<'a, 'b, 'c when 'b: struct> (clContext: ClContext) workGroupSize op = + + let preparePositions (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun (ndRange: Range1D) (operand: ClCell<'a>) rowCount columnCount (values: ClArray<'b>) (rowPointers: ClArray) (columns: ClArray) (resultBitmap: ClArray) (resultValues: ClArray<'c>) -> + + let gid = ndRange.GlobalID0 + + if gid < rowCount * columnCount then + + let columnIndex = gid % columnCount + let rowIndex = gid / columnCount + + let firstIndex = rowPointers.[rowIndex] + let lastIndex = rowPointers.[rowIndex + 1] - 1 + + let value = + (%Search.Bin.inRange) firstIndex lastIndex columnIndex columns values + + match (%op) (Some operand.Value) value with + | Some resultValue -> + resultValues.[gid] <- resultValue + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = clContext.Compile <| preparePositions op + + fun (processor: MailboxProcessor<_>) (operand: ClCell<'a>) (matrix: CSR<'b>) (resultDenseMatrix: ClArray<'c>) (resultBitmap: ClArray) -> + + let resultLength = matrix.RowCount * matrix.ColumnCount + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + operand + matrix.RowCount + matrix.ColumnCount + matrix.Values + matrix.RowPointers + matrix.Columns + resultBitmap + resultDenseMatrix) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + let private setPositions<'c when 'c: struct> (clContext: ClContext) workGroupSize = + + let setPositions = + <@ fun (ndRange: Range1D) rowCount columnCount startIndex (rowOffset: ClCell) (columnOffset: ClCell) (bitmap: ClArray) (values: ClArray<'c>) (resultRows: ClArray) (resultColumns: ClArray) (resultValues: ClArray<'c>) -> + + let gid = ndRange.GlobalID0 + + if gid < rowCount * columnCount + && (gid = 0 && bitmap.[gid] = 1 + || gid > 0 && bitmap.[gid - 1] < bitmap.[gid]) then + + let columnIndex = gid % columnCount + let rowIndex = gid / columnCount + + let index = startIndex + bitmap.[gid] - 1 + + resultRows.[index] <- rowIndex + rowOffset.Value + resultColumns.[index] <- columnIndex + columnOffset.Value + resultValues.[index] <- values.[gid] @> + + let kernel = clContext.Compile <| setPositions + + let scan = + PrefixSum.standardIncludeInPlace clContext workGroupSize + + fun (processor: MailboxProcessor<_>) rowCount columnCount (rowOffset: int) (columnOffset: int) (startIndex: int) (resultMatrix: COO<'c>) (values: ClArray<'c>) (bitmap: ClArray) -> + + let sum = scan processor bitmap + + let ndRange = + Range1D.CreateValid(rowCount * columnCount, workGroupSize) + + let kernel = kernel.GetKernel() + + let rowOffset = rowOffset |> clContext.CreateClCell + let columnOffset = columnOffset |> clContext.CreateClCell + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + rowCount + columnCount + startIndex + rowOffset + columnOffset + bitmap + values + resultMatrix.Rows + resultMatrix.Columns + resultMatrix.Values) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + (sum.ToHostAndFree processor) + startIndex + + let private copyToResult (clContext: ClContext) workGroupSize = + + let copyToResult = + <@ fun (ndRange: Range1D) startIndex sourceLength (rowOffset: ClCell) (columnOffset: ClCell) (sourceRows: ClArray) (sourceColumns: ClArray) (sourceValues: ClArray<'c>) (resultRows: ClArray) (resultColumns: ClArray) (resultValues: ClArray<'c>) -> + + let gid = ndRange.GlobalID0 + + if gid < sourceLength then + let index = startIndex + gid + + resultRows.[index] <- rowOffset.Value + sourceRows.[gid] + resultColumns.[index] <- columnOffset.Value + sourceColumns.[gid] + resultValues.[index] <- sourceValues.[gid] @> + + let kernel = clContext.Compile <| copyToResult + + fun (processor: MailboxProcessor<_>) startIndex (rowOffset: int) (columnOffset: int) (resultMatrix: COO<'c>) (sourceMatrix: COO<'c>) -> + + let ndRange = + Range1D.CreateValid(sourceMatrix.NNZ, workGroupSize) + + let kernel = kernel.GetKernel() + + let rowOffset = rowOffset |> clContext.CreateClCell + let columnOffset = columnOffset |> clContext.CreateClCell + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + startIndex + sourceMatrix.NNZ + rowOffset + columnOffset + sourceMatrix.Rows + sourceMatrix.Columns + sourceMatrix.Values + resultMatrix.Rows + resultMatrix.Columns + resultMatrix.Values) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + let private insertZero (clContext: ClContext) workGroupSize = + + let copy = copyToResult clContext workGroupSize + + fun queue startIndex (zeroCounts: int list array) (matrixZero: COO<'c>) resultMatrix -> + + let rowCount = zeroCounts.Length + + let mutable startIndex = startIndex + + let insertMany row firstColumn count = + for i in 0 .. count - 1 do + let rowOffset = row * matrixZero.RowCount + + let columnOffset = + (firstColumn + i) * matrixZero.ColumnCount + + copy queue startIndex rowOffset columnOffset resultMatrix matrixZero + + startIndex <- startIndex + matrixZero.NNZ + + let rec insertInRowRec zeroCounts row column = + match zeroCounts with + | [] -> () + | h :: tl -> + insertMany row column h + + insertInRowRec tl row (h + column + 1) + + for row in 0 .. rowCount - 1 do + insertInRowRec zeroCounts.[row] row 0 + + let private insertNonZero (clContext: ClContext) workGroupSize op = + + let item = ClArray.item clContext workGroupSize + + let preparePositions = + preparePositions clContext workGroupSize op + + let setPositions = setPositions clContext workGroupSize + + fun queue (rowsEdges: (int * int) array) (matrixRight: CSR<'b>) (leftValues: ClArray<'a>) (leftColsHost: int array) (resultMatrix: COO<'c>) -> + + let setPositions = + setPositions queue matrixRight.RowCount matrixRight.ColumnCount + + let rowCount = rowsEdges.Length + + let length = + matrixRight.RowCount * matrixRight.ColumnCount + + let bitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, length) + + let mappedMatrix = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, length) + + let mutable startIndex = 0 + + for row in 0 .. rowCount - 1 do + let leftEdge, rightEdge = rowsEdges.[row] + + for i in leftEdge .. rightEdge do + let value = item queue i leftValues + let column = leftColsHost.[i] + + let rowOffset = row * matrixRight.RowCount + let columnOffset = column * matrixRight.ColumnCount + + preparePositions queue value matrixRight mappedMatrix bitmap + + value.Free queue + + startIndex <- setPositions rowOffset columnOffset startIndex resultMatrix mappedMatrix bitmap + + bitmap.Free queue + mappedMatrix.Free queue + + startIndex + + let private mapAll<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (clContext: ClContext) + workGroupSize + (op: Expr<'a option -> 'b option -> 'c option>) + = + + let insertNonZero = insertNonZero clContext workGroupSize op + + let insertZero = insertZero clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (resultNNZ: int) (matrixZero: COO<'c> option) (matrixLeft: CSR<'a>) (matrixRight: CSR<'b>) -> + + let resultRows = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultNNZ) + + let resultColumns = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultNNZ) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(allocationMode, resultNNZ) + + let resultMatrix = + { Context = clContext + Rows = resultRows + Columns = resultColumns + Values = resultValues + RowCount = matrixLeft.RowCount * matrixRight.RowCount + ColumnCount = matrixLeft.ColumnCount * matrixRight.ColumnCount } + + let leftRowPointers = matrixLeft.RowPointers.ToHost queue + let leftColumns = matrixLeft.Columns.ToHost queue + + let nnzInRows = + leftRowPointers + |> Array.pairwise + |> Array.map (fun (fst, snd) -> snd - fst) + + let rowsEdges = + leftRowPointers + |> Array.pairwise + |> Array.map (fun (fst, snd) -> (fst, snd - 1)) + + let (zeroCounts: int list array) = Array.zeroCreate matrixLeft.RowCount + + { 0 .. matrixLeft.RowCount - 1 } + |> Seq.iter2 + (fun edges i -> + zeroCounts.[i] <- + leftColumns.[fst edges..snd edges] + |> Array.toList + |> List.insertAt 0 -1 + |> List.insertAt (nnzInRows.[i] + 1) matrixLeft.ColumnCount + |> List.pairwise + |> List.map (fun (fstCol, sndCol) -> sndCol - fstCol - 1)) + rowsEdges + + let startIndex = + insertNonZero queue rowsEdges matrixRight matrixLeft.Values leftColumns resultMatrix + + matrixZero + |> Option.iter (fun m -> insertZero queue startIndex zeroCounts m resultMatrix) + + resultMatrix + + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (clContext: ClContext) + workGroupSize + (op: Expr<'a option -> 'b option -> 'c option>) + = + + let getSize = + getAllocationSize clContext workGroupSize op + + let mapWithValue = + Map.WithValue.run clContext op workGroupSize + + let mapAll = mapAll clContext workGroupSize op + + let bitonic = + Sort.Bitonic.sortKeyValuesInplace clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrixLeft: CSR<'a>) (matrixRight: CSR<'b>) -> + + let matrixZero = + mapWithValue queue allocationMode None matrixRight + + let size = + getSize queue matrixZero matrixLeft matrixRight + + if size = 0 then + matrixZero + |> Option.iter (fun m -> m.Dispose queue) + + None + else + let result = + mapAll queue allocationMode size matrixZero matrixLeft matrixRight + + matrixZero + |> Option.iter (fun m -> m.Dispose queue) + + bitonic queue result.Rows result.Columns result.Values + + result |> Some diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSR/Map.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Map.fs new file mode 100644 index 00000000..a6c2b077 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Map.fs @@ -0,0 +1,224 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.CSR + +open Brahma.FSharp +open FSharp.Quotations +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClCell +open GraphBLAS.FSharp.Backend.Objects.ClMatrix +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +module internal Map = + let preparePositions<'a, 'b> op (clContext: ClContext) workGroupSize = + + let preparePositions (op: Expr<'a option -> 'b option>) = + <@ fun (ndRange: Range1D) rowCount columnCount (values: ClArray<'a>) (rowPointers: ClArray) (columns: ClArray) (resultBitmap: ClArray) (resultValues: ClArray<'b>) (resultRows: ClArray) (resultColumns: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < rowCount * columnCount then + + let columnIndex = gid % columnCount + let rowIndex = gid / columnCount + + let startIndex = rowPointers.[rowIndex] + let lastIndex = rowPointers.[rowIndex + 1] - 1 + + let value = + (%Search.Bin.inRange) startIndex lastIndex columnIndex columns values + + match (%op) value with + | Some resultValue -> + resultValues.[gid] <- resultValue + resultRows.[gid] <- rowIndex + resultColumns.[gid] <- columnIndex + + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = clContext.Compile <| preparePositions op + + fun (processor: MailboxProcessor<_>) rowCount columnCount (values: ClArray<'a>) (rowPointers: ClArray) (columns: ClArray) -> + + let (resultLength: int) = columnCount * rowCount + + let resultBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultRows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultColumns = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'b>(DeviceOnly, resultLength) + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + rowCount + columnCount + values + rowPointers + columns + resultBitmap + resultValues + resultRows + resultColumns) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + resultBitmap, resultValues, resultRows, resultColumns + + let run<'a, 'b when 'a: struct and 'b: struct and 'b: equality> + (opAdd: Expr<'a option -> 'b option>) + (clContext: ClContext) + workGroupSize + = + + let map = + preparePositions opAdd clContext workGroupSize + + let setPositions = + Common.setPositions<'b> clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + + let bitmap, values, rows, columns = + map queue matrix.RowCount matrix.ColumnCount matrix.Values matrix.RowPointers matrix.Columns + + let resultRows, resultColumns, resultValues, _ = + setPositions queue allocationMode rows columns values bitmap + + bitmap.Free queue + values.Free queue + rows.Free queue + columns.Free queue + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = resultRows + Columns = resultColumns + Values = resultValues } + + module WithValue = + let preparePositions<'a, 'b, 'c when 'b: struct> (clContext: ClContext) workGroupSize op = + + let preparePositions (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun (ndRange: Range1D) (operand: ClCell<'a option>) rowCount columnCount (values: ClArray<'b>) (rowPointers: ClArray) (columns: ClArray) (resultBitmap: ClArray) (resultValues: ClArray<'c>) (resultRows: ClArray) (resultColumns: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < rowCount * columnCount then + + let columnIndex = gid % columnCount + let rowIndex = gid / columnCount + + let startIndex = rowPointers.[rowIndex] + let lastIndex = rowPointers.[rowIndex + 1] - 1 + + let value = + (%Search.Bin.inRange) startIndex lastIndex columnIndex columns values + + match (%op) operand.Value value with + | Some resultValue -> + resultValues.[gid] <- resultValue + resultRows.[gid] <- rowIndex + resultColumns.[gid] <- columnIndex + + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = clContext.Compile <| preparePositions op + + fun (processor: MailboxProcessor<_>) (operand: ClCell<'a option>) (matrix: ClMatrix.CSR<'b>) -> + + let resultLength = matrix.RowCount * matrix.ColumnCount + + let resultBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultRows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultColumns = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, resultLength) + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + operand + matrix.RowCount + matrix.ColumnCount + matrix.Values + matrix.RowPointers + matrix.Columns + resultBitmap + resultValues + resultRows + resultColumns) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + resultBitmap, resultValues, resultRows, resultColumns + + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (clContext: ClContext) + (op: Expr<'a option -> 'b option -> 'c option>) + workGroupSize + = + + let mapWithValue = + preparePositions clContext workGroupSize op + + let setPositions = + Common.setPositionsOption<'c> clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (value: 'a option) (matrix: ClMatrix.CSR<'b>) -> + let valueClCell = clContext.CreateClCell value + + let bitmap, values, rows, columns = mapWithValue queue valueClCell matrix + + valueClCell.Free queue + + let result = + setPositions queue allocationMode rows columns values bitmap + + bitmap.Free queue + values.Free queue + rows.Free queue + columns.Free queue + + result + |> Option.map + (fun (resRows, resCols, resValues, _) -> + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = resRows + Columns = resCols + Values = resValues }) diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSR/Map2.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Map2.fs new file mode 100644 index 00000000..bfd5f161 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Map2.fs @@ -0,0 +1,243 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.CSR + +open Brahma.FSharp +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClMatrix +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Matrix.COO + +module internal Map2 = + let preparePositions<'a, 'b, 'c> opAdd (clContext: ClContext) workGroupSize = + + let preparePositions (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun (ndRange: Range1D) rowCount columnCount (leftValues: ClArray<'a>) (leftRowPointers: ClArray) (leftColumns: ClArray) (rightValues: ClArray<'b>) (rightRowPointers: ClArray) (rightColumn: ClArray) (resultBitmap: ClArray) (resultValues: ClArray<'c>) (resultRows: ClArray) (resultColumns: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < rowCount * columnCount then + + let columnIndex = gid % columnCount + let rowIndex = gid / columnCount + + let leftStartIndex = leftRowPointers.[rowIndex] + let leftLastIndex = leftRowPointers.[rowIndex + 1] - 1 + + let rightStartIndex = rightRowPointers.[rowIndex] + let rightLastIndex = rightRowPointers.[rowIndex + 1] - 1 + + let leftValue = + (%Search.Bin.inRange) leftStartIndex leftLastIndex columnIndex leftColumns leftValues + + let rightValue = + (%Search.Bin.inRange) rightStartIndex rightLastIndex columnIndex rightColumn rightValues + + match (%op) leftValue rightValue with + | Some value -> + resultValues.[gid] <- value + resultRows.[gid] <- rowIndex + resultColumns.[gid] <- columnIndex + + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = + clContext.Compile <| preparePositions opAdd + + fun (processor: MailboxProcessor<_>) rowCount columnCount (leftValues: ClArray<'a>) (leftRows: ClArray) (leftColumns: ClArray) (rightValues: ClArray<'b>) (rightRows: ClArray) (rightColumns: ClArray) -> + + let (resultLength: int) = columnCount * rowCount + + let resultBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultRows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultColumns = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, resultLength) + + let ndRange = + Range1D.CreateValid(resultLength, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + rowCount + columnCount + leftValues + leftRows + leftColumns + rightValues + rightRows + rightColumns + resultBitmap + resultValues + resultRows + resultColumns) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + resultBitmap, resultValues, resultRows, resultColumns + + ///. + ///. + ///Should be a power of 2 and greater than 1. + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (opAdd: Expr<'a option -> 'b option -> 'c option>) + (clContext: ClContext) + workGroupSize + = + + let map2 = + preparePositions opAdd clContext workGroupSize + + let setPositions = + Common.setPositions<'c> clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrixLeft: ClMatrix.CSR<'a>) (matrixRight: ClMatrix.CSR<'b>) -> + + let bitmap, values, rows, columns = + map2 + queue + matrixLeft.RowCount + matrixLeft.ColumnCount + matrixLeft.Values + matrixLeft.RowPointers + matrixLeft.Columns + matrixRight.Values + matrixRight.RowPointers + matrixRight.Columns + + let resultRows, resultColumns, resultValues, _ = + setPositions queue allocationMode rows columns values bitmap + + queue.Post(Msg.CreateFreeMsg<_>(bitmap)) + queue.Post(Msg.CreateFreeMsg<_>(values)) + queue.Post(Msg.CreateFreeMsg<_>(rows)) + queue.Post(Msg.CreateFreeMsg<_>(columns)) + + { Context = clContext + RowCount = matrixLeft.RowCount + ColumnCount = matrixLeft.ColumnCount + Rows = resultRows + Columns = resultColumns + Values = resultValues } + + module AtLeastOne = + let preparePositions<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (opAdd: Expr<'a option -> 'b option -> 'c option>) + (clContext: ClContext) + workGroupSize + = + + let preparePositions = + <@ fun (ndRange: Range1D) length (allColumns: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (allValues: ClArray<'c>) (rawPositions: ClArray) (isEndOfRowBitmap: ClArray) (isLeftBitmap: ClArray) -> + + let i = ndRange.GlobalID0 + + if (i < length - 1 + && allColumns.[i] = allColumns.[i + 1] + && isEndOfRowBitmap.[i] = 0) then + + let result = + (%opAdd) (Some leftValues.[i + 1]) (Some rightValues.[i]) + + (%PreparePositions.both) i result rawPositions allValues + elif i = 0 + || (i < length + && (allColumns.[i] <> allColumns.[i - 1] + || isEndOfRowBitmap.[i - 1] = 1)) then + + let leftResult = (%opAdd) (Some leftValues.[i]) None + let rightResult = (%opAdd) None (Some rightValues.[i]) + + (%PreparePositions.leftRight) i leftResult rightResult isLeftBitmap allValues rawPositions @> + + let kernel = clContext.Compile(preparePositions) + + fun (processor: MailboxProcessor<_>) (allColumns: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isEndOfRow: ClArray) (isLeft: ClArray) -> + let length = leftValues.Length + + let ndRange = + Range1D.CreateValid(length, workGroupSize) + + let rowPositions = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, length) + + let allValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, length) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + length + allColumns + leftValues + rightValues + allValues + rowPositions + isEndOfRow + isLeft) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + rowPositions, allValues + + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (opAdd: Expr<'a option -> 'b option -> 'c option>) + (clContext: ClContext) + workGroupSize + = + + let merge = + GraphBLAS.FSharp.Backend.Matrix.CSR.Merge.run clContext workGroupSize + + let preparePositions = + preparePositions opAdd clContext workGroupSize + + let setPositions = + Common.setPositions<'c> clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrixLeft: ClMatrix.CSR<'a>) (matrixRight: ClMatrix.CSR<'b>) -> + + let allRows, allColumns, leftMergedValues, rightMergedValues, isRowEnd, isLeft = + merge queue matrixLeft matrixRight + + let positions, allValues = + preparePositions queue allColumns leftMergedValues rightMergedValues isRowEnd isLeft + + queue.Post(Msg.CreateFreeMsg<_>(leftMergedValues)) + queue.Post(Msg.CreateFreeMsg<_>(rightMergedValues)) + + let resultRows, resultColumns, resultValues, _ = + setPositions queue allocationMode allRows allColumns allValues positions + + queue.Post(Msg.CreateFreeMsg<_>(allRows)) + queue.Post(Msg.CreateFreeMsg<_>(isLeft)) + queue.Post(Msg.CreateFreeMsg<_>(isRowEnd)) + queue.Post(Msg.CreateFreeMsg<_>(positions)) + queue.Post(Msg.CreateFreeMsg<_>(allColumns)) + queue.Post(Msg.CreateFreeMsg<_>(allValues)) + + { Context = clContext + RowCount = matrixLeft.RowCount + ColumnCount = matrixLeft.ColumnCount + Rows = resultRows + Columns = resultColumns + Values = resultValues } diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSR/Matrix.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Matrix.fs new file mode 100644 index 00000000..22171912 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Matrix.fs @@ -0,0 +1,338 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.CSR + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Quotes +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClMatrix +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ClVector +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + + +module Matrix = + let expandRowPointers (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) columnsLength pointersLength (pointers: ClArray) (results: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < columnsLength then + let result = + (%Search.Bin.lowerBound) pointersLength gid pointers + + results.[gid] <- result - 1 @> + + let program = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + + let rows = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, matrix.Columns.Length) + + let kernel = program.GetKernel() + + let ndRange = + Range1D.CreateValid(matrix.Columns.Length, workGroupSize) + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + matrix.Columns.Length + matrix.RowPointers.Length + matrix.RowPointers + rows) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + rows + + let item<'a when 'a: struct> (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) row column (rowPointers: ClArray) (columns: ClArray) (values: ClArray<'a>) (result: ClCell<'a option>) -> + + let gid = ndRange.GlobalID0 + + if gid = 0 then + let firstIndex = rowPointers.[row] + let lastIndex = rowPointers.[row + 1] - 1 + + result.Value <- (%Search.Bin.inRange) firstIndex lastIndex column columns values @> + + let program = clContext.Compile kernel + + fun (processor: MailboxProcessor<_>) (row: int) (column: int) (matrix: ClMatrix.CSR<'a>) -> + + if row < 0 || row >= matrix.RowCount then + failwith "Row out of range" + + if column < 0 || column >= matrix.ColumnCount then + failwith "Column out of range" + + let result = clContext.CreateClCell None + + let kernel = program.GetKernel() + + let ndRange = Range1D.CreateValid(1, workGroupSize) + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc ndRange row column matrix.RowPointers matrix.Columns matrix.Values result) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + result + + let subRows (clContext: ClContext) workGroupSize = + + let kernel = + <@ fun (ndRange: Range1D) resultLength sourceRow pointersLength (pointers: ClArray) (results: ClArray) -> + + let gid = ndRange.GlobalID0 + + let shift = pointers.[sourceRow] + let shiftedId = gid + shift + + if gid < resultLength then + let result = + (%Search.Bin.lowerBound) pointersLength shiftedId pointers + + results.[gid] <- result - 1 @> + + let program = clContext.Compile kernel + + let blit = ClArray.blit clContext workGroupSize + + let blitData = ClArray.blit clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode startIndex count (matrix: ClMatrix.CSR<'a>) -> + if count <= 0 then + failwith "Count must be greater than zero" + + if startIndex < 0 then + failwith "startIndex must be greater then zero" + + if startIndex + count > matrix.RowCount then + failwith "startIndex and count sum is larger than the matrix row count" + + // extract rows + let rowPointers = matrix.RowPointers.ToHost processor + + let resultLength = + rowPointers.[startIndex + count] + - rowPointers.[startIndex] + + let rows = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let kernel = program.GetKernel() + + let ndRange = + Range1D.CreateValid(matrix.Columns.Length, workGroupSize) + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + resultLength + startIndex + matrix.RowPointers.Length + matrix.RowPointers + rows) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + let startPosition = rowPointers.[startIndex] + + // extract values + let values = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + blitData processor matrix.Values startPosition values 0 resultLength + + // extract indices + let columns = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + blit processor matrix.Columns startPosition columns 0 resultLength + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = rows + Columns = columns + Values = values } + + let toCOO (clContext: ClContext) workGroupSize = + let prepare = + expandRowPointers clContext workGroupSize + + let copy = ClArray.copy clContext workGroupSize + + let copyData = ClArray.copy clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + let rows = prepare processor allocationMode matrix + + let cols = + copy processor allocationMode matrix.Columns + + let values = + copyData processor allocationMode matrix.Values + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = rows + Columns = cols + Values = values } + + let toCOOInPlace (clContext: ClContext) workGroupSize = + let prepare = + expandRowPointers clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + let rows = prepare processor allocationMode matrix + + processor.Post(Msg.CreateFreeMsg(matrix.RowPointers)) + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = rows + Columns = matrix.Columns + Values = matrix.Values } + + let map = CSR.Map.run + + let map2 = Map2.run + + let map2AtLeastOne<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> + (clContext: ClContext) + (opAdd: Expr -> 'c option>) + workGroupSize + = + + Map2.AtLeastOne.run (Convert.atLeastOneToOption opAdd) clContext workGroupSize + + let transposeInPlace (clContext: ClContext) workGroupSize = + + let toCOOInPlace = toCOOInPlace clContext workGroupSize + + let transposeInPlace = + COO.Matrix.transposeInPlace clContext workGroupSize + + let toCSRInPlace = + COO.Matrix.toCSRInPlace clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + toCOOInPlace queue allocationMode matrix + |> transposeInPlace queue + |> toCSRInPlace queue allocationMode + + let transpose (clContext: ClContext) workGroupSize = + + let toCOO = toCOO clContext workGroupSize + + let transposeInPlace = + COO.Matrix.transposeInPlace clContext workGroupSize + + let toCSRInPlace = + COO.Matrix.toCSRInPlace clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + toCOO queue allocationMode matrix + |> transposeInPlace queue + |> toCSRInPlace queue allocationMode + + let byRowsLazy (clContext: ClContext) workGroupSize = + + let getChunkValues = ClArray.sub clContext workGroupSize + + let getChunkIndices = ClArray.sub clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + + let getChunkValues = + getChunkValues processor allocationMode matrix.Values + + let getChunkIndices = + getChunkIndices processor allocationMode matrix.Columns + + let creatSparseVector values columns = + { Context = clContext + Indices = columns + Values = values + Size = matrix.ColumnCount } + + matrix.RowPointers.ToHost processor + |> Seq.pairwise + |> Seq.map + (fun (first, second) -> + lazy + (let count = second - first + + if count > 0 then + let values = getChunkValues first count + let columns = getChunkIndices first count + + Some <| creatSparseVector values columns + else + None)) + + let byRows (clContext: ClContext) workGroupSize = + + let runLazy = byRowsLazy clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + runLazy processor allocationMode matrix + |> Seq.map (fun lazyValue -> lazyValue.Value) + + let toLIL (clContext: ClContext) workGroupSize = + + let byRows = byRows clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> + let rows = + byRows processor allocationMode matrix + |> Seq.toList + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = rows + NNZ = matrix.NNZ } + + let NNZInRows (clContext: ClContext) workGroupSize = + + let pairwise = ClArray.pairwise clContext workGroupSize + + let subtract = + ClArray.map <@ fun (fst, snd) -> snd - fst @> clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'b>) -> + let pointerPairs = + pairwise processor DeviceOnly matrix.RowPointers + // since row pointers length in matrix always >= 2 + |> Option.defaultWith + (fun () -> failwith "The state of the matrix is broken. The length of the rowPointers must be >= 2") + + let rowsLength = + subtract processor allocationMode pointerPairs + + pointerPairs.Free processor + + rowsLength + + let kronecker = Kronecker.run diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/Map2.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Merge.fs similarity index 70% rename from src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/Map2.fs rename to src/GraphBLAS-sharp.Backend/Matrix/CSR/Merge.fs index 63de131c..cf98d531 100644 --- a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/Map2.fs +++ b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Merge.fs @@ -1,76 +1,13 @@ namespace GraphBLAS.FSharp.Backend.Matrix.CSR -open System open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Quotes -open Microsoft.FSharp.Quotations -open GraphBLAS.FSharp.Backend.Objects.ClContext - -module internal Map2 = - let preparePositions<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> - (clContext: ClContext) - (opAdd: Expr<'a option -> 'b option -> 'c option>) - workGroupSize - = - - let preparePositions = - <@ fun (ndRange: Range1D) length (allColumns: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (allValues: ClArray<'c>) (rawPositions: ClArray) (isEndOfRowBitmap: ClArray) (isLeftBitmap: ClArray) -> - - let i = ndRange.GlobalID0 - - if (i < length - 1 - && allColumns.[i] = allColumns.[i + 1] - && isEndOfRowBitmap.[i] = 0) then - - let result = - (%opAdd) (Some leftValues.[i + 1]) (Some rightValues.[i]) - - (%PreparePositions.both) i result rawPositions allValues - elif i = 0 - || (i < length - && (allColumns.[i] <> allColumns.[i - 1] - || isEndOfRowBitmap.[i - 1] = 1)) then - - let leftResult = (%opAdd) (Some leftValues.[i]) None - let rightResult = (%opAdd) None (Some rightValues.[i]) - - (%PreparePositions.leftRight) i leftResult rightResult isLeftBitmap allValues rawPositions @> - - let kernel = clContext.Compile(preparePositions) - - fun (processor: MailboxProcessor<_>) (allColumns: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isEndOfRow: ClArray) (isLeft: ClArray) -> - let length = leftValues.Length - - let ndRange = - Range1D.CreateValid(length, workGroupSize) - - let rowPositions = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, length) - - let allValues = - clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, length) - - let kernel = kernel.GetKernel() - - processor.Post( - Msg.MsgSetArguments - (fun () -> - kernel.KernelFunc - ndRange - length - allColumns - leftValues - rightValues - allValues - rowPositions - isEndOfRow - isLeft) - ) +open System +open GraphBLAS.FSharp.Backend.Objects - processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - rowPositions, allValues +open GraphBLAS.FSharp.Backend.Objects.ClContext - let merge<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) workGroupSize = +module Merge = + let run<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) workGroupSize = let localArraySize = workGroupSize + 2 let merge = @@ -225,10 +162,10 @@ module internal Map2 = let kernel = clContext.Compile(merge) - fun (processor: MailboxProcessor<_>) (matrixLeftRowPointers: ClArray) (matrixLeftColumns: ClArray) (matrixLeftValues: ClArray<'a>) (matrixRightRowPointers: ClArray) (matrixRightColumns: ClArray) (matrixRightValues: ClArray<'b>) -> + fun (processor: MailboxProcessor<_>) (leftMatrix: ClMatrix.CSR<'a>) (rightMatrix: ClMatrix.CSR<'b>) -> - let firstLength = matrixLeftValues.Length - let secondLength = matrixRightValues.Length + let firstLength = leftMatrix.Columns.Length + let secondLength = rightMatrix.Columns.Length let resLength = firstLength + secondLength let allRows = @@ -250,7 +187,11 @@ module internal Map2 = clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resLength) let ndRange = - Range1D.CreateValid((matrixLeftRowPointers.Length - 1) * workGroupSize, workGroupSize) + Range1D.CreateValid( + (leftMatrix.RowPointers.Length - 1) + * workGroupSize, + workGroupSize + ) let kernel = kernel.GetKernel() @@ -259,12 +200,12 @@ module internal Map2 = (fun () -> kernel.KernelFunc ndRange - matrixLeftRowPointers - matrixLeftColumns - matrixLeftValues - matrixRightRowPointers - matrixRightColumns - matrixRightValues + leftMatrix.RowPointers + leftMatrix.Columns + leftMatrix.Values + rightMatrix.RowPointers + rightMatrix.Columns + rightMatrix.Values allRows allColumns leftMergedValues diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/CSRMatrix.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/CSRMatrix.fs deleted file mode 100644 index 21882051..00000000 --- a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/CSRMatrix.fs +++ /dev/null @@ -1,257 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.Matrix.CSR - -open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend -open GraphBLAS.FSharp.Backend.Matrix.CSR.Map2 -open GraphBLAS.FSharp.Backend.Quotes -open Microsoft.FSharp.Quotations -open GraphBLAS.FSharp.Backend.Matrix.COO -open GraphBLAS.FSharp.Backend.Objects -open GraphBLAS.FSharp.Backend.Objects.ClMatrix - -module CSRMatrix = - let private expandRowPointers (clContext: ClContext) workGroupSize = - - let expandRowPointers = - <@ fun (ndRange: Range1D) (rowPointers: ClArray) (rowCount: int) (rows: ClArray) -> - - let i = ndRange.GlobalID0 - - if i < rowCount then - let rowPointer = rowPointers.[i] - - if rowPointer <> rowPointers.[i + 1] then - rows.[rowPointer] <- i @> - - let program = clContext.Compile(expandRowPointers) - - let create = ClArray.create clContext workGroupSize - - let scan = - ClArray.prefixSumIncludeInplace <@ max @> clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (rowPointers: ClArray) nnz rowCount -> - - let rows = create processor allocationMode nnz 0 - - let kernel = program.GetKernel() - - let ndRange = - Range1D.CreateValid(rowCount, workGroupSize) - - processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange rowPointers rowCount rows)) - processor.Post(Msg.CreateRunMsg<_, _> kernel) - - let total = scan processor rows 0 - processor.Post(Msg.CreateFreeMsg(total)) - - rows - - let toCOO (clContext: ClContext) workGroupSize = - let prepare = - expandRowPointers clContext workGroupSize - - let copy = ClArray.copy clContext workGroupSize - - let copyData = ClArray.copy clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> - let rows = - prepare processor allocationMode matrix.RowPointers matrix.Columns.Length matrix.RowCount - - let cols = - copy processor allocationMode matrix.Columns - - let vals = - copyData processor allocationMode matrix.Values - - { Context = clContext - RowCount = matrix.RowCount - ColumnCount = matrix.ColumnCount - Rows = rows - Columns = cols - Values = vals } - - let toCOOInplace (clContext: ClContext) workGroupSize = - let prepare = - expandRowPointers clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> - let rows = - prepare processor allocationMode matrix.RowPointers matrix.Columns.Length matrix.RowCount - - processor.Post(Msg.CreateFreeMsg(matrix.RowPointers)) - - { Context = clContext - RowCount = matrix.RowCount - ColumnCount = matrix.ColumnCount - Rows = rows - Columns = matrix.Columns - Values = matrix.Values } - - ///Old version - let map2WithCOO (clContext: ClContext) (opAdd: Expr<'a option -> 'b option -> 'c option>) workGroupSize = - - let prepareRows = - expandRowPointers clContext workGroupSize - - let eWiseCOO = - COOMatrix.map2 clContext opAdd workGroupSize - - let toCSRInplace = - COOMatrix.toCSRInplace clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (m1: ClMatrix.CSR<'a>) (m2: ClMatrix.CSR<'b>) -> - let m1COO = - { Context = clContext - RowCount = m1.RowCount - ColumnCount = m1.ColumnCount - Rows = prepareRows processor allocationMode m1.RowPointers m1.Values.Length m1.RowCount - Columns = m1.Columns - Values = m1.Values } - - let m2COO = - { Context = clContext - RowCount = m2.RowCount - ColumnCount = m2.ColumnCount - Rows = prepareRows processor allocationMode m2.RowPointers m2.Values.Length m2.RowCount - Columns = m2.Columns - Values = m2.Values } - - let m3COO = - eWiseCOO processor allocationMode m1COO m2COO - - processor.Post(Msg.CreateFreeMsg(m1COO.Rows)) - processor.Post(Msg.CreateFreeMsg(m2COO.Rows)) - - toCSRInplace processor allocationMode m3COO - - ///Old version - let map2AtLeastOneWithCOO (clContext: ClContext) (opAdd: Expr -> 'c option>) workGroupSize = - - map2WithCOO clContext (Convert.atLeastOneToOption opAdd) workGroupSize - - let transposeInplace (clContext: ClContext) workGroupSize = - - let toCOOInplace = toCOOInplace clContext workGroupSize - - let transposeInplace = - COOMatrix.transposeInplace clContext workGroupSize - - let toCSRInplace = - COOMatrix.toCSRInplace clContext workGroupSize - - fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> - toCOOInplace queue allocationMode matrix - |> transposeInplace queue - |> toCSRInplace queue allocationMode - - let transpose (clContext: ClContext) workGroupSize = - - let toCOO = toCOO clContext workGroupSize - - let transposeInplace = - COOMatrix.transposeInplace clContext workGroupSize - - let toCSRInplace = - COOMatrix.toCSRInplace clContext workGroupSize - - fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) -> - toCOO queue allocationMode matrix - |> transposeInplace queue - |> toCSRInplace queue allocationMode - - let map2ToCOO<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> - (clContext: ClContext) - (opAdd: Expr<'a option -> 'b option -> 'c option>) - workGroupSize - = - - let merge = merge clContext workGroupSize - - let preparePositions = - preparePositions clContext opAdd workGroupSize - - let setPositions = - Matrix.Common.setPositions<'c> clContext workGroupSize - - fun (queue: MailboxProcessor<_>) allocationMode (matrixLeft: ClMatrix.CSR<'a>) (matrixRight: ClMatrix.CSR<'b>) -> - - let allRows, allColumns, leftMergedValues, rightMergedValues, isRowEnd, isLeft = - merge - queue - matrixLeft.RowPointers - matrixLeft.Columns - matrixLeft.Values - matrixRight.RowPointers - matrixRight.Columns - matrixRight.Values - - let positions, allValues = - preparePositions queue allColumns leftMergedValues rightMergedValues isRowEnd isLeft - - queue.Post(Msg.CreateFreeMsg<_>(leftMergedValues)) - queue.Post(Msg.CreateFreeMsg<_>(rightMergedValues)) - - let resultRows, resultColumns, resultValues, _ = - setPositions queue allocationMode allRows allColumns allValues positions - - queue.Post(Msg.CreateFreeMsg<_>(allRows)) - queue.Post(Msg.CreateFreeMsg<_>(isLeft)) - queue.Post(Msg.CreateFreeMsg<_>(isRowEnd)) - queue.Post(Msg.CreateFreeMsg<_>(positions)) - queue.Post(Msg.CreateFreeMsg<_>(allColumns)) - queue.Post(Msg.CreateFreeMsg<_>(allValues)) - - { Context = clContext - RowCount = matrixLeft.RowCount - ColumnCount = matrixLeft.ColumnCount - Rows = resultRows - Columns = resultColumns - Values = resultValues } - - let map2<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> - (clContext: ClContext) - (opAdd: Expr<'a option -> 'b option -> 'c option>) - workGroupSize - = - - let elementwiseToCOO = map2ToCOO clContext opAdd workGroupSize - - let toCSRInplace = - COOMatrix.toCSRInplace clContext workGroupSize - - fun (queue: MailboxProcessor<_>) allocationMode (matrixLeft: ClMatrix.CSR<'a>) (matrixRight: ClMatrix.CSR<'b>) -> - elementwiseToCOO queue allocationMode matrixLeft matrixRight - |> toCSRInplace queue allocationMode - - let map2AtLeastOneToCOO<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> - (clContext: ClContext) - (opAdd: Expr -> 'c option>) - workGroupSize - = - - map2ToCOO clContext (Convert.atLeastOneToOption opAdd) workGroupSize - - let map2AtLeastOne<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct and 'c: equality> - (clContext: ClContext) - (opAdd: Expr -> 'c option>) - workGroupSize - = - - map2 clContext (Convert.atLeastOneToOption opAdd) workGroupSize - - let spgemmCSC - (clContext: ClContext) - workGroupSize - (opAdd: Expr<'c -> 'c -> 'c option>) - (opMul: Expr<'a -> 'b -> 'c option>) - = - - let run = - SpGEMM.run clContext workGroupSize opAdd opMul - - fun (queue: MailboxProcessor<_>) (matrixLeft: ClMatrix.CSR<'a>) (matrixRight: ClMatrix.CSC<'b>) (mask: ClMatrix.COO<_>) -> - - run queue matrixLeft matrixRight mask diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/GetTuples.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/GetTuples.fs deleted file mode 100644 index 573badec..00000000 --- a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/GetTuples.fs +++ /dev/null @@ -1,46 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.CSRMatrix - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Backend.Common - -module internal GetTuples = - let fromMatrix (matrix: CSRMatrix<'a>) = - opencl { - if matrix.Values.Length = 0 then - return - { RowIndices = [||] - ColumnIndices = [||] - Values = [||] } - - else - let rowCount = matrix.RowCount - - let expandCsrRows = - <@ fun (ndRange: Range1D) (rowPointers: int []) (outputRowIndices: int []) -> - - let gid = ndRange.GlobalID0 - - if gid < rowCount then - for idx = rowPointers.[gid] to rowPointers.[gid + 1] - 1 do - outputRowIndices.[idx] <- gid @> - - let rowIndices = - Array.zeroCreate matrix.Values.Length - - do! - runCommand expandCsrRows - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(rowCount |> Utils.getDefaultGlobalSize, Utils.defaultWorkGroupSize) - <| matrix.RowPointers - <| rowIndices - - let! colIndices = Copy.copyArray matrix.ColumnIndices - let! vals = Copy.copyArray matrix.Values - - return - { RowIndices = rowIndices - ColumnIndices = colIndices - Values = vals } - } diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/SpMSpV.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/SpMSpV.fs deleted file mode 100644 index 419e3ace..00000000 --- a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/SpMSpV.fs +++ /dev/null @@ -1,321 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.CSRMatrix - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Backend.Common - -module internal rec SpMSpV = - let unmasked (matrix: CSRMatrix<'a>) (vector: COOVector<'a>) (semiring: ISemiring<'a>) = - opencl { - if matrix.Values.Length = 0 - || vector.Values.Length = 0 then - return - { Size = matrix.RowCount - Indices = [||] - Values = [||] } - - else - let rowCount = matrix.RowCount - let vectorNnz = vector.Values.Length - let wgSize = Utils.defaultWorkGroupSize - - let (ClosedBinaryOp plus) = semiring.Plus - let (ClosedBinaryOp times) = semiring.Times - let zero = semiring.Zero - - let calcValuesPerRow = - <@ fun (range: Range1D) (matrixRowPointers: int []) (matrixColumnIndices: int []) (matrixValues: 'a []) (vectorIndices: int []) (vectorValues: 'a []) (countOfProductsPerRow: int []) (valuesPerRow: 'a []) -> - - let gid = range.GlobalID0 - let lid = range.LocalID0 - let groupId = gid / wgSize // rowId - - let localCountAccum = localArray wgSize - localCountAccum.[lid] <- 0 - - let localValuesAccum = localArray<'a> wgSize - localValuesAccum.[lid] <- zero - - barrier () - - let mutable i = matrixRowPointers.[groupId] + lid - let _end = matrixRowPointers.[groupId + 1] - - while i < _end do - let col = matrixColumnIndices.[i] - let value = matrixValues.[i] - - let mutable l = 0 - let mutable r = vectorNnz - let mutable m = l + ((r - l) / 2) - let mutable idx = -1 - let mutable _break = false - - while l < r && not _break do - if vectorIndices.[m] = col then - idx <- m - _break <- true - elif vectorIndices.[m] < col then - l <- m + 1 - else - r <- m - - m <- l + ((r - l) / 2) - - if idx <> -1 then - let vectorValue = vectorValues.[idx] - localCountAccum.[lid] <- localCountAccum.[lid] + 1 - localValuesAccum.[lid] <- (%plus) localValuesAccum.[lid] ((%times) value vectorValue) - - i <- i + wgSize - - barrier () - - if lid = 0 then - let mutable countAcc = 0 - let mutable valueAcc = zero - - for i = 0 to wgSize - 1 do - countAcc <- countAcc + localCountAccum.[i] - valueAcc <- (%plus) valueAcc localValuesAccum.[i] - - countOfProductsPerRow.[groupId] <- countAcc - valuesPerRow.[groupId] <- valueAcc @> - - let countOfProductsPerRow = Array.zeroCreate rowCount - let valuesPerRow = Array.zeroCreate<'a> rowCount - - do! - runCommand calcValuesPerRow - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(rowCount * Utils.defaultWorkGroupSize, Utils.defaultWorkGroupSize) - <| matrix.RowPointers - <| matrix.ColumnIndices - <| matrix.Values - <| vector.Indices - <| vector.Values - <| countOfProductsPerRow - <| valuesPerRow - - let getNonzeroBitmap = - <@ fun (range: Range1D) (count: int []) (bitmap: int []) -> - - let gid = range.GlobalID0 - - if gid < rowCount && count.[gid] = 0 then - bitmap.[gid] <- 0 @> - - let bitmap = Array.create rowCount 1 - - do! - runCommand getNonzeroBitmap - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize rowCount, Utils.defaultWorkGroupSize) - <| countOfProductsPerRow - <| bitmap - - let! (positions, totalSum) = PrefixSum.runExclude bitmap - failwith "FIX ME! And rewrite." - //let! _ = ToHost totalSum - let resultLength = totalSum.[0] - - if resultLength = 0 then - return - { Size = matrix.RowCount - Indices = [||] - Values = [||] } - - else - let getOutputVector = - <@ fun (range: Range1D) (count: int []) (values: 'a []) (positions: int []) (outputValues: 'a []) (outputIndices: int []) -> - - let gid = range.GlobalID0 - - if gid < rowCount && count.[gid] <> 0 then - outputValues.[positions.[gid]] <- values.[gid] - outputIndices.[positions.[gid]] <- gid @> - - let outputValues = Array.zeroCreate<'a> resultLength - let outputIndices = Array.zeroCreate resultLength - - do! - runCommand getOutputVector - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize rowCount, Utils.defaultWorkGroupSize) - <| countOfProductsPerRow - <| valuesPerRow - <| positions - <| outputValues - <| outputIndices - - return - { Size = rowCount - Indices = outputIndices - Values = outputValues } - } - - let masked (matrix: CSRMatrix<'a>) (vector: COOVector<'a>) (semiring: ISemiring<'a>) (mask: Mask1D) = - opencl { - if matrix.Values.Length = 0 - || vector.Values.Length = 0 then - return - { Size = matrix.RowCount - Indices = [||] - Values = [||] } - - elif mask.Indices.Length = 0 && not mask.IsComplemented - || mask.Indices.Length = mask.Size - && mask.IsComplemented then - return - { Size = matrix.RowCount - Indices = [||] - Values = [||] } - - else - let rowCount = matrix.RowCount - let vectorNnz = vector.Values.Length - let wgSize = Utils.defaultWorkGroupSize - let maskNnz = mask.Indices.Length - - let (ClosedBinaryOp plus) = semiring.Plus - let (ClosedBinaryOp times) = semiring.Times - let zero = semiring.Zero - - let calcValuesPerRow = - <@ fun (range: Range1D) (mask: int []) (matrixRowPointers: int []) (matrixColumnIndices: int []) (matrixValues: 'a []) (vectorIndices: int []) (vectorValues: 'a []) (countOfProductsPerRow: int []) (valuesPerRow: 'a []) -> - - let gid = range.GlobalID0 - let lid = range.LocalID0 - let groupId = gid / wgSize - let rowId = mask.[groupId] - - let localCountAccum = localArray wgSize - localCountAccum.[lid] <- 0 - - let localValuesAccum = localArray<'a> wgSize - localValuesAccum.[lid] <- zero - - barrier () - - let mutable i = matrixRowPointers.[rowId] + lid - let _end = matrixRowPointers.[rowId + 1] - - while i < _end do - let col = matrixColumnIndices.[i] - let value = matrixValues.[i] - - let mutable l = 0 - let mutable r = vectorNnz - let mutable m = l + ((r - l) / 2) - let mutable idx = -1 - let mutable _break = false - - while l < r && not _break do - if vectorIndices.[m] = col then - idx <- m - _break <- true - elif vectorIndices.[m] < col then - l <- m + 1 - else - r <- m - - m <- l + ((r - l) / 2) - - if idx <> -1 then - let vectorValue = vectorValues.[idx] - localCountAccum.[lid] <- localCountAccum.[lid] + 1 - localValuesAccum.[lid] <- (%plus) localValuesAccum.[lid] ((%times) value vectorValue) - - i <- i + wgSize - - barrier () - - if lid = 0 then - let mutable countAcc = 0 - let mutable valueAcc = zero - - for i = 0 to wgSize - 1 do - countAcc <- countAcc + localCountAccum.[i] - valueAcc <- (%plus) valueAcc localValuesAccum.[i] - - countOfProductsPerRow.[rowId] <- countAcc - valuesPerRow.[rowId] <- valueAcc @> - - let countOfProductsPerRow = Array.zeroCreate rowCount - let valuesPerRow = Array.zeroCreate<'a> rowCount - - do! - runCommand calcValuesPerRow - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(maskNnz * Utils.defaultWorkGroupSize, Utils.defaultWorkGroupSize) - <| mask.Indices - <| matrix.RowPointers - <| matrix.ColumnIndices - <| matrix.Values - <| vector.Indices - <| vector.Values - <| countOfProductsPerRow - <| valuesPerRow - - let getNonzeroBitmap = - <@ fun (range: Range1D) (count: int []) (bitmap: int []) -> - - let gid = range.GlobalID0 - - if gid < rowCount && count.[gid] = 0 then - bitmap.[gid] <- 0 @> - - let bitmap = Array.create rowCount 1 - - do! - runCommand getNonzeroBitmap - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize rowCount, Utils.defaultWorkGroupSize) - <| countOfProductsPerRow - <| bitmap - - let! (positions, totalSum) = PrefixSum.runExclude bitmap - failwith "FIX ME! And rewrite." - //let! _ = ToHost totalSum - let resultLength = totalSum.[0] - - if resultLength = 0 then - return - { Size = matrix.RowCount - Indices = [||] - Values = [||] } - - else - let getOutputVector = - <@ fun (range: Range1D) (count: int []) (values: 'a []) (positions: int []) (outputValues: 'a []) (outputIndices: int []) -> - - let gid = range.GlobalID0 - - if gid < rowCount && count.[gid] <> 0 then - outputValues.[positions.[gid]] <- values.[gid] - outputIndices.[positions.[gid]] <- gid @> - - let outputValues = Array.zeroCreate<'a> resultLength - let outputIndices = Array.zeroCreate resultLength - - do! - runCommand getOutputVector - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize rowCount, Utils.defaultWorkGroupSize) - <| countOfProductsPerRow - <| valuesPerRow - <| positions - <| outputValues - <| outputIndices - - return - { Size = rowCount - Indices = outputIndices - Values = outputValues } - } diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/Transpose.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/Transpose.fs deleted file mode 100644 index a73ebd8b..00000000 --- a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/Transpose.fs +++ /dev/null @@ -1,225 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.CSRMatrix - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Backend.Common - -module internal rec Transpose = - let transposeMatrix (matrix: CSRMatrix<'a>) = - opencl { - if matrix.Values.Length = 0 then - return - { RowCount = matrix.ColumnCount - ColumnCount = matrix.RowCount - RowPointers = [| 0; 0 |] - ColumnIndices = [||] - Values = [||] } - else - let! coo = csr2coo matrix - let! packedIndices = pack coo.Columns coo.Rows - - do! BitonicSort.sortKeyValuesInplace packedIndices coo.Values - let! (rows, cols) = unpack packedIndices - - let! compressedRows = compressRows matrix.ColumnCount rows - - return - { RowCount = matrix.ColumnCount - ColumnCount = matrix.RowCount - RowPointers = compressedRows - ColumnIndices = cols - Values = coo.Values } - } - - let private csr2coo (matrix: CSRMatrix<'a>) = - opencl { - let wgSize = Utils.defaultWorkGroupSize - - let expandRows = - <@ fun (range: Range1D) (rowPointers: int []) (rowIndices: int []) -> - - let lid = range.LocalID0 - let groupId = range.GlobalID0 / wgSize - - let rowStart = rowPointers.[groupId] - let rowEnd = rowPointers.[groupId + 1] - let rowLength = rowEnd - rowStart - - let mutable i = lid - - while i < rowLength do - rowIndices.[rowStart + i] <- groupId - i <- i + wgSize @> - - let rowIndices = - Array.zeroCreate matrix.Values.Length - - do! - runCommand expandRows - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(wgSize * matrix.RowCount, wgSize) - <| matrix.RowPointers - <| rowIndices - - let! colIndices = Copy.copyArray matrix.ColumnIndices - let! values = Copy.copyArray matrix.Values - - return - { RowCount = matrix.RowCount - ColumnCount = matrix.ColumnCount - Rows = rowIndices - Columns = colIndices - Values = values } - } - - let private pack (firstArray: int []) (secondArray: int []) = - opencl { - let length = firstArray.Length - - let kernel = - <@ fun (range: Range1D) (firstArray: int []) (secondArray: int []) (packed: uint64 []) -> - - let gid = range.GlobalID0 - - if gid < length then - packed.[gid] <- - (uint64 firstArray.[gid] <<< 32) - ||| (uint64 secondArray.[gid]) @> - - let packedArray = Array.zeroCreate length - - do! - runCommand kernel - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize length, Utils.defaultWorkGroupSize) - <| firstArray - <| secondArray - <| packedArray - - return packedArray - } - - let private unpack (packedArray: uint64 []) = - opencl { - let length = packedArray.Length - - let kernel = - <@ fun (range: Range1D) (packedArray: uint64 []) (firstArray: int []) (secondArray: int []) -> - - let gid = range.GlobalID0 - - if gid < length then - firstArray.[gid] <- int ((packedArray.[gid] &&& 0xFFFFFFFF0000000UL) >>> 32) - secondArray.[gid] <- int (packedArray.[gid] &&& 0xFFFFFFFUL) @> - - let firstArray = Array.zeroCreate length - let secondArray = Array.zeroCreate length - - do! - runCommand kernel - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize length, Utils.defaultWorkGroupSize) - <| packedArray - <| firstArray - <| secondArray - - return firstArray, secondArray - } - - let private compressRows rowCount (rowIndices: int []) = - opencl { - let nnz = rowIndices.Length - - let getUniqueBitmap = - <@ fun (ndRange: Range1D) (inputArray: int []) (isUniqueBitmap: int []) -> - - let i = ndRange.GlobalID0 - - if i < nnz - 1 && inputArray.[i] = inputArray.[i + 1] then - isUniqueBitmap.[i] <- 0 @> - - let bitmap = Array.create nnz 1 - - do! - runCommand getUniqueBitmap - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize nnz, Utils.defaultWorkGroupSize) - <| rowIndices - <| bitmap - - let! (positions, totalSum) = PrefixSum.runExclude bitmap - failwith "FIX ME! And rewrite." - //let! _ = ToHost totalSum - let totalSum = totalSum.[0] - - let calcHyperSparseRows = - <@ fun (ndRange: Range1D) (rowsIndices: int []) (bitmap: int []) (positions: int []) (nonZeroRowsIndices: int []) (nonZeroRowsPointers: int []) -> - - let gid = ndRange.GlobalID0 - - if gid < nnz && bitmap.[gid] = 1 then - nonZeroRowsIndices.[positions.[gid]] <- rowsIndices.[gid] - nonZeroRowsPointers.[positions.[gid]] <- gid + 1 @> - - let nonZeroRowsIndices = Array.zeroCreate totalSum - let nonZeroRowsPointers = Array.zeroCreate totalSum - - do! - runCommand calcHyperSparseRows - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize nnz, Utils.defaultWorkGroupSize) - <| rowIndices - <| bitmap - <| positions - <| nonZeroRowsIndices - <| nonZeroRowsPointers - - let calcNnzPerRowSparse = - <@ fun (ndRange: Range1D) (nonZeroRowsPointers: int []) (nnzPerRowSparse: int []) -> - - let gid = ndRange.GlobalID0 - - if gid = 0 then - nnzPerRowSparse.[gid] <- nonZeroRowsPointers.[gid] - elif gid < totalSum then - nnzPerRowSparse.[gid] <- - nonZeroRowsPointers.[gid] - - nonZeroRowsPointers.[gid - 1] @> - - let nnzPerRowSparse = Array.zeroCreate totalSum - - do! - runCommand calcNnzPerRowSparse - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize totalSum, Utils.defaultWorkGroupSize) - <| nonZeroRowsPointers - <| nnzPerRowSparse - - let expandSparseNnzPerRow = - <@ fun (ndRange: Range1D) (nnzPerRowSparse: int []) (nonZeroRowsIndices: int []) (off2: int []) -> - - let gid = ndRange.GlobalID0 - - if gid < totalSum then - off2.[nonZeroRowsIndices.[gid] + 1] <- nnzPerRowSparse.[gid] @> - - let expandedNnzPerRow = Array.zeroCreate (rowCount + 1) - - do! - runCommand expandSparseNnzPerRow - <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Utils.getDefaultGlobalSize totalSum, Utils.defaultWorkGroupSize) - <| nnzPerRowSparse - <| nonZeroRowsIndices - <| expandedNnzPerRow - - let! (rowPointers, _) = PrefixSum.runInclude expandedNnzPerRow - return rowPointers - } diff --git a/src/GraphBLAS-sharp.Backend/Matrix/Common.fs b/src/GraphBLAS-sharp.Backend/Matrix/Common.fs index 997521af..5588b203 100644 --- a/src/GraphBLAS-sharp.Backend/Matrix/Common.fs +++ b/src/GraphBLAS-sharp.Backend/Matrix/Common.fs @@ -2,23 +2,22 @@ namespace GraphBLAS.FSharp.Backend.Matrix open Brahma.FSharp open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.Predefined open GraphBLAS.FSharp.Backend.Objects.ClContext open GraphBLAS.FSharp.Backend.Objects.ClCell -module Common = +module internal Common = ///. ///Should be a power of 2 and greater than 1. let setPositions<'a when 'a: struct> (clContext: ClContext) workGroupSize = let indicesScatter = - Scatter.runInplace clContext workGroupSize + Scatter.lastOccurrence clContext workGroupSize let valuesScatter = - Scatter.runInplace clContext workGroupSize + Scatter.lastOccurrence clContext workGroupSize let sum = - PrefixSum.standardExcludeInplace clContext workGroupSize + PrefixSum.standardExcludeInPlace clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (allRows: ClArray) (allColumns: ClArray) (allValues: ClArray<'a>) (positions: ClArray) -> @@ -41,3 +40,41 @@ module Common = valuesScatter processor positions allValues resultValues resultRows, resultColumns, resultValues, resultLength + + ///. + ///Should be a power of 2 and greater than 1. + let setPositionsOption<'a when 'a: struct> (clContext: ClContext) workGroupSize = + + let indicesScatter = + Scatter.lastOccurrence clContext workGroupSize + + let valuesScatter = + Scatter.lastOccurrence clContext workGroupSize + + let sum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (allRows: ClArray) (allColumns: ClArray) (allValues: ClArray<'a>) (positions: ClArray) -> + + let resultLength = + (sum processor positions).ToHostAndFree(processor) + + if resultLength = 0 then + None + else + let resultRows = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let resultColumns = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + indicesScatter processor positions allRows resultRows + + indicesScatter processor positions allColumns resultColumns + + valuesScatter processor positions allValues resultValues + + Some(resultRows, resultColumns, resultValues, resultLength) diff --git a/src/GraphBLAS-sharp.Backend/Matrix/LIL/Matrix.fs b/src/GraphBLAS-sharp.Backend/Matrix/LIL/Matrix.fs new file mode 100644 index 00000000..34eff782 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/LIL/Matrix.fs @@ -0,0 +1,45 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.LIL + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ClMatrix + +module Matrix = + let toCSR (clContext: ClContext) workGroupSize = + + let concatIndices = ClArray.concat clContext workGroupSize + + let concatValues = ClArray.concat clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (matrix: LIL<'a>) -> + + let rowsPointers = + matrix.Rows + |> List.map + (function + | None -> 0 + | Some vector -> vector.Values.Length) + |> List.toArray + // prefix sum + |> Array.scan (+) 0 + |> fun pointers -> clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, pointers) + + let valuesByRows, columnsIndicesByRows = + matrix.Rows + |> List.choose id + |> List.map (fun vector -> vector.Values, vector.Indices) + |> List.unzip + + let values = + concatValues processor allocationMode valuesByRows + + let columnsIndices = + concatIndices processor allocationMode columnsIndicesByRows + + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + RowPointers = rowsPointers + Columns = columnsIndices + Values = values } diff --git a/src/GraphBLAS-sharp.Backend/Matrix/Matrix.fs b/src/GraphBLAS-sharp.Backend/Matrix/Matrix.fs index 5e38c56b..cd754379 100644 --- a/src/GraphBLAS-sharp.Backend/Matrix/Matrix.fs +++ b/src/GraphBLAS-sharp.Backend/Matrix/Matrix.fs @@ -3,17 +3,22 @@ namespace GraphBLAS.FSharp.Backend.Matrix open Brahma.FSharp open Microsoft.FSharp.Quotations open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.Matrix.COO -open GraphBLAS.FSharp.Backend.Matrix.CSR +open GraphBLAS.FSharp.Backend.Matrix open GraphBLAS.FSharp.Backend.Objects open GraphBLAS.FSharp.Backend.Objects.ClMatrix +open GraphBLAS.FSharp.Backend.Vector +open GraphBLAS.FSharp.Backend.Objects.ClContext module Matrix = let copy (clContext: ClContext) workGroupSize = + let copy = ClArray.copy clContext workGroupSize let copyData = ClArray.copy clContext workGroupSize + let vectorCopy = + Sparse.Vector.copy clContext workGroupSize + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix<'a>) -> match matrix with | ClMatrix.COO m -> @@ -40,6 +45,16 @@ module Matrix = Rows = copy processor allocationMode m.Rows ColumnPointers = copy processor allocationMode m.ColumnPointers Values = copyData processor allocationMode m.Values } + | ClMatrix.LIL matrix -> + matrix.Rows + |> List.map (Option.map (vectorCopy processor allocationMode)) + |> fun rows -> + { Context = clContext + RowCount = matrix.RowCount + ColumnCount = matrix.ColumnCount + Rows = rows + NNZ = matrix.NNZ } + |> ClMatrix.LIL /// /// Creates a new matrix, represented in CSR format, that is equal to the given one. @@ -47,28 +62,26 @@ module Matrix = ///OpenCL context. ///Should be a power of 2 and greater than 1. let toCSR (clContext: ClContext) workGroupSize = - let toCSR = COOMatrix.toCSR clContext workGroupSize + let toCSR = COO.Matrix.toCSR clContext workGroupSize let copy = copy clContext workGroupSize let transpose = - CSRMatrix.transpose clContext workGroupSize + CSR.Matrix.transpose clContext workGroupSize + + let rowsToCSR = LIL.Matrix.toCSR clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix<'a>) -> match matrix with | ClMatrix.COO m -> toCSR processor allocationMode m |> ClMatrix.CSR | ClMatrix.CSR _ -> copy processor allocationMode matrix | ClMatrix.CSC m -> - - { Context = m.Context - RowCount = m.ColumnCount - ColumnCount = m.RowCount - RowPointers = m.ColumnPointers - Columns = m.Rows - Values = m.Values } - + m.ToCSR |> transpose processor allocationMode |> ClMatrix.CSR + | ClMatrix.LIL m -> + rowsToCSR processor allocationMode m + |> ClMatrix.CSR /// /// Returns the matrix, represented in CSR format, that is equal to the given one. @@ -76,29 +89,24 @@ module Matrix = /// ///OpenCL context. ///Should be a power of 2 and greater than 1. - let toCSRInplace (clContext: ClContext) workGroupSize = - let toCSRInplace = - COOMatrix.toCSRInplace clContext workGroupSize + let toCSRInPlace (clContext: ClContext) workGroupSize = + let toCSRInPlace = + COO.Matrix.toCSRInPlace clContext workGroupSize - let transposeInplace = - CSRMatrix.transposeInplace clContext workGroupSize + let transposeInPlace = + CSR.Matrix.transposeInPlace clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix<'a>) -> match matrix with | ClMatrix.COO m -> - toCSRInplace processor allocationMode m + toCSRInPlace processor allocationMode m |> ClMatrix.CSR | ClMatrix.CSR _ -> matrix | ClMatrix.CSC m -> - { Context = m.Context - RowCount = m.ColumnCount - ColumnCount = m.RowCount - RowPointers = m.ColumnPointers - Columns = m.Rows - Values = m.Values } - - |> transposeInplace processor allocationMode + m.ToCSR + |> transposeInPlace processor allocationMode |> ClMatrix.CSR + | _ -> failwith "Not yet implemented" /// /// Creates a new matrix, represented in COO format, that is equal to the given one. @@ -106,28 +114,27 @@ module Matrix = ///OpenCL context. ///Should be a power of 2 and greater than 1. let toCOO (clContext: ClContext) workGroupSize = - let toCOO = CSRMatrix.toCOO clContext workGroupSize + let toCOO = CSR.Matrix.toCOO clContext workGroupSize let copy = copy clContext workGroupSize - let transposeInplace = - COOMatrix.transposeInplace clContext workGroupSize + let transposeInPlace = + COO.Matrix.transposeInPlace clContext workGroupSize + + let rowsToCSR = LIL.Matrix.toCSR clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix<'a>) -> match matrix with | ClMatrix.COO _ -> copy processor allocationMode matrix | ClMatrix.CSR m -> toCOO processor allocationMode m |> ClMatrix.COO | ClMatrix.CSC m -> - - { Context = m.Context - RowCount = m.ColumnCount - ColumnCount = m.RowCount - RowPointers = m.ColumnPointers - Columns = m.Rows - Values = m.Values } - + m.ToCSR + |> toCOO processor allocationMode + |> transposeInPlace processor + |> ClMatrix.COO + | ClMatrix.LIL m -> + rowsToCSR processor allocationMode m |> toCOO processor allocationMode - |> transposeInplace processor |> ClMatrix.COO /// @@ -136,31 +143,25 @@ module Matrix = /// ///OpenCL context. ///Should be a power of 2 and greater than 1. - let toCOOInplace (clContext: ClContext) workGroupSize = - let toCOOInplace = - CSRMatrix.toCOOInplace clContext workGroupSize + let toCOOInPlace (clContext: ClContext) workGroupSize = + let toCOOInPlace = + CSR.Matrix.toCOOInPlace clContext workGroupSize - let transposeInplace = - COOMatrix.transposeInplace clContext workGroupSize + let transposeInPlace = + COO.Matrix.transposeInPlace clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix<'a>) -> match matrix with | ClMatrix.COO _ -> matrix | ClMatrix.CSR m -> - toCOOInplace processor allocationMode m + toCOOInPlace processor allocationMode m |> ClMatrix.COO | ClMatrix.CSC m -> - - { Context = m.Context - RowCount = m.ColumnCount - ColumnCount = m.RowCount - RowPointers = m.ColumnPointers - Columns = m.Rows - Values = m.Values } - - |> toCOOInplace processor allocationMode - |> transposeInplace processor + m.ToCSR + |> toCOOInPlace processor allocationMode + |> transposeInPlace processor |> ClMatrix.COO + | _ -> failwith "Not yet implemented" /// /// Creates a new matrix, represented in CSC format, that is equal to the given one. @@ -168,40 +169,33 @@ module Matrix = ///OpenCL context. ///Should be a power of 2 and greater than 1. let toCSC (clContext: ClContext) workGroupSize = - let toCSR = COOMatrix.toCSR clContext workGroupSize + let COOtoCSR = COO.Matrix.toCSR clContext workGroupSize let copy = copy clContext workGroupSize let transposeCSR = - CSRMatrix.transpose clContext workGroupSize + CSR.Matrix.transpose clContext workGroupSize let transposeCOO = - COOMatrix.transpose clContext workGroupSize + COO.Matrix.transpose clContext workGroupSize + + let rowsToCSR = LIL.Matrix.toCSR clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix<'a>) -> match matrix with | ClMatrix.CSC _ -> copy processor allocationMode matrix | ClMatrix.CSR m -> - let csrT = transposeCSR processor allocationMode m - - { Context = csrT.Context - RowCount = csrT.ColumnCount - ColumnCount = csrT.RowCount - Rows = csrT.Columns - ColumnPointers = csrT.RowPointers - Values = csrT.Values } + (transposeCSR processor allocationMode m).ToCSC |> ClMatrix.CSC | ClMatrix.COO m -> - let csrT = - transposeCOO processor allocationMode m - |> toCSR processor allocationMode - - { Context = csrT.Context - RowCount = csrT.ColumnCount - ColumnCount = csrT.RowCount - Rows = csrT.Columns - ColumnPointers = csrT.RowPointers - Values = csrT.Values } + (transposeCOO processor allocationMode m + |> COOtoCSR processor allocationMode) + .ToCSC + |> ClMatrix.CSC + | ClMatrix.LIL m -> + rowsToCSR processor allocationMode m + |> transposeCSR processor allocationMode + |> fun m -> m.ToCSC |> ClMatrix.CSC /// @@ -210,208 +204,122 @@ module Matrix = /// ///OpenCL context. ///Should be a power of 2 and greater than 1. - let toCSCInplace (clContext: ClContext) workGroupSize = - let toCSRInplace = - COOMatrix.toCSRInplace clContext workGroupSize + let toCSCInPlace (clContext: ClContext) workGroupSize = + let toCSRInPlace = + COO.Matrix.toCSRInPlace clContext workGroupSize - let transposeCSRInplace = - CSRMatrix.transposeInplace clContext workGroupSize + let transposeCSRInPlace = + CSR.Matrix.transposeInPlace clContext workGroupSize - let transposeCOOInplace = - COOMatrix.transposeInplace clContext workGroupSize + let transposeCOOInPlace = + COO.Matrix.transposeInPlace clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix<'a>) -> match matrix with | ClMatrix.CSC _ -> matrix | ClMatrix.CSR m -> - let csrT = - transposeCSRInplace processor allocationMode m - - { Context = csrT.Context - RowCount = csrT.ColumnCount - ColumnCount = csrT.RowCount - Rows = csrT.Columns - ColumnPointers = csrT.RowPointers - Values = csrT.Values } + (transposeCSRInPlace processor allocationMode m) + .ToCSC |> ClMatrix.CSC | ClMatrix.COO m -> - let csrT = - toCSRInplace processor allocationMode - <| transposeCOOInplace processor m - - { Context = csrT.Context - RowCount = csrT.ColumnCount - ColumnCount = csrT.RowCount - Rows = csrT.Columns - ColumnPointers = csrT.RowPointers - Values = csrT.Values } + (transposeCOOInPlace processor m + |> toCSRInPlace processor allocationMode) + .ToCSC |> ClMatrix.CSC + | _ -> failwith "Not yet implemented" + + let toLIL (clContext: ClContext) workGroupSize = - let map2 (clContext: ClContext) (opAdd: Expr<'a option -> 'b option -> 'c option>) workGroupSize = - let COOElementwise = - COOMatrix.map2 clContext opAdd workGroupSize + let copy = copy clContext workGroupSize - let CSRElementwise = - CSRMatrix.map2 clContext opAdd workGroupSize + let COOToCSR = COO.Matrix.toCSR clContext workGroupSize - fun (processor: MailboxProcessor<_>) allocationMode matrix1 matrix2 -> - match matrix1, matrix2 with - | ClMatrix.COO m1, ClMatrix.COO m2 -> - COOElementwise processor allocationMode m1 m2 - |> ClMatrix.COO - | ClMatrix.CSR m1, ClMatrix.CSR m2 -> - CSRElementwise processor allocationMode m1 m2 - |> ClMatrix.CSR - | ClMatrix.CSC m1, ClMatrix.CSC m2 -> - let csrT1 = - { Context = m1.Context - RowCount = m1.ColumnCount - ColumnCount = m1.RowCount - RowPointers = m1.ColumnPointers - Columns = m1.Rows - Values = m1.Values } - - let csrT2 = - { Context = m2.Context - RowCount = m2.ColumnCount - ColumnCount = m2.RowCount - RowPointers = m2.ColumnPointers - Columns = m2.Rows - Values = m2.Values } - - let resT = - CSRElementwise processor allocationMode csrT1 csrT2 - - { Context = resT.Context - RowCount = resT.ColumnCount - ColumnCount = resT.RowCount - Rows = resT.Columns - ColumnPointers = resT.RowPointers - Values = resT.Values } - |> ClMatrix.CSC - | _ -> failwith "Matrix formats are not matching" + let transposeCSR = + CSR.Matrix.transpose clContext workGroupSize - let map2ToCOO (clContext: ClContext) (opAdd: Expr<'a option -> 'b option -> 'c option>) workGroupSize = - let COOElementwise = - COOMatrix.map2 clContext opAdd workGroupSize + let CSRToLIL = CSR.Matrix.toLIL clContext workGroupSize - let CSRElementwise = - CSRMatrix.map2ToCOO clContext opAdd workGroupSize + fun (processor: MailboxProcessor<_>) allocationMode (matrix: ClMatrix<'a>) -> + match matrix with + | ClMatrix.CSC m -> + m.ToCSR + |> transposeCSR processor allocationMode + |> CSRToLIL processor allocationMode + |> ClMatrix.LIL + | ClMatrix.CSR m -> + CSRToLIL processor allocationMode m + |> ClMatrix.LIL + | ClMatrix.COO m -> + COOToCSR processor allocationMode m + |> CSRToLIL processor allocationMode + |> ClMatrix.LIL + | ClMatrix.LIL _ -> copy processor allocationMode matrix - let transposeCOOInplace = - COOMatrix.transposeInplace clContext workGroupSize + let map (opAdd: Expr<'a option -> 'b option>) (clContext: ClContext) workGroupSize = + let mapCOO = + COO.Matrix.map opAdd clContext workGroupSize - fun (processor: MailboxProcessor<_>) allocationMode matrix1 matrix2 -> - match matrix1, matrix2 with - | ClMatrix.COO m1, ClMatrix.COO m2 -> - COOElementwise processor allocationMode m1 m2 - |> ClMatrix.COO - | ClMatrix.CSR m1, ClMatrix.CSR m2 -> - CSRElementwise processor allocationMode m1 m2 - |> ClMatrix.COO - | ClMatrix.CSC m1, ClMatrix.CSC m2 -> - let csrT1 = - { Context = m1.Context - RowCount = m1.ColumnCount - ColumnCount = m1.RowCount - RowPointers = m1.ColumnPointers - Columns = m1.Rows - Values = m1.Values } - - let csrT2 = - { Context = m2.Context - RowCount = m2.ColumnCount - ColumnCount = m2.RowCount - RowPointers = m2.ColumnPointers - Columns = m2.Rows - Values = m2.Values } - - CSRElementwise processor allocationMode csrT1 csrT2 - |> transposeCOOInplace processor + let mapCSR = + CSR.Matrix.map opAdd clContext workGroupSize + + let transposeCOO = + COO.Matrix.transposeInPlace clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode matrix -> + match matrix with + | ClMatrix.COO m -> mapCOO processor allocationMode m |> ClMatrix.COO + | ClMatrix.CSR m -> mapCSR processor allocationMode m |> ClMatrix.COO + | ClMatrix.CSC m -> + (mapCSR processor allocationMode m.ToCSR) + |> transposeCOO processor |> ClMatrix.COO - | _ -> failwith "Matrix formats are not matching" + | _ -> failwith "Not yet implemented" - let map2AtLeastOne (clContext: ClContext) (opAdd: Expr -> 'c option>) workGroupSize = - let COOElementwise = - COOMatrix.map2AtLeastOne clContext opAdd workGroupSize + let map2 (opAdd: Expr<'a option -> 'b option -> 'c option>) (clContext: ClContext) workGroupSize = + let map2COO = + COO.Matrix.map2 opAdd clContext workGroupSize - let CSRElementwise = - CSRMatrix.map2AtLeastOne clContext opAdd workGroupSize + let map2CSR = + CSR.Matrix.map2 opAdd clContext workGroupSize + + let transposeCOO = + COO.Matrix.transposeInPlace clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode matrix1 matrix2 -> match matrix1, matrix2 with | ClMatrix.COO m1, ClMatrix.COO m2 -> - COOElementwise processor allocationMode m1 m2 + map2COO processor allocationMode m1 m2 |> ClMatrix.COO | ClMatrix.CSR m1, ClMatrix.CSR m2 -> - CSRElementwise processor allocationMode m1 m2 - |> ClMatrix.CSR + map2CSR processor allocationMode m1 m2 + |> ClMatrix.COO | ClMatrix.CSC m1, ClMatrix.CSC m2 -> - let csrT1 = - { Context = m1.Context - RowCount = m1.ColumnCount - ColumnCount = m1.RowCount - RowPointers = m1.ColumnPointers - Columns = m1.Rows - Values = m1.Values } - - let csrT2 = - { Context = m2.Context - RowCount = m2.ColumnCount - ColumnCount = m2.RowCount - RowPointers = m2.ColumnPointers - Columns = m2.Rows - Values = m2.Values } - - let resT = - CSRElementwise processor allocationMode csrT1 csrT2 - - { Context = resT.Context - RowCount = resT.ColumnCount - ColumnCount = resT.RowCount - Rows = resT.Columns - ColumnPointers = resT.RowPointers - Values = resT.Values } - |> ClMatrix.CSC + (map2CSR processor allocationMode m1.ToCSR m2.ToCSR) + |> transposeCOO processor + |> ClMatrix.COO | _ -> failwith "Matrix formats are not matching" - let map2AtLeastOneToCOO (clContext: ClContext) (opAdd: Expr -> 'c option>) workGroupSize = - let COOElementwise = - COOMatrix.map2AtLeastOne clContext opAdd workGroupSize + let map2AtLeastOne (opAdd: Expr -> 'c option>) (clContext: ClContext) workGroupSize = + let COOMap2 = + COO.Matrix.map2AtLeastOne clContext opAdd workGroupSize - let CSRElementwise = - CSRMatrix.map2AtLeastOneToCOO clContext opAdd workGroupSize + let CSRMap2 = + CSR.Matrix.map2AtLeastOne clContext opAdd workGroupSize - let transposeCOOInplace = - COOMatrix.transposeInplace clContext workGroupSize + let COOTranspose = + COO.Matrix.transposeInPlace clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode matrix1 matrix2 -> match matrix1, matrix2 with | ClMatrix.COO m1, ClMatrix.COO m2 -> - COOElementwise processor allocationMode m1 m2 + COOMap2 processor allocationMode m1 m2 |> ClMatrix.COO | ClMatrix.CSR m1, ClMatrix.CSR m2 -> - CSRElementwise processor allocationMode m1 m2 + CSRMap2 processor allocationMode m1 m2 |> ClMatrix.COO | ClMatrix.CSC m1, ClMatrix.CSC m2 -> - let csrT1 = - { Context = m1.Context - RowCount = m1.ColumnCount - ColumnCount = m1.RowCount - RowPointers = m1.ColumnPointers - Columns = m1.Rows - Values = m1.Values } - - let csrT2 = - { Context = m2.Context - RowCount = m2.ColumnCount - ColumnCount = m2.RowCount - RowPointers = m2.ColumnPointers - Columns = m2.Rows - Values = m2.Values } - - CSRElementwise processor allocationMode csrT1 csrT2 - |> transposeCOOInplace processor + (CSRMap2 processor allocationMode m1.ToCSR m2.ToCSR) + |> COOTranspose processor |> ClMatrix.COO | _ -> failwith "Matrix formats are not matching" @@ -428,29 +336,16 @@ module Matrix = /// ///OpenCL context. ///Should be a power of 2 and greater than 1. - let transposeInplace (clContext: ClContext) workGroupSize = - let COOtransposeInplace = - COOMatrix.transposeInplace clContext workGroupSize + let transposeInPlace (clContext: ClContext) workGroupSize = + let COOTransposeInPlace = + COO.Matrix.transposeInPlace clContext workGroupSize fun (processor: MailboxProcessor<_>) matrix -> match matrix with - | ClMatrix.COO m -> COOtransposeInplace processor m |> ClMatrix.COO - | ClMatrix.CSR m -> - { Context = m.Context - RowCount = m.ColumnCount - ColumnCount = m.RowCount - Rows = m.Columns - ColumnPointers = m.RowPointers - Values = m.Values } - |> ClMatrix.CSC - | ClMatrix.CSC m -> - { Context = m.Context - RowCount = m.ColumnCount - ColumnCount = m.RowCount - RowPointers = m.ColumnPointers - Columns = m.Rows - Values = m.Values } - |> ClMatrix.CSR + | ClMatrix.COO m -> COOTransposeInPlace processor m |> ClMatrix.COO + | ClMatrix.CSR m -> ClMatrix.CSC m.ToCSC + | ClMatrix.CSC m -> ClMatrix.CSR m.ToCSR + | ClMatrix.LIL _ -> failwith "Not yet implemented" /// /// Transposes the given matrix and returns result as a new matrix. @@ -465,8 +360,8 @@ module Matrix = ///OpenCL context. ///Should be a power of 2 and greater than 1. let transpose (clContext: ClContext) workGroupSize = - let COOtranspose = - COOMatrix.transpose clContext workGroupSize + let COOTranspose = + COO.Matrix.transpose clContext workGroupSize let copy = ClArray.copy clContext workGroupSize @@ -475,7 +370,7 @@ module Matrix = fun (processor: MailboxProcessor<_>) allocationMode matrix -> match matrix with | ClMatrix.COO m -> - COOtranspose processor allocationMode m + COOTranspose processor allocationMode m |> ClMatrix.COO | ClMatrix.CSR m -> { Context = m.Context @@ -493,18 +388,56 @@ module Matrix = Columns = copy processor allocationMode m.Rows Values = copyData processor allocationMode m.Values } |> ClMatrix.CSR + | ClMatrix.LIL _ -> failwith "Not yet implemented" - let mxm - (opAdd: Expr<'c -> 'c -> 'c option>) - (opMul: Expr<'a -> 'b -> 'c option>) - (clContext: ClContext) - workGroupSize - = - - let runCSRnCSC = - CSRMatrix.spgemmCSC clContext workGroupSize opAdd opMul + let kronecker (op: Expr<'a option -> 'b option -> 'c option>) (clContext: ClContext) workGroupSize = + let run = + CSR.Matrix.kronecker clContext workGroupSize op - fun (queue: MailboxProcessor<_>) (matrix1: ClMatrix<'a>) (matrix2: ClMatrix<'b>) (mask: ClMatrix<_>) -> - match matrix1, matrix2, mask with - | ClMatrix.CSR m1, ClMatrix.CSC m2, ClMatrix.COO mask -> runCSRnCSC queue m1 m2 mask |> ClMatrix.COO - | _ -> failwith "Matrix formats are not matching" + fun (queue: MailboxProcessor<_>) allocationFlag (matrix1: ClMatrix<'a>) (matrix2: ClMatrix<'b>) -> + match matrix1, matrix2 with + | ClMatrix.CSR m1, ClMatrix.CSR m2 -> + let result = run queue allocationFlag m1 m2 + Option.map ClMatrix.COO result + | _ -> failwith "Both matrices should be in CSR format." + + module SpGeMM = + let masked + (opAdd: Expr<'c -> 'c -> 'c option>) + (opMul: Expr<'a -> 'b -> 'c option>) + (clContext: ClContext) + workGroupSize + = + + let runCSRnCSC = + SpGeMM.Masked.run opAdd opMul clContext workGroupSize + + fun (queue: MailboxProcessor<_>) (matrix1: ClMatrix<'a>) (matrix2: ClMatrix<'b>) (mask: ClMatrix<_>) -> + match matrix1, matrix2, mask with + | ClMatrix.CSR m1, ClMatrix.CSC m2, ClMatrix.COO mask -> runCSRnCSC queue m1 m2 mask |> ClMatrix.COO + | _ -> failwith "Matrix formats are not matching" + + let expand + (opAdd: Expr<'c -> 'c -> 'c option>) + (opMul: Expr<'a -> 'b -> 'c option>) + (clContext: ClContext) + workGroupSize + = + + let run = + SpGeMM.Expand.run opAdd opMul clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (leftMatrix: ClMatrix<'a>) (rightMatrix: ClMatrix<'b>) -> + match leftMatrix, rightMatrix with + | ClMatrix.CSR leftMatrix, ClMatrix.CSR rightMatrix -> + let allocCapacity = + List.max [ sizeof<'a> + sizeof<'c> + sizeof<'b> ] + * 1 + + let resultCapacity = + (clContext.MaxMemAllocSize / allocCapacity) / 3 + + run processor allocationMode resultCapacity leftMatrix rightMatrix + | _ -> failwith "Matrix formats are not matching" diff --git a/src/GraphBLAS-sharp.Backend/Matrix/SpGeMM/Expand.fs b/src/GraphBLAS-sharp.Backend/Matrix/SpGeMM/Expand.fs new file mode 100644 index 00000000..92eba752 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Matrix/SpGeMM/Expand.fs @@ -0,0 +1,494 @@ +namespace GraphBLAS.FSharp.Backend.Matrix.SpGeMM + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Common.Sort +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClCell +open FSharp.Quotations +open GraphBLAS.FSharp.Backend.Objects.ClMatrix + +module Expand = + let getSegmentPointers (clContext: ClContext) workGroupSize = + + let gather = Gather.run clContext workGroupSize + + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (leftMatrixColumns: ClArray) (rightMatrixRowsLengths: ClArray) -> + + let segmentsLengths = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, leftMatrixColumns.Length) + + // extract needed lengths by left matrix nnz + gather processor leftMatrixColumns rightMatrixRowsLengths segmentsLengths + + // compute pointers + let length = + (prefixSum processor segmentsLengths) + .ToHostAndFree processor + + length, segmentsLengths + + let multiply (predicate: Expr<'a -> 'b -> 'c option>) (clContext: ClContext) workGroupSize = + let getBitmap = + ClArray.map2<'a, 'b, int> (Map.choose2Bitmap predicate) clContext workGroupSize + + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + let assignValues = + ClArray.assignOption2 predicate clContext workGroupSize + + let scatter = + Scatter.lastOccurrence clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (firstValues: ClArray<'a>) (secondValues: ClArray<'b>) (columns: ClArray) (rows: ClArray) -> + + let positions = + getBitmap processor DeviceOnly firstValues secondValues + + let resultLength = + (prefixSum processor positions) + .ToHostAndFree(processor) + + if resultLength = 0 then + positions.Free processor + + None + else + let resultColumns = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + scatter processor positions columns resultColumns + + let resultRows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + scatter processor positions rows resultRows + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, resultLength) + + assignValues processor firstValues secondValues positions resultValues + + positions.Free processor + + Some(resultValues, resultColumns, resultRows) + + let expand (clContext: ClContext) workGroupSize = + + let idScatter = + Scatter.initLastOccurrence Map.id clContext workGroupSize + + let scatter = + Scatter.lastOccurrence clContext workGroupSize + + let zeroCreate = + ClArray.zeroCreate clContext workGroupSize + + let maxPrefixSum = + PrefixSum.runIncludeInPlace <@ max @> clContext workGroupSize + + let create = ClArray.create clContext workGroupSize + + let gather = Gather.run clContext workGroupSize + + let segmentPrefixSum = + PrefixSum.ByKey.sequentialInclude <@ (+) @> 0 clContext workGroupSize + + let removeDuplicates = + ClArray.removeDuplications clContext workGroupSize + + let leftMatrixGather = Gather.run clContext workGroupSize + + let rightMatrixGather = Gather.run clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (lengths: int) (segmentsPointers: ClArray) (leftMatrix: ClMatrix.COO<'a>) (rightMatrix: ClMatrix.CSR<'b>) -> + // Compute left matrix positions + let leftMatrixPositions = zeroCreate processor DeviceOnly lengths + + idScatter processor segmentsPointers leftMatrixPositions + + (maxPrefixSum processor leftMatrixPositions 0) + .Free processor + + // Compute right matrix positions + let rightMatrixPositions = create processor DeviceOnly lengths 1 + + let requiredRightMatrixPointers = + zeroCreate processor DeviceOnly leftMatrix.Columns.Length + + gather processor leftMatrix.Columns rightMatrix.RowPointers requiredRightMatrixPointers + + scatter processor segmentsPointers requiredRightMatrixPointers rightMatrixPositions + + requiredRightMatrixPointers.Free processor + + // another way to get offsets ??? + let offsets = + removeDuplicates processor segmentsPointers + + segmentPrefixSum processor offsets.Length rightMatrixPositions leftMatrixPositions offsets + + offsets.Free processor + + // compute columns + let columns = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, lengths) + + gather processor rightMatrixPositions rightMatrix.Columns columns + + let rows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, lengths) + + gather processor leftMatrixPositions leftMatrix.Rows rows + + // compute left matrix values + let leftMatrixValues = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, lengths) + + leftMatrixGather processor leftMatrixPositions leftMatrix.Values leftMatrixValues + + leftMatrixPositions.Free processor + + // compute right matrix values + let rightMatrixValues = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, lengths) + + rightMatrixGather processor rightMatrixPositions rightMatrix.Values rightMatrixValues + + rightMatrixPositions.Free processor + + // left, right matrix values, columns and rows indices + leftMatrixValues, rightMatrixValues, columns, rows + + let sortByColumnsAndRows (clContext: ClContext) workGroupSize = + + let sortByKeyIndices = + Radix.runByKeysStandard clContext workGroupSize + + let sortByKeyValues = + Radix.runByKeysStandard clContext workGroupSize + + let sortKeys = + Radix.standardRunKeysOnly clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (values: ClArray<'a>) (columns: ClArray) (rows: ClArray) -> + // sort by columns + let valuesSortedByColumns = + sortByKeyValues processor DeviceOnly columns values + + let rowsSortedByColumns = + sortByKeyIndices processor DeviceOnly columns rows + + let sortedColumns = sortKeys processor columns + + // sort by rows + let valuesSortedByRows = + sortByKeyValues processor DeviceOnly rowsSortedByColumns valuesSortedByColumns + + let columnsSortedByRows = + sortByKeyIndices processor DeviceOnly rowsSortedByColumns sortedColumns + + let sortedRows = sortKeys processor rowsSortedByColumns + + valuesSortedByColumns.Free processor + rowsSortedByColumns.Free processor + sortedColumns.Free processor + + valuesSortedByRows, columnsSortedByRows, sortedRows + + let reduce opAdd (clContext: ClContext) workGroupSize = + + let reduce = + Reduce.ByKey2D.Option.segmentSequential opAdd clContext workGroupSize + + let getUniqueBitmap = + ClArray.Bitmap.lastOccurrence2 clContext workGroupSize + + let prefixSum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + let idScatter = + Scatter.initFirsOccurrence Map.id clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (values: ClArray<'a>) (columns: ClArray) (rows: ClArray) -> + + let bitmap = + getUniqueBitmap processor DeviceOnly columns rows + + let uniqueKeysCount = + (prefixSum processor bitmap) + .ToHostAndFree processor + + let offsets = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, uniqueKeysCount) + + idScatter processor bitmap offsets + + bitmap.Free processor + + let reduceResult = + reduce processor allocationMode uniqueKeysCount offsets columns rows values + + offsets.Free processor + + // reducedValues, reducedColumns, reducedRows option + reduceResult + + let runCOO opAdd opMul (clContext: ClContext) workGroupSize = + + let getSegmentPointers = + getSegmentPointers clContext workGroupSize + + let expand = expand clContext workGroupSize + + let multiply = multiply opMul clContext workGroupSize + + let sort = + sortByColumnsAndRows clContext workGroupSize + + let reduce = reduce opAdd clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (rightMatrixRowsNNZ: ClArray) (rightMatrix: ClMatrix.CSR<'b>) (leftMatrix: ClMatrix.COO<'a>) -> + + let length, segmentPointers = + getSegmentPointers processor leftMatrix.Columns rightMatrixRowsNNZ + + if length = 0 then + segmentPointers.Free processor + + length, None + else + // expand + let leftMatrixValues, rightMatrixValues, columns, rows = + expand processor length segmentPointers leftMatrix rightMatrix + + segmentPointers.Free processor + + // multiply + let mulResult = + multiply processor leftMatrixValues rightMatrixValues columns rows + + leftMatrixValues.Free processor + rightMatrixValues.Free processor + columns.Free processor + rows.Free processor + + let result = + mulResult + |> Option.bind + (fun (resultValues, resultColumns, resultRows) -> + // sort + let sortedValues, sortedColumns, sortedRows = + sort processor resultValues resultColumns resultRows + + resultValues.Free processor + resultColumns.Free processor + resultRows.Free processor + + // addition + let reduceResult = + reduce processor allocationMode sortedValues sortedColumns sortedRows + + sortedValues.Free processor + sortedColumns.Free processor + sortedRows.Free processor + + reduceResult) + + length, result + + let runOneStep opAdd opMul (clContext: ClContext) workGroupSize = + + let runCOO = + runCOO opAdd opMul clContext workGroupSize + + let expandRowPointers = + CSR.Matrix.expandRowPointers clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (leftMatrix: ClMatrix.CSR<'a>) rightMatrixRowsNNZ (rightMatrix: ClMatrix.CSR<'b>) -> + + let rows = + expandRowPointers processor DeviceOnly leftMatrix + + let leftMatrixCOO = + { Context = clContext + RowCount = leftMatrix.RowCount + ColumnCount = leftMatrix.ColumnCount + Rows = rows + Columns = leftMatrix.Columns + Values = leftMatrix.Values } + + let _, result = + runCOO processor allocationMode rightMatrixRowsNNZ rightMatrix leftMatrixCOO + + rows.Free processor + + result + |> Option.map + (fun (values, columns, rows) -> + { Context = clContext + RowCount = leftMatrix.RowCount + ColumnCount = rightMatrix.ColumnCount + Rows = rows + Columns = columns + Values = values }) + + let runManySteps opAdd opMul (clContext: ClContext) workGroupSize = + + let gather = Gather.run clContext workGroupSize + + let upperBound = + ClArray.upperBound clContext workGroupSize + + let set = ClArray.set clContext workGroupSize + + let subMatrix = + CSR.Matrix.subRows clContext workGroupSize + + let runCOO = + runCOO opAdd opMul clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode maxAllocSize generalLength (leftMatrix: ClMatrix.CSR<'a>) segmentLengths rightMatrixRowsNNZ (rightMatrix: ClMatrix.CSR<'b>) -> + // extract segment lengths by left matrix rows pointers + let segmentPointersByLeftMatrixRows = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, leftMatrix.RowPointers.Length) + + gather processor leftMatrix.RowPointers segmentLengths segmentPointersByLeftMatrixRows + + // set last element to one step length + set processor segmentPointersByLeftMatrixRows (leftMatrix.RowPointers.Length - 1) generalLength + + // curring + let upperBound = + upperBound processor segmentPointersByLeftMatrixRows + + let subMatrix = subMatrix processor DeviceOnly + + let runCOO = + runCOO processor allocationMode rightMatrixRowsNNZ rightMatrix + + let rec helper beginRow workOffset previousResult = + if beginRow < leftMatrix.RowCount then + let currentBound = + clContext.CreateClCell(workOffset + maxAllocSize: int) + + // find largest row that fit into maxAllocSize + let upperBound = + (upperBound currentBound).ToHostAndFree processor + + let endRow = upperBound - 2 + + currentBound.Free processor + + // TODO(handle largest rows) + // (we can split row, multiply and merge them but merge path needed) + if endRow = beginRow then + failwith "It is impossible to multiply such a long row" + + // extract matrix TODO(Transfer overhead) + let subMatrix = + subMatrix beginRow (endRow - beginRow) leftMatrix + + // compute sub result + let length, result = runCOO subMatrix + // increase workOffset according to previous expand + let workOffset = workOffset + length + + match result with + | Some result -> + helper endRow workOffset + <| result :: previousResult + | None -> helper endRow workOffset previousResult + else + previousResult + + let result = helper 0 0 [] |> List.rev + + segmentPointersByLeftMatrixRows.Free processor + + result + + let run opAdd opMul (clContext: ClContext) workGroupSize = + + let getNNZInRows = + CSR.Matrix.NNZInRows clContext workGroupSize + + let getSegmentPointers = + getSegmentPointers clContext workGroupSize + + let runOneStep = + runOneStep opAdd opMul clContext workGroupSize + + let concat = ClArray.concat clContext workGroupSize + + let concatData = ClArray.concat clContext workGroupSize + + let runManySteps = + runManySteps opAdd opMul clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode maxAllocSize (leftMatrix: ClMatrix.CSR<'a>) (rightMatrix: ClMatrix.CSR<'b>) -> + + let rightMatrixRowsNNZ = + getNNZInRows processor DeviceOnly rightMatrix + + let generalLength, segmentLengths = + getSegmentPointers processor leftMatrix.Columns rightMatrixRowsNNZ + + if generalLength < maxAllocSize then + segmentLengths.Free processor + + runOneStep processor allocationMode leftMatrix rightMatrixRowsNNZ rightMatrix + else + let result = + runManySteps + processor + allocationMode + maxAllocSize + generalLength + leftMatrix + segmentLengths + rightMatrixRowsNNZ + rightMatrix + + rightMatrixRowsNNZ.Free processor + segmentLengths.Free processor + + match result with + | _ :: _ -> + let valuesList, columnsList, rowsList = result |> List.unzip3 + + let values = + concatData processor allocationMode valuesList + + let columns = + concat processor allocationMode columnsList + + let rows = concat processor allocationMode rowsList + + // TODO(overhead: compute result length 3 time) + // release resources + valuesList + |> List.iter (fun array -> array.Free processor) + + columnsList + |> List.iter (fun array -> array.Free processor) + + rowsList + |> List.iter (fun array -> array.Free processor) + + { Context = clContext + RowCount = leftMatrix.RowCount + ColumnCount = rightMatrix.ColumnCount + Rows = rows + Columns = columns + Values = values } + |> Some + | _ -> None diff --git a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/SpGEMM.fs b/src/GraphBLAS-sharp.Backend/Matrix/SpGeMM/Masked.fs similarity index 88% rename from src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/SpGEMM.fs rename to src/GraphBLAS-sharp.Backend/Matrix/SpGeMM/Masked.fs index cbcfbeb4..700018c3 100644 --- a/src/GraphBLAS-sharp.Backend/Matrix/CSRMatrix/SpGEMM.fs +++ b/src/GraphBLAS-sharp.Backend/Matrix/SpGeMM/Masked.fs @@ -1,20 +1,19 @@ -namespace GraphBLAS.FSharp.Backend.Matrix.CSR +namespace GraphBLAS.FSharp.Backend.Matrix.SpGeMM open GraphBLAS.FSharp.Backend.Common open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Predefined open Microsoft.FSharp.Quotations open GraphBLAS.FSharp.Backend.Objects open GraphBLAS.FSharp.Backend.Objects.ClMatrix open GraphBLAS.FSharp.Backend.Objects.ClContext open GraphBLAS.FSharp.Backend.Objects.ClCell -module internal SpGEMM = +module internal Masked = let private calculate - (context: ClContext) - workGroupSize (opAdd: Expr<'c -> 'c -> 'c option>) (opMul: Expr<'a -> 'b -> 'c option>) + (context: ClContext) + workGroupSize = let run = @@ -143,20 +142,23 @@ module internal SpGEMM = values, bitmap let run - (context: ClContext) - workGroupSize (opAdd: Expr<'c -> 'c -> 'c option>) (opMul: Expr<'a -> 'b -> 'c option>) + (context: ClContext) + workGroupSize = let calculate = - calculate context workGroupSize opAdd opMul + calculate opAdd opMul context workGroupSize + + let scatter = + Scatter.lastOccurrence context workGroupSize - let scatter = Scatter.runInplace context workGroupSize - let scatterData = Scatter.runInplace context workGroupSize + let scatterData = + Scatter.lastOccurrence context workGroupSize - let scanInplace = - PrefixSum.standardExcludeInplace context workGroupSize + let scanInPlace = + PrefixSum.standardExcludeInPlace context workGroupSize fun (queue: MailboxProcessor<_>) (matrixLeft: ClMatrix.CSR<'a>) (matrixRight: ClMatrix.CSC<'b>) (mask: ClMatrix.COO<_>) -> @@ -164,15 +166,15 @@ module internal SpGEMM = calculate queue matrixLeft matrixRight mask let resultNNZ = - (scanInplace queue positions).ToHostAndFree(queue) + (scanInPlace queue positions).ToHostAndFree(queue) let resultRows = context.CreateClArray resultNNZ - let resultCols = context.CreateClArray resultNNZ - let resultVals = context.CreateClArray<'c> resultNNZ + let resultColumns = context.CreateClArray resultNNZ + let resultValues = context.CreateClArray<'c> resultNNZ scatter queue positions mask.Rows resultRows - scatter queue positions mask.Columns resultCols - scatterData queue positions values resultVals + scatter queue positions mask.Columns resultColumns + scatterData queue positions values resultValues queue.Post(Msg.CreateFreeMsg<_>(values)) queue.Post(Msg.CreateFreeMsg<_>(positions)) @@ -181,5 +183,5 @@ module internal SpGEMM = RowCount = matrixLeft.RowCount ColumnCount = matrixRight.ColumnCount Rows = resultRows - Columns = resultCols - Values = resultVals } + Columns = resultColumns + Values = resultValues } diff --git a/src/GraphBLAS-sharp.Backend/Objects/ArraysExtentions.fs b/src/GraphBLAS-sharp.Backend/Objects/ArraysExtentions.fs index d76b90b9..29aad544 100644 --- a/src/GraphBLAS-sharp.Backend/Objects/ArraysExtentions.fs +++ b/src/GraphBLAS-sharp.Backend/Objects/ArraysExtentions.fs @@ -3,9 +3,8 @@ open Brahma.FSharp module ArraysExtensions = - type ClArray<'a> with - member this.Dispose(q: MailboxProcessor) = + member this.FreeAndWait(q: MailboxProcessor) = q.Post(Msg.CreateFreeMsg this) q.PostAndReply(Msg.MsgNotifyMe) @@ -13,6 +12,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 diff --git a/src/GraphBLAS-sharp.Backend/Objects/ClCell.fs b/src/GraphBLAS-sharp.Backend/Objects/ClCell.fs index 5d6d1dc6..6b6b188f 100644 --- a/src/GraphBLAS-sharp.Backend/Objects/ClCell.fs +++ b/src/GraphBLAS-sharp.Backend/Objects/ClCell.fs @@ -4,10 +4,14 @@ open Brahma.FSharp module ClCell = type ClCell<'a> with - member this.ToHostAndFree(processor: MailboxProcessor<_>) = - let res = - processor.PostAndReply(fun ch -> Msg.CreateToHostMsg<_>(this, (Array.zeroCreate<'a> 1), ch)) + member this.ToHost(processor: MailboxProcessor<_>) = + processor.PostAndReply(fun ch -> Msg.CreateToHostMsg<_>(this, (Array.zeroCreate<'a> 1), ch)).[0] + member this.Free(processor: MailboxProcessor<_>) = processor.Post(Msg.CreateFreeMsg<_>(this)) - res.[0] + member this.ToHostAndFree(processor: MailboxProcessor<_>) = + let result = this.ToHost processor + this.Free processor + + result diff --git a/src/GraphBLAS-sharp.Backend/Objects/ClContextExtensions.fs b/src/GraphBLAS-sharp.Backend/Objects/ClContextExtensions.fs index 650a423e..bd5c8a3a 100644 --- a/src/GraphBLAS-sharp.Backend/Objects/ClContextExtensions.fs +++ b/src/GraphBLAS-sharp.Backend/Objects/ClContextExtensions.fs @@ -41,3 +41,11 @@ module ClContext = hostAccessMode = HostAccessMode.ReadWrite, allocationMode = AllocationMode.CopyHostPtr ) + + member this.MaxMemAllocSize = + let error = ref Unchecked.defaultof + + Cl + .GetDeviceInfo(this.ClDevice.Device, OpenCL.Net.DeviceInfo.MaxMemAllocSize, error) + .CastTo() + * 1 diff --git a/src/GraphBLAS-sharp.Backend/Objects/Matrix.fs b/src/GraphBLAS-sharp.Backend/Objects/Matrix.fs index 6f37eb9d..650c40b3 100644 --- a/src/GraphBLAS-sharp.Backend/Objects/Matrix.fs +++ b/src/GraphBLAS-sharp.Backend/Objects/Matrix.fs @@ -6,6 +6,7 @@ type MatrixFormat = | CSR | COO | CSC + | LIL module ClMatrix = type CSR<'elem when 'elem: struct> = @@ -23,42 +24,77 @@ module ClMatrix = q.Post(Msg.CreateFreeMsg<_>(this.RowPointers)) q.PostAndReply(Msg.MsgNotifyMe) + member this.Dispose q = (this :> IDeviceMemObject).Dispose q + member this.NNZ = this.Values.Length - type COO<'elem when 'elem: struct> = + member this.ToCSC = + { Context = this.Context + RowCount = this.ColumnCount + ColumnCount = this.RowCount + Rows = this.Columns + ColumnPointers = this.RowPointers + Values = this.Values } + + and CSC<'elem when 'elem: struct> = { Context: ClContext RowCount: int ColumnCount: int Rows: ClArray - Columns: ClArray + ColumnPointers: ClArray Values: ClArray<'elem> } interface IDeviceMemObject with member this.Dispose q = q.Post(Msg.CreateFreeMsg<_>(this.Values)) - q.Post(Msg.CreateFreeMsg<_>(this.Columns)) q.Post(Msg.CreateFreeMsg<_>(this.Rows)) + q.Post(Msg.CreateFreeMsg<_>(this.ColumnPointers)) q.PostAndReply(Msg.MsgNotifyMe) + member this.Dispose q = (this :> IDeviceMemObject).Dispose q + member this.NNZ = this.Values.Length - type CSC<'elem when 'elem: struct> = + member this.ToCSR = + { Context = this.Context + RowCount = this.ColumnCount + ColumnCount = this.RowCount + RowPointers = this.ColumnPointers + Columns = this.Rows + Values = this.Values } + + type COO<'elem when 'elem: struct> = { Context: ClContext RowCount: int ColumnCount: int Rows: ClArray - ColumnPointers: ClArray + Columns: ClArray Values: ClArray<'elem> } interface IDeviceMemObject with member this.Dispose q = q.Post(Msg.CreateFreeMsg<_>(this.Values)) + q.Post(Msg.CreateFreeMsg<_>(this.Columns)) q.Post(Msg.CreateFreeMsg<_>(this.Rows)) - q.Post(Msg.CreateFreeMsg<_>(this.ColumnPointers)) q.PostAndReply(Msg.MsgNotifyMe) + member this.Dispose q = (this :> IDeviceMemObject).Dispose q + member this.NNZ = this.Values.Length + type LIL<'elem when 'elem: struct> = + { Context: ClContext + RowCount: int + ColumnCount: int + Rows: ClVector.Sparse<'elem> option list + NNZ: int } + + interface IDeviceMemObject with + member this.Dispose q = + this.Rows + |> Seq.choose id + |> Seq.iter (fun vector -> vector.Dispose q) + type Tuple<'elem when 'elem: struct> = { Context: ClContext RowIndices: ClArray @@ -72,6 +108,8 @@ module ClMatrix = q.Post(Msg.CreateFreeMsg<_>(this.Values)) q.PostAndReply(Msg.MsgNotifyMe) + member this.Dispose q = (this :> IDeviceMemObject).Dispose q + member this.NNZ = this.Values.Length [] @@ -79,27 +117,32 @@ type ClMatrix<'a when 'a: struct> = | CSR of ClMatrix.CSR<'a> | COO of ClMatrix.COO<'a> | CSC of ClMatrix.CSC<'a> + | LIL of ClMatrix.LIL<'a> member this.RowCount = match this with | ClMatrix.CSR matrix -> matrix.RowCount | ClMatrix.COO matrix -> matrix.RowCount | ClMatrix.CSC matrix -> matrix.RowCount + | ClMatrix.LIL matrix -> matrix.RowCount member this.ColumnCount = match this with | ClMatrix.CSR matrix -> matrix.ColumnCount | ClMatrix.COO matrix -> matrix.ColumnCount | ClMatrix.CSC matrix -> matrix.ColumnCount + | ClMatrix.LIL matrix -> matrix.ColumnCount member this.Dispose q = match this with | ClMatrix.CSR matrix -> (matrix :> IDeviceMemObject).Dispose q | ClMatrix.COO matrix -> (matrix :> IDeviceMemObject).Dispose q | ClMatrix.CSC matrix -> (matrix :> IDeviceMemObject).Dispose q + | ClMatrix.LIL matrix -> (matrix :> IDeviceMemObject).Dispose q member this.NNZ = match this with | ClMatrix.CSR matrix -> matrix.NNZ | ClMatrix.COO matrix -> matrix.NNZ | ClMatrix.CSC matrix -> matrix.NNZ + | ClMatrix.LIL matrix -> matrix.NNZ diff --git a/src/GraphBLAS-sharp.Backend/Objects/Vector.fs b/src/GraphBLAS-sharp.Backend/Objects/Vector.fs index 4e9f3b33..f7430242 100644 --- a/src/GraphBLAS-sharp.Backend/Objects/Vector.fs +++ b/src/GraphBLAS-sharp.Backend/Objects/Vector.fs @@ -22,6 +22,8 @@ module ClVector = member this.Dispose(q) = (this :> IDeviceMemObject).Dispose(q) + member this.NNZ = this.Values.Length + [] type ClVector<'a when 'a: struct> = | Sparse of ClVector.Sparse<'a> @@ -34,4 +36,4 @@ type ClVector<'a when 'a: struct> = member this.Dispose(q) = match this with | Sparse vector -> vector.Dispose(q) - | Dense vector -> vector.Dispose(q) + | Dense vector -> vector.FreeAndWait(q) diff --git a/src/GraphBLAS-sharp.Backend/Predefined/PrefixSum.fs b/src/GraphBLAS-sharp.Backend/Predefined/PrefixSum.fs deleted file mode 100644 index 5e07eac7..00000000 --- a/src/GraphBLAS-sharp.Backend/Predefined/PrefixSum.fs +++ /dev/null @@ -1,41 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.Predefined - -open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Common - -module internal PrefixSum = - let standardExcludeInplace (clContext: ClContext) workGroupSize = - - let scan = - ClArray.prefixSumExcludeInplace <@ (+) @> clContext workGroupSize - - fun (processor: MailboxProcessor<_>) (inputArray: ClArray) -> - - scan processor inputArray 0 - - let standardIncludeInplace (clContext: ClContext) workGroupSize = - - let scan = - ClArray.prefixSumIncludeInplace <@ (+) @> clContext workGroupSize - - fun (processor: MailboxProcessor<_>) (inputArray: ClArray) -> - - scan processor inputArray 0 - - let standardInclude (clContext: ClContext) workGroupSize = - - let scan = - ClArray.prefixSumInclude <@ (+) @> clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (inputArray: ClArray) -> - - scan processor allocationMode inputArray 0 - - let standardExclude (clContext: ClContext) workGroupSize = - - let scan = - ClArray.prefixSumExclude <@ (+) @> clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (inputArray: ClArray) -> - - scan processor allocationMode inputArray 0 diff --git a/src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs b/src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs index 1432510f..f7d51a89 100644 --- a/src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs +++ b/src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs @@ -3,6 +3,16 @@ open GraphBLAS.FSharp.Backend.Objects module ArithmeticOperations = + let inline mkUnaryOp zero unaryOp = + <@ fun x -> + let mutable res = zero + + match x with + | Some v -> res <- (%unaryOp) v + | None -> res <- (%unaryOp) zero + + if res = zero then None else Some res @> + let inline mkNumericSum zero = <@ fun (x: 't option) (y: 't option) -> let mutable res = zero @@ -46,7 +56,35 @@ module ArithmeticOperations = if res = zero then None else Some res @> - let boolSum = + let byteSumOption = + <@ fun (x: byte option) (y: byte option) -> + let mutable res = 0 + + // Converted to int because of Quotations Evaluator issue. + let xInt = + match x with + | Some x -> Some(int x) + | None -> None + + let yInt = + match y with + | Some y -> Some(int y) + | None -> None + + match xInt, yInt with + | Some f, Some s -> res <- f + s + | Some f, None -> res <- f + | None, Some s -> res <- s + | None, None -> () + + let byteRes = byte res + + if byteRes = 0uy then + None + else + Some byteRes @> + + let boolSumOption = <@ fun (x: bool option) (y: bool option) -> let mutable res = false @@ -56,10 +94,15 @@ module ArithmeticOperations = if res then Some true else None @> - let intSum = mkNumericSum 0 - let byteSum = mkNumericSum 0uy - let floatSum = mkNumericSum 0.0 - let float32Sum = mkNumericSum 0f + let inline addLeftConst zero constant = + mkUnaryOp zero <@ fun x -> constant + x @> + + let inline addRightConst zero constant = + mkUnaryOp zero <@ fun x -> x + constant @> + + let intSumOption = mkNumericSum 0 + let floatSumOption = mkNumericSum 0.0 + let float32SumOption = mkNumericSum 0f let boolSumAtLeastOne = <@ fun (_: AtLeastOne) -> Some true @> @@ -69,7 +112,33 @@ module ArithmeticOperations = let floatSumAtLeastOne = mkNumericSumAtLeastOne 0.0 let float32SumAtLeastOne = mkNumericSumAtLeastOne 0f - let boolMul = + let byteMulOption = + <@ fun (x: byte option) (y: byte option) -> + let mutable res = 0 + + // Converted to int because of Quotations Evaluator issue. + let xInt = + match x with + | Some x -> Some(int x) + | None -> None + + let yInt = + match y with + | Some y -> Some(int y) + | None -> None + + match xInt, yInt with + | Some f, Some s -> res <- f * s + | _ -> () + + let byteRes = byte res + + if byteRes = 0uy then + None + else + Some byteRes @> + + let boolMulOption = <@ fun (x: bool option) (y: bool option) -> let mutable res = false @@ -79,10 +148,15 @@ module ArithmeticOperations = if res then Some true else None @> - let intMul = mkNumericMul 0 - let byteMul = mkNumericMul 0uy - let floatMul = mkNumericMul 0.0 - let float32Mul = mkNumericMul 0f + let inline mulLeftConst zero constant = + mkUnaryOp zero <@ fun x -> constant * x @> + + let inline mulRightConst zero constant = + mkUnaryOp zero <@ fun x -> x * constant @> + + let intMulOption = mkNumericMul 0 + let floatMulOption = mkNumericMul 0.0 + let float32MulOption = mkNumericMul 0f let boolMulAtLeastOne = <@ fun (values: AtLeastOne) -> @@ -98,3 +172,47 @@ module ArithmeticOperations = let byteMulAtLeastOne = mkNumericMulAtLeastOne 0uy let floatMulAtLeastOne = mkNumericMulAtLeastOne 0.0 let float32MulAtLeastOne = mkNumericMulAtLeastOne 0f + + let notOption = + <@ fun x -> + match x with + | Some true -> None + | _ -> Some true @> + + let inline private binOpQ zero op = + <@ fun (left: 'a) (right: 'a) -> + let result = (%op) left right + + if result = zero then + None + else + Some result @> + + let inline private binOp zero op = + fun left right -> + let result = op left right + + if result = zero then + None + else + Some result + + let inline createPair zero op opQ = binOpQ zero opQ, binOp zero op + + // addition + let intAdd = createPair 0 (+) <@ (+) @> + + let boolAdd = createPair false (||) <@ (||) @> + + let floatAdd = createPair 0.0 (+) <@ (+) @> + + let float32Add = createPair 0.0f (+) <@ (+) @> + + // multiplication + let intMul = createPair 0 (*) <@ (*) @> + + let boolMul = createPair true (&&) <@ (&&) @> + + let floatMul = createPair 0.0 (*) <@ (*) @> + + let float32Mul = createPair 0.0f (*) <@ (*) @> diff --git a/src/GraphBLAS-sharp.Backend/Quotes/Convert.fs b/src/GraphBLAS-sharp.Backend/Quotes/Convert.fs index 774b41f2..d779ba5a 100644 --- a/src/GraphBLAS-sharp.Backend/Quotes/Convert.fs +++ b/src/GraphBLAS-sharp.Backend/Quotes/Convert.fs @@ -23,3 +23,11 @@ module Convert = match rightItem with | Some _ -> (%op) leftItem None | None -> (%op) leftItem (Some value) @> + + let map2ToMapLeftNone (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun rightItem -> (%op) None rightItem @> + + let map2ToMapRightNone (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun leftItem -> (%op) leftItem None @> + + let map2ToNoneNone (op: Expr<'a option -> 'b option -> 'c option>) = <@ (%op) None None @> diff --git a/src/GraphBLAS-sharp.Backend/Quotes/Map.fs b/src/GraphBLAS-sharp.Backend/Quotes/Map.fs index 2ec988d5..2f74a7c5 100644 --- a/src/GraphBLAS-sharp.Backend/Quotes/Map.fs +++ b/src/GraphBLAS-sharp.Backend/Quotes/Map.fs @@ -21,3 +21,17 @@ module Map = match (%map) item with | Some _ -> 1 | None -> 0 @> + + let choose2Bitmap<'a, 'b, 'c> (map: Expr<'a -> 'b -> 'c option>) = + <@ fun (leftItem: 'a) (rightItem: 'b) -> + match (%map) leftItem rightItem with + | Some _ -> 1 + | None -> 0 @> + + let inc = <@ fun item -> item + 1 @> + + let subtraction = <@ fun first second -> first - second @> + + let fst () = <@ fun fst _ -> fst @> + + let snd () = <@ fun _ snd -> snd @> diff --git a/src/GraphBLAS-sharp.Backend/Quotes/Predicates.fs b/src/GraphBLAS-sharp.Backend/Quotes/Predicates.fs index ad2c4165..74fda243 100644 --- a/src/GraphBLAS-sharp.Backend/Quotes/Predicates.fs +++ b/src/GraphBLAS-sharp.Backend/Quotes/Predicates.fs @@ -1,8 +1,20 @@ namespace GraphBLAS.FSharp.Backend.Quotes +open Brahma.FSharp + module Predicates = let isSome<'a> = <@ fun (item: 'a option) -> match item with | Some _ -> true | _ -> false @> + + let inline lastOccurrence () = + <@ fun (gid: int) (length: int) (inputArray: ClArray<'a>) -> + gid = length - 1 + || inputArray.[gid] <> inputArray.[gid + 1] @> + + let inline firstOccurrence () = + <@ fun (gid: int) (_: int) (inputArray: ClArray<'a>) -> + gid = 0 + || inputArray.[gid - 1] <> inputArray.[gid] @> diff --git a/src/GraphBLAS-sharp.Backend/Quotes/PreparePositions.fs b/src/GraphBLAS-sharp.Backend/Quotes/PreparePositions.fs index 29459997..d219e7ec 100644 --- a/src/GraphBLAS-sharp.Backend/Quotes/PreparePositions.fs +++ b/src/GraphBLAS-sharp.Backend/Quotes/PreparePositions.fs @@ -27,3 +27,16 @@ module PreparePositions = allValuesBuffer.[index] <- v rawPositionsBuffer.[index] <- 1 | None -> rawPositionsBuffer.[index] <- 0 @> + + let getUniqueBitmapLocal<'a when 'a: equality> = + <@ fun (array: 'a []) length lid (result: int []) -> + if lid < length then + let isFirst = lid = 0 + + let isNotEqualToPrev = array.[lid] <> array.[lid - 1] + let isUnique = lid > 0 && isNotEqualToPrev + + if isFirst || isUnique then + result.[lid] <- 1 + else + result.[lid] <- 0 @> diff --git a/src/GraphBLAS-sharp.Backend/Quotes/Search.fs b/src/GraphBLAS-sharp.Backend/Quotes/Search.fs new file mode 100644 index 00000000..d2ea346a --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Quotes/Search.fs @@ -0,0 +1,188 @@ +namespace GraphBLAS.FSharp.Backend.Quotes + +open Brahma.FSharp + +module Search = + module Bin = + /// + /// Searches a section of the array of indices, bounded by the given left and right edges, for an index, using a binary search algorithm. + /// In case searched section contains source index, the value at the same position in the array of values is returned. + /// + /// + /// Searched section of index array should be sorted in ascending order. + /// The index array should have the same length as the array of values. + /// left edge and right edge should be less than the length of the index array. + /// + let inRange<'a> = + <@ fun leftEdge rightEdge sourceIndex (indices: ClArray) (values: ClArray<'a>) -> + + let mutable leftEdge = leftEdge + let mutable rightEdge = rightEdge + + let mutable result = None + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + + let currentColumn = indices.[middleIdx] + + if sourceIndex = currentColumn then + result <- Some values.[middleIdx] + + rightEdge <- -1 // TODO() break + elif sourceIndex < currentColumn then + rightEdge <- middleIdx - 1 + else + leftEdge <- middleIdx + 1 + + result @> + + /// + /// Searches value in array by key. + /// In case there is a value at the given key position, it is returned. + /// + let byKey<'a> = + <@ fun lenght sourceIndex (keys: ClArray) (values: ClArray<'a>) -> + + let mutable leftEdge = 0 + let mutable rightEdge = lenght - 1 + + let mutable result = None + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + let currentIndex = keys.[middleIdx] + + if sourceIndex = currentIndex then + result <- Some values.[middleIdx] + + rightEdge <- -1 // TODO() break + elif sourceIndex < currentIndex then + rightEdge <- middleIdx - 1 + else + leftEdge <- middleIdx + 1 + + result @> + + /// + /// Searches value in array by two keys. + /// In case there is a value at the given keys position, it is returned. + /// + let byKey2D<'a> = + <@ fun lenght sourceIndex (rowIndices: ClArray) (columnIndices: ClArray) (values: ClArray<'a>) -> + + let mutable leftEdge = 0 + let mutable rightEdge = lenght - 1 + + let mutable result = None + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + + let currentIndex: uint64 = + ((uint64 rowIndices.[middleIdx]) <<< 32) + ||| (uint64 columnIndices.[middleIdx]) + + if sourceIndex = currentIndex then + result <- Some values.[middleIdx] + + rightEdge <- -1 // TODO() break + elif sourceIndex < currentIndex then + rightEdge <- middleIdx - 1 + else + leftEdge <- middleIdx + 1 + + result @> + + /// + /// Find lower position of item in array. + /// + let lowerPosition<'a when 'a: equality and 'a: comparison> = + <@ fun lenght sourceItem (keys: 'a []) -> + + let mutable leftEdge = 0 + let mutable rightEdge = lenght - 1 + + let mutable resultPosition = None + + while leftEdge <= rightEdge do + let currentPosition = (leftEdge + rightEdge) / 2 + let currentKey = keys.[currentPosition] + + if sourceItem = currentKey then + // remember positions and move left + resultPosition <- Some currentPosition + + rightEdge <- currentPosition - 1 + elif sourceItem < currentKey then + rightEdge <- currentPosition - 1 + else + leftEdge <- currentPosition + 1 + + resultPosition @> + + /// + /// lowerBound is a version of binary search: it attempts to find the element value in an ordered range [first, last). + /// Specifically, it returns the last position where value could be inserted without violating the ordering. + /// + /// + /// + /// let array = [ 0; 2; 5; 7; 8; ] + /// + /// lowerBound array 0 // return 1 + /// lowerBound array 1 // return 1 + /// lowerBound array 2 // return 2 + /// lowerBound array 3 // return 2 + /// lowerBound array 8 // return array.Length - 1 + /// lowerBound array 9 // return array.Length - 1 + /// + /// + let lowerBound<'a when 'a: comparison> = + <@ fun lenght sourceItem (keys: ClArray<'a>) -> + + let mutable leftEdge = 0 + let mutable rightEdge = lenght - 1 + + let mutable resultPosition = 0 + + if sourceItem >= keys.[lenght - 1] then + lenght - 1 + else + while leftEdge <= rightEdge do + let currentPosition = (leftEdge + rightEdge) / 2 + let currentKey = keys.[currentPosition] + + if sourceItem < currentKey then + resultPosition <- currentPosition + + rightEdge <- currentPosition - 1 + else + leftEdge <- currentPosition + 1 + + resultPosition @> + + let lowerBoundAndValue<'a when 'a: comparison> = + let defaultValue = Unchecked.defaultof<'a> + + <@ fun lenght sourceItem (keys: ClArray<'a>) -> + + let mutable leftEdge = 0 + let mutable rightEdge = lenght - 1 + + let mutable resultPosition = 0, defaultValue + + if sourceItem >= keys.[lenght - 1] then + (lenght - 1), keys.[lenght - 1] + else + while leftEdge <= rightEdge do + let currentPosition = (leftEdge + rightEdge) / 2 + let currentKey = keys.[currentPosition] + + if sourceItem < currentKey then + resultPosition <- currentPosition, currentKey + + rightEdge <- currentPosition - 1 + else + leftEdge <- currentPosition + 1 + + resultPosition @> diff --git a/src/GraphBLAS-sharp.Backend/Quotes/SubSum.fs b/src/GraphBLAS-sharp.Backend/Quotes/SubSum.fs index c4ed9ec2..1fbcaa0a 100644 --- a/src/GraphBLAS-sharp.Backend/Quotes/SubSum.fs +++ b/src/GraphBLAS-sharp.Backend/Quotes/SubSum.fs @@ -4,7 +4,7 @@ open Brahma.FSharp module SubSum = let private treeAccess<'a> opAdd = - <@ fun step lid wgSize (localBuffer: 'a []) -> + <@ fun step lid _ (localBuffer: 'a []) -> let i = step * (lid + 1) - 1 let firstValue = localBuffer.[i - (step >>> 1)] @@ -31,7 +31,45 @@ module SubSum = barrierLocal () @> - let sequentialSum<'a> opAdd = - sumGeneral<'a> <| sequentialAccess<'a> opAdd + let sequentialSum<'a> = sumGeneral<'a> << sequentialAccess<'a> + + let upSweep<'a> = sumGeneral<'a> << treeAccess<'a> + + let downSweep opAdd = + <@ fun wgSize lid (localBuffer: 'a []) -> + let mutable step = wgSize + + while step > 1 do + barrierLocal () + + if lid < wgSize / step then + let i = step * (lid + 1) - 1 + let j = i - (step >>> 1) + + let tmp = localBuffer.[i] + + let operand = localBuffer.[j] // brahma error + let buff = (%opAdd) tmp operand + + localBuffer.[i] <- buff + localBuffer.[j] <- tmp + + step <- step >>> 1 @> + + let localPrefixSum opAdd = + <@ fun (lid: int) (workGroupSize: int) (array: 'a []) -> + let mutable offset = 1 + + while offset < workGroupSize do + barrierLocal () + let mutable value = array.[lid] + + if lid >= offset then + value <- (%opAdd) value array.[lid - offset] + + offset <- offset * 2 + + barrierLocal () + array.[lid] <- value @> - let treeSum<'a> opAdd = sumGeneral<'a> <| treeAccess<'a> opAdd + let localIntPrefixSum = localPrefixSum <@ (+) @> diff --git a/src/GraphBLAS-sharp.Backend/Vector/DenseVector/DenseVector.fs b/src/GraphBLAS-sharp.Backend/Vector/Dense/Vector.fs similarity index 73% rename from src/GraphBLAS-sharp.Backend/Vector/DenseVector/DenseVector.fs rename to src/GraphBLAS-sharp.Backend/Vector/Dense/Vector.fs index 5e509f9f..53f8de3e 100644 --- a/src/GraphBLAS-sharp.Backend/Vector/DenseVector/DenseVector.fs +++ b/src/GraphBLAS-sharp.Backend/Vector/Dense/Vector.fs @@ -4,20 +4,19 @@ open Brahma.FSharp open GraphBLAS.FSharp.Backend.Common open GraphBLAS.FSharp.Backend.Quotes open Microsoft.FSharp.Quotations -open GraphBLAS.FSharp.Backend.Predefined open GraphBLAS.FSharp.Backend.Objects.ClVector open GraphBLAS.FSharp.Backend.Objects.ClContext open GraphBLAS.FSharp.Backend.Objects.ClCell -module DenseVector = - let map2Inplace<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> - (clContext: ClContext) +module Vector = + let map2InPlace<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> (opAdd: Expr<'a option -> 'b option -> 'c option>) + (clContext: ClContext) workGroupSize = let map2InPlace = - ClArray.map2Inplace clContext workGroupSize opAdd + ClArray.map2InPlace opAdd clContext workGroupSize fun (processor: MailboxProcessor<_>) (leftVector: ClArray<'a option>) (rightVector: ClArray<'b option>) (resultVector: ClArray<'c option>) -> @@ -25,25 +24,25 @@ module DenseVector = let map2<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> - (clContext: ClContext) (opAdd: Expr<'a option -> 'b option -> 'c option>) + (clContext: ClContext) workGroupSize = let map2 = - ClArray.map2 clContext workGroupSize opAdd + ClArray.map2 opAdd clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClArray<'a option>) (rightVector: ClArray<'b option>) -> map2 processor allocationMode leftVector rightVector - let map2AtLeastOne clContext op workGroupSize = - map2 clContext (Convert.atLeastOneToOption op) workGroupSize + let map2AtLeastOne op clContext workGroupSize = + map2 (Convert.atLeastOneToOption op) clContext workGroupSize - let assignByMaskInplace<'a, 'b when 'a: struct and 'b: struct> - (clContext: ClContext) + let assignByMaskInPlace<'a, 'b when 'a: struct and 'b: struct> (maskOp: Expr<'a option -> 'b option -> 'a -> 'a option>) + (clContext: ClContext) workGroupSize = @@ -72,13 +71,13 @@ module DenseVector = processor.Post(Msg.CreateRunMsg<_, _>(kernel)) let assignByMask<'a, 'b when 'a: struct and 'b: struct> - (clContext: ClContext) (maskOp: Expr<'a option -> 'b option -> 'a -> 'a option>) + (clContext: ClContext) workGroupSize = let assignByMask = - assignByMaskInplace clContext maskOp workGroupSize + assignByMaskInPlace maskOp clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClArray<'a option>) (maskVector: ClArray<'b option>) (value: ClCell<'a>) -> let resultVector = @@ -91,24 +90,22 @@ module DenseVector = let toSparse<'a when 'a: struct> (clContext: ClContext) workGroupSize = let scatterValues = - Scatter.runInplace clContext workGroupSize + Scatter.lastOccurrence clContext workGroupSize let scatterIndices = - Scatter.runInplace clContext workGroupSize + Scatter.lastOccurrence clContext workGroupSize let getBitmap = - ClArray.map clContext workGroupSize - <| Map.option 1 0 + ClArray.map (Map.option 1 0) clContext workGroupSize let prefixSum = - PrefixSum.standardExcludeInplace clContext workGroupSize + PrefixSum.standardExcludeInPlace clContext workGroupSize let allIndices = - ClArray.init clContext workGroupSize Map.id + ClArray.init Map.id clContext workGroupSize let allValues = - ClArray.map clContext workGroupSize - <| Map.optionToValueOrZero Unchecked.defaultof<'a> + ClArray.map (Map.optionToValueOrZero Unchecked.defaultof<'a>) clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (vector: ClArray<'a option>) -> @@ -146,31 +143,21 @@ module DenseVector = Values = resultValues Size = vector.Length } - let reduce<'a when 'a: struct> (clContext: ClContext) workGroupSize (opAdd: Expr<'a -> 'a -> 'a>) = + let reduce<'a when 'a: struct> (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = let choose = - ClArray.choose clContext workGroupSize Map.id + ClArray.choose Map.id clContext workGroupSize let reduce = - Reduce.reduce clContext workGroupSize opAdd - - let containsNonZero = - ClArray.exists clContext workGroupSize Predicates.isSome + Reduce.reduce opAdd clContext workGroupSize fun (processor: MailboxProcessor<_>) (vector: ClArray<'a option>) -> + choose processor DeviceOnly vector + |> function + | Some values -> + let result = reduce processor values - let notEmpty = - (containsNonZero processor vector) - .ToHostAndFree processor - - if notEmpty then - let values = choose processor DeviceOnly vector - - let result = reduce processor values - - processor.Post(Msg.CreateFreeMsg<_>(values)) - - result + processor.Post(Msg.CreateFreeMsg<_>(values)) - else - clContext.CreateClCell Unchecked.defaultof<'a> + result + | None -> clContext.CreateClCell Unchecked.defaultof<'a> diff --git a/src/GraphBLAS-sharp.Backend/Vector/SpMV.fs b/src/GraphBLAS-sharp.Backend/Vector/SpMV.fs index 4de83189..46895b0c 100644 --- a/src/GraphBLAS-sharp.Backend/Vector/SpMV.fs +++ b/src/GraphBLAS-sharp.Backend/Vector/SpMV.fs @@ -8,9 +8,9 @@ open GraphBLAS.FSharp.Backend.Objects.ClContext module SpMV = let runTo - (clContext: ClContext) (add: Expr<'c option -> 'c option -> 'c option>) (mul: Expr<'a option -> 'b option -> 'c option>) + (clContext: ClContext) workGroupSize = @@ -144,12 +144,12 @@ module SpMV = queue.Post(Msg.CreateFreeMsg intermediateArray) let run - (clContext: ClContext) (add: Expr<'c option -> 'c option -> 'c option>) (mul: Expr<'a option -> 'b option -> 'c option>) + (clContext: ClContext) workGroupSize = - let runTo = runTo clContext add mul workGroupSize + let runTo = runTo add mul clContext workGroupSize fun (queue: MailboxProcessor<_>) allocationMode (matrix: ClMatrix.CSR<'a>) (vector: ClArray<'b option>) -> diff --git a/src/GraphBLAS-sharp.Backend/Vector/Sparse/Common.fs b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Common.fs new file mode 100644 index 00000000..cb6a8971 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Common.fs @@ -0,0 +1,100 @@ +namespace GraphBLAS.FSharp.Backend.Vector.Sparse + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Objects.ClVector +open Microsoft.FSharp.Control +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ClCell + +module internal Common = + let setPositions<'a when 'a: struct> (clContext: ClContext) workGroupSize = + + let sum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + let valuesScatter = + Scatter.lastOccurrence clContext workGroupSize + + let indicesScatter = + Scatter.lastOccurrence clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (allValues: ClArray<'a>) (allIndices: ClArray) (positions: ClArray) -> + + let resultLength = + (sum processor positions).ToHostAndFree(processor) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'a>(allocationMode, resultLength) + + let resultIndices = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + valuesScatter processor positions allValues resultValues + + indicesScatter processor positions allIndices resultIndices + + resultValues, resultIndices + + let setPositionsOption<'a when 'a: struct> (clContext: ClContext) workGroupSize = + + let sum = + PrefixSum.standardExcludeInPlace clContext workGroupSize + + let valuesScatter = + Scatter.lastOccurrence clContext workGroupSize + + let indicesScatter = + Scatter.lastOccurrence clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (allValues: ClArray<'a>) (allIndices: ClArray) (positions: ClArray) -> + + let resultLength = + (sum processor positions).ToHostAndFree(processor) + + if resultLength = 0 then + None + else + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'a>(allocationMode, resultLength) + + let resultIndices = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) + + valuesScatter processor positions allValues resultValues + + indicesScatter processor positions allIndices resultIndices + + (resultValues, resultIndices) |> Some + + let concat (clContext: ClContext) workGroupSize = + + let concatValues = ClArray.concat clContext workGroupSize + + let concatIndices = ClArray.concat clContext workGroupSize + + let mapIndices = + ClArray.mapWithValue clContext workGroupSize <@ fun x y -> x + y @> + + fun (processor: MailboxProcessor<_>) allocationMode (vectors: Sparse<'a> seq) -> + + let vectorIndices, _ = + vectors + |> Seq.mapFold + (fun offset vector -> + let newIndices = + mapIndices processor allocationMode offset vector.Indices + + newIndices, offset + vector.Size) + 0 + + let vectorValues = + vectors |> Seq.map (fun vector -> vector.Values) + + let resultIndices = + concatIndices processor allocationMode vectorIndices + + let resultValues = + concatValues processor allocationMode vectorValues + + resultIndices, resultValues diff --git a/src/GraphBLAS-sharp.Backend/Vector/Sparse/Map.fs b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Map.fs new file mode 100644 index 00000000..3d804101 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Map.fs @@ -0,0 +1,122 @@ +namespace GraphBLAS.FSharp.Backend.Vector.Sparse + +open FSharp.Quotations.Evaluator.QuotationEvaluationExtensions +open Microsoft.FSharp.Quotations +open Brahma.FSharp +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Vector.Sparse +open GraphBLAS.FSharp.Backend.Objects.ClVector +open GraphBLAS.FSharp.Backend.Common.ClArray +open GraphBLAS.FSharp.Backend.Objects.ClCell +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +module Map = + module WithValueOption = + let preparePositions<'a, 'b, 'c> opAdd (clContext: ClContext) workGroupSize = + + let preparePositions (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun (ndRange: Range1D) (operand: ClCell<'a option>) size valuesLength (indices: ClArray) (values: ClArray<'b>) (resultIndices: ClArray) (resultValues: ClArray<'c>) (resultBitmap: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < size then + + let value = + (%Search.Bin.byKey) valuesLength gid indices values + + match (%op) operand.Value value with + | Some resultValue -> + resultValues.[gid] <- resultValue + resultIndices.[gid] <- gid + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = + clContext.Compile <| preparePositions opAdd + + fun (processor: MailboxProcessor<_>) (value: ClCell<'a option>) (vector: Sparse<'b>) -> + + let resultBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vector.Size) + + let resultIndices = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vector.Size) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, vector.Size) + + let ndRange = + Range1D.CreateValid(vector.Size, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + value + vector.Size + vector.Values.Length + vector.Indices + vector.Values + resultIndices + resultValues + resultBitmap) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + resultIndices, resultValues, resultBitmap + + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> + (clContext: ClContext) + workGroupSize + (op: Expr<'a option -> 'b option -> 'c option>) + = + + let map = + preparePositions op clContext workGroupSize + + let opOnHost = op.Evaluate() + + let setPositions = + Common.setPositionsOption<'c> clContext workGroupSize + + let create = create clContext workGroupSize + + let init = init <@ id @> clContext workGroupSize + + fun (queue: MailboxProcessor<_>) allocationMode (value: 'a option) size -> + function + | Some vector -> + let valueClCell = clContext.CreateClCell value + + let indices, values, bitmap = map queue valueClCell vector + + valueClCell.Free queue + + let result = + setPositions queue allocationMode values indices bitmap + + indices.Free queue + values.Free queue + bitmap.Free queue + + result + |> Option.map + (fun (resultValues, resultIndices) -> + { Context = clContext + Size = size + Indices = resultIndices + Values = resultValues }) + | None -> + opOnHost value None + |> Option.map + (fun resultValue -> + { Context = clContext + Size = size + Indices = init queue allocationMode size + Values = create queue allocationMode size resultValue }) diff --git a/src/GraphBLAS-sharp.Backend/Vector/Sparse/Map2.fs b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Map2.fs new file mode 100644 index 00000000..1b8ef660 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Map2.fs @@ -0,0 +1,306 @@ +namespace GraphBLAS.FSharp.Backend.Vector.Sparse + +open Brahma.FSharp +open FSharp.Quotations +open Microsoft.FSharp.Control +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClVector +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Quotes + +module internal Map2 = + let private preparePositions<'a, 'b, 'c> opAdd (clContext: ClContext) workGroupSize = + + let preparePositions (op: Expr<'a option -> 'b option -> 'c option>) = + <@ fun (ndRange: Range1D) length leftValuesLength rightValuesLength (leftValues: ClArray<'a>) (leftIndices: ClArray) (rightValues: ClArray<'b>) (rightIndices: ClArray) (resultBitmap: ClArray) (resultValues: ClArray<'c>) (resultIndices: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < length then + + let (leftValue: 'a option) = + (%Search.Bin.byKey) leftValuesLength gid leftIndices leftValues + + let (rightValue: 'b option) = + (%Search.Bin.byKey) rightValuesLength gid rightIndices rightValues + + match (%op) leftValue rightValue with + | Some value -> + resultValues.[gid] <- value + resultIndices.[gid] <- gid + + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = + clContext.Compile <| preparePositions opAdd + + fun (processor: MailboxProcessor<_>) (vectorLenght: int) (leftValues: ClArray<'a>) (leftIndices: ClArray) (rightValues: ClArray<'b>) (rightIndices: ClArray) -> + + let resultBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vectorLenght) + + let resultIndices = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vectorLenght) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, vectorLenght) + + let ndRange = + Range1D.CreateValid(vectorLenght, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + vectorLenght + leftValues.Length + rightValues.Length + leftValues + leftIndices + rightValues + rightIndices + resultBitmap + resultValues + resultIndices) + ) + + processor.Post(Msg.CreateRunMsg<_, _> kernel) + + resultBitmap, resultValues, resultIndices + + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> op (clContext: ClContext) workGroupSize = + + let prepare = + preparePositions<'a, 'b, 'c> op clContext workGroupSize + + let setPositions = + Common.setPositions clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector.Sparse<'a>) (rightVector: ClVector.Sparse<'b>) -> + + let bitmap, allValues, allIndices = + prepare + processor + leftVector.Size + leftVector.Values + leftVector.Indices + rightVector.Values + rightVector.Indices + + let resultValues, resultIndices = + setPositions processor allocationMode allValues allIndices bitmap + + processor.Post(Msg.CreateFreeMsg<_>(allIndices)) + processor.Post(Msg.CreateFreeMsg<_>(allValues)) + processor.Post(Msg.CreateFreeMsg<_>(bitmap)) + + { Context = clContext + Values = resultValues + Indices = resultIndices + Size = max leftVector.Size rightVector.Size } + + let private preparePositionsAssignByMask<'a, 'b when 'a: struct and 'b: struct> + op + (clContext: ClContext) + workGroupSize + = + + let assign op = + <@ fun (ndRange: Range1D) length leftValuesLength rightValuesLength (leftValues: ClArray<'a>) (leftIndices: ClArray) (rightValues: ClArray<'b>) (rightIndices: ClArray) (value: ClCell<'a>) (resultBitmap: ClArray) (resultValues: ClArray<'c>) (resultIndices: ClArray) -> + + let gid = ndRange.GlobalID0 + + let value = value.Value + + if gid < length then + + let (leftValue: 'a option) = + (%Search.Bin.byKey) leftValuesLength gid leftIndices leftValues + + let (rightValue: 'b option) = + (%Search.Bin.byKey) rightValuesLength gid rightIndices rightValues + + match (%op) leftValue rightValue value with + | Some value -> + resultValues.[gid] <- value + resultIndices.[gid] <- gid + + resultBitmap.[gid] <- 1 + | None -> resultBitmap.[gid] <- 0 @> + + let kernel = clContext.Compile <| assign op + + fun (processor: MailboxProcessor<_>) (vectorLenght: int) (leftValues: ClArray<'a>) (leftIndices: ClArray) (rightValues: ClArray<'b>) (rightIndices: ClArray) (value: ClCell<'a>) -> + + let resultBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vectorLenght) + + let resultIndices = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vectorLenght) + + let resultValues = + clContext.CreateClArrayWithSpecificAllocationMode<'a>(DeviceOnly, vectorLenght) + + let ndRange = + Range1D.CreateValid(vectorLenght, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + vectorLenght + leftValues.Length + rightValues.Length + leftValues + leftIndices + rightValues + rightIndices + value + resultBitmap + resultValues + resultIndices) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + resultBitmap, resultValues, resultIndices + + ///. + ///. + ///Should be a power of 2 and greater than 1. + let assignByMask<'a, 'b when 'a: struct and 'b: struct> op (clContext: ClContext) workGroupSize = + + let prepare = + preparePositionsAssignByMask op clContext workGroupSize + + let setPositions = + Common.setPositions clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector.Sparse<'a>) (rightVector: ClVector.Sparse<'b>) (value: ClCell<'a>) -> + + let bitmap, values, indices = + prepare + processor + leftVector.Size + leftVector.Values + leftVector.Indices + rightVector.Values + rightVector.Indices + value + + let resultValues, resultIndices = + setPositions processor allocationMode values indices bitmap + + processor.Post(Msg.CreateFreeMsg<_>(indices)) + processor.Post(Msg.CreateFreeMsg<_>(values)) + processor.Post(Msg.CreateFreeMsg<_>(bitmap)) + + { Context = clContext + Values = resultValues + Indices = resultIndices + Size = rightVector.Size } + + module AtLeastOne = + let private preparePositions<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> + op + (clContext: ClContext) + workGroupSize + = + + let preparePositions opAdd = + <@ fun (ndRange: Range1D) length (allIndices: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isLeft: ClArray) (allValues: ClArray<'c>) (positions: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < length - 1 + && allIndices.[gid] = allIndices.[gid + 1] then + let result = + (%opAdd) (Some leftValues.[gid]) (Some rightValues.[gid + 1]) + + (%PreparePositions.both) gid result positions allValues + elif (gid < length + && gid > 0 + && allIndices.[gid - 1] <> allIndices.[gid]) + || gid = 0 then + let leftResult = (%opAdd) (Some leftValues.[gid]) None + let rightResult = (%opAdd) None (Some rightValues.[gid]) + + (%PreparePositions.leftRight) gid leftResult rightResult isLeft allValues positions @> + + let kernel = clContext.Compile <| preparePositions op + + fun (processor: MailboxProcessor<_>) (allIndices: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isLeft: ClArray) -> + + let length = allIndices.Length + + let allValues = + clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, length) + + let positions = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, length) + + let ndRange = + Range1D.CreateValid(length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + length + allIndices + leftValues + rightValues + isLeft + allValues + positions) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + allValues, positions + + ///. + ///. + ///Should be a power of 2 and greater than 1. + let run<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> op (clContext: ClContext) workGroupSize = + + let merge = Merge.run clContext workGroupSize + + let prepare = + preparePositions<'a, 'b, 'c> op clContext workGroupSize + + let setPositions = + Common.setPositions clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector.Sparse<'a>) (rightVector: ClVector.Sparse<'b>) -> + + let allIndices, leftValues, rightValues, isLeft = merge processor leftVector rightVector + + let allValues, positions = + prepare processor allIndices leftValues rightValues isLeft + + processor.Post(Msg.CreateFreeMsg<_>(leftValues)) + processor.Post(Msg.CreateFreeMsg<_>(rightValues)) + processor.Post(Msg.CreateFreeMsg<_>(isLeft)) + + let resultValues, resultIndices = + setPositions processor allocationMode allValues allIndices positions + + processor.Post(Msg.CreateFreeMsg<_>(allIndices)) + processor.Post(Msg.CreateFreeMsg<_>(allValues)) + processor.Post(Msg.CreateFreeMsg<_>(positions)) + + { Context = clContext + Values = resultValues + Indices = resultIndices + Size = max leftVector.Size rightVector.Size } diff --git a/src/GraphBLAS-sharp.Backend/Vector/Sparse/Merge.fs b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Merge.fs new file mode 100644 index 00000000..459ab6d5 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Merge.fs @@ -0,0 +1,167 @@ +namespace GraphBLAS.FSharp.Backend.Vector.Sparse + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClContext + +module internal Merge = + let run<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) workGroupSize = + + let merge = + <@ fun (ndRange: Range1D) (firstSide: int) (secondSide: int) (sumOfSides: int) (firstIndicesBuffer: ClArray) (firstValuesBuffer: ClArray<'a>) (secondIndicesBuffer: ClArray) (secondValuesBuffer: ClArray<'b>) (allIndicesBuffer: ClArray) (firstResultValues: ClArray<'a>) (secondResultValues: ClArray<'b>) (isLeftBitMap: ClArray) -> + + let gid = ndRange.GlobalID0 + let lid = ndRange.LocalID0 + + let mutable beginIdxLocal = local () + let mutable endIdxLocal = local () + + if lid < 2 then + // (n - 1) * wgSize - 1 for lid = 0 + // n * wgSize - 1 for lid = 1 + // where n in 1 .. wgGroupCount + let x = lid * (workGroupSize - 1) + gid - 1 + + let diagonalNumber = min (sumOfSides - 1) x + + let mutable leftEdge = max 0 (diagonalNumber + 1 - secondSide) + + let mutable rightEdge = min (firstSide - 1) diagonalNumber + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + + let firstIndex = firstIndicesBuffer.[middleIdx] + + let secondIndex = + secondIndicesBuffer.[diagonalNumber - middleIdx] + + if firstIndex <= secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 + + // Here localID equals either 0 or 1 + if lid = 0 then + beginIdxLocal <- leftEdge + else + endIdxLocal <- leftEdge + + barrierLocal () + + let beginIdx = beginIdxLocal + let endIdx = endIdxLocal + let firstLocalLength = endIdx - beginIdx + let mutable x = workGroupSize - firstLocalLength + + if endIdx = firstSide then + x <- secondSide - gid + lid + beginIdx + + let secondLocalLength = x + + //First indices are from 0 to firstLocalLength - 1 inclusive + //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive + let localIndices = localArray workGroupSize + + if lid < firstLocalLength then + localIndices.[lid] <- firstIndicesBuffer.[beginIdx + lid] + + if lid < secondLocalLength then + localIndices.[firstLocalLength + lid] <- secondIndicesBuffer.[gid - beginIdx] + + barrierLocal () + + if gid < sumOfSides then + let mutable leftEdge = lid + 1 - secondLocalLength + if leftEdge < 0 then leftEdge <- 0 + + let mutable rightEdge = firstLocalLength - 1 + + rightEdge <- min rightEdge lid + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + let firstIndex = localIndices.[middleIdx] + + let secondIndex = + localIndices.[firstLocalLength + lid - middleIdx] + + if firstIndex <= secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 + + let boundaryX = rightEdge + let boundaryY = lid - leftEdge + + // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) + let isValidX = boundaryX >= 0 + let isValidY = boundaryY >= 0 + + let mutable fstIdx = 0 + + if isValidX then + fstIdx <- localIndices.[boundaryX] + + let mutable sndIdx = 0 + + if isValidY then + sndIdx <- localIndices.[firstLocalLength + boundaryY] + + if not isValidX || isValidY && fstIdx <= sndIdx then + allIndicesBuffer.[gid] <- sndIdx + secondResultValues.[gid] <- secondValuesBuffer.[gid - lid - beginIdx + boundaryY] + isLeftBitMap.[gid] <- 0 + else + allIndicesBuffer.[gid] <- fstIdx + firstResultValues.[gid] <- firstValuesBuffer.[beginIdx + boundaryX] + isLeftBitMap.[gid] <- 1 @> + + let kernel = clContext.Compile merge + + fun (processor: MailboxProcessor<_>) (firstVector: ClVector.Sparse<'a>) (secondVector: ClVector.Sparse<'b>) -> + + let firstSide = firstVector.Indices.Length + + let secondSide = secondVector.Indices.Length + + let sumOfSides = firstSide + secondSide + + let allIndices = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) + + let firstValues = + clContext.CreateClArrayWithSpecificAllocationMode<'a>(DeviceOnly, sumOfSides) + + let secondValues = + clContext.CreateClArrayWithSpecificAllocationMode<'b>(DeviceOnly, sumOfSides) + + let isLeftBitmap = + clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) + + let ndRange = + Range1D.CreateValid(sumOfSides, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + firstSide + secondSide + sumOfSides + firstVector.Indices + firstVector.Values + secondVector.Indices + secondVector.Values + allIndices + firstValues + secondValues + isLeftBitmap) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + allIndices, firstValues, secondValues, isLeftBitmap diff --git a/src/GraphBLAS-sharp.Backend/Vector/Sparse/Vector.fs b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Vector.fs new file mode 100644 index 00000000..5b3594ae --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Vector.fs @@ -0,0 +1,73 @@ +namespace GraphBLAS.FSharp.Backend.Vector.Sparse + +open Brahma.FSharp +open Microsoft.FSharp.Control +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClVector +open GraphBLAS.FSharp.Backend.Vector.Sparse + +module Vector = + let copy (clContext: ClContext) workGroupSize = + let copy = ClArray.copy clContext workGroupSize + + let copyData = ClArray.copy clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (vector: Sparse<'a>) -> + { Context = clContext + Indices = copy processor allocationMode vector.Indices + Values = copyData processor allocationMode vector.Values + Size = vector.Size } + + let mapWithValue = Map.WithValueOption.run + + let map2 = Map2.run + + let map2AtLeastOne opAdd (clContext: ClContext) workGroupSize allocationMode = + Map2.AtLeastOne.run (Convert.atLeastOneToOption opAdd) clContext workGroupSize allocationMode + + let assignByMask = Map2.assignByMask + + let toDense (clContext: ClContext) workGroupSize = + + let toDense = + <@ fun (ndRange: Range1D) length (values: ClArray<'a>) (indices: ClArray) (resultArray: ClArray<'a option>) -> + let gid = ndRange.GlobalID0 + + if gid < length then + let index = indices.[gid] + + resultArray.[index] <- Some values.[gid] @> + + let kernel = clContext.Compile(toDense) + + let create = + ClArray.zeroCreate clContext workGroupSize + + fun (processor: MailboxProcessor<_>) allocationMode (vector: ClVector.Sparse<'a>) -> + let resultVector = + create processor allocationMode vector.Size + + let ndRange = + Range1D.CreateValid(vector.Indices.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc ndRange vector.Indices.Length vector.Values vector.Indices resultVector) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + resultVector + + let reduce<'a when 'a: struct> (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = + + let reduce = + Reduce.reduce opAdd clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (vector: ClVector.Sparse<'a>) -> reduce processor vector.Values diff --git a/src/GraphBLAS-sharp.Backend/Vector/SparseVector/Map2.fs b/src/GraphBLAS-sharp.Backend/Vector/SparseVector/Map2.fs deleted file mode 100644 index d1d2e315..00000000 --- a/src/GraphBLAS-sharp.Backend/Vector/SparseVector/Map2.fs +++ /dev/null @@ -1,202 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.Vector.Sparse - -open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Quotes -open FSharp.Quotations - -module Map2 = - let binSearch<'a> = - <@ fun lenght sourceIndex (indices: ClArray) (values: ClArray<'a>) -> - - let mutable leftEdge = 0 - let mutable rightEdge = lenght - 1 - - let mutable result = None - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let currentIndex = indices.[middleIdx] - - if sourceIndex = currentIndex then - result <- Some values.[middleIdx] - - rightEdge <- -1 // TODO() break - elif sourceIndex < currentIndex then - rightEdge <- middleIdx - 1 - else - leftEdge <- middleIdx + 1 - - result @> - - let preparePositionsGeneral (op: Expr<'a option -> 'b option -> 'c option>) = - <@ fun (ndRange: Range1D) length leftValuesLength rightValuesLength (leftValues: ClArray<'a>) (leftIndices: ClArray) (rightValues: ClArray<'b>) (rightIndices: ClArray) (resultBitmap: ClArray) (resultValues: ClArray<'c>) (resultIndices: ClArray) -> - - let gid = ndRange.GlobalID0 - - if gid < length then - - let (leftValue: 'a option) = - (%binSearch) leftValuesLength gid leftIndices leftValues - - let (rightValue: 'b option) = - (%binSearch) rightValuesLength gid rightIndices rightValues - - match (%op) leftValue rightValue with - | Some value -> - resultValues.[gid] <- value - resultIndices.[gid] <- gid - - resultBitmap.[gid] <- 1 - | None -> resultBitmap.[gid] <- 0 @> - - let prepareAssign op = - <@ fun (ndRange: Range1D) length leftValuesLength rightValuesLength (leftValues: ClArray<'a>) (leftIndices: ClArray) (rightValues: ClArray<'b>) (rightIndices: ClArray) (value: ClCell<'a>) (resultBitmap: ClArray) (resultValues: ClArray<'c>) (resultIndices: ClArray) -> - - let gid = ndRange.GlobalID0 - - let value = value.Value - - if gid < length then - - let (leftValue: 'a option) = - (%binSearch) leftValuesLength gid leftIndices leftValues - - let (rightValue: 'b option) = - (%binSearch) rightValuesLength gid rightIndices rightValues - - match (%op) leftValue rightValue value with - | Some value -> - resultValues.[gid] <- value - resultIndices.[gid] <- gid - - resultBitmap.[gid] <- 1 - | None -> resultBitmap.[gid] <- 0 @> - - let merge workGroupSize = - <@ fun (ndRange: Range1D) (firstSide: int) (secondSide: int) (sumOfSides: int) (firstIndicesBuffer: ClArray) (firstValuesBuffer: ClArray<'a>) (secondIndicesBuffer: ClArray) (secondValuesBuffer: ClArray<'b>) (allIndicesBuffer: ClArray) (firstResultValues: ClArray<'a>) (secondResultValues: ClArray<'b>) (isLeftBitMap: ClArray) -> - - let i = ndRange.GlobalID0 - - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 - - if localID < 2 then - let x = localID * (workGroupSize - 1) + i - 1 - - let diagonalNumber = min (sumOfSides - 1) x - - let mutable leftEdge = diagonalNumber + 1 - secondSide - leftEdge <- max 0 leftEdge - - let mutable rightEdge = firstSide - 1 - - rightEdge <- min rightEdge diagonalNumber - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = firstIndicesBuffer.[middleIdx] - - let secondIndex = - secondIndicesBuffer.[diagonalNumber - middleIdx] - - if firstIndex <= secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge - - barrierLocal () - - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength - - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx - - let secondLocalLength = x - - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize - - if localID < firstLocalLength then - localIndices.[localID] <- firstIndicesBuffer.[beginIdx + localID] - - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- secondIndicesBuffer.[i - beginIdx] - - barrierLocal () - - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstLocalLength - 1 - - rightEdge <- min rightEdge localID - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] - - let secondIndex = - localIndices.[firstLocalLength + localID - middleIdx] - - if firstIndex <= secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - let boundaryX = rightEdge - let boundaryY = localID - leftEdge - - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 - - let mutable fstIdx = 0 - - if isValidX then - fstIdx <- localIndices.[boundaryX] - - let mutable sndIdx = 0 - - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] - - if not isValidX || isValidY && fstIdx <= sndIdx then - allIndicesBuffer.[i] <- sndIdx - secondResultValues.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] - isLeftBitMap.[i] <- 0 - else - allIndicesBuffer.[i] <- fstIdx - firstResultValues.[i] <- firstValuesBuffer.[beginIdx + boundaryX] - isLeftBitMap.[i] <- 1 @> - - let preparePositions opAdd = - <@ fun (ndRange: Range1D) length (allIndices: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isLeft: ClArray) (allValues: ClArray<'c>) (positions: ClArray) -> - - let gid = ndRange.GlobalID0 - - if gid < length - 1 - && allIndices.[gid] = allIndices.[gid + 1] then - let result = - (%opAdd) (Some leftValues.[gid]) (Some rightValues.[gid + 1]) - - (%PreparePositions.both) gid result positions allValues - elif (gid < length - && gid > 0 - && allIndices.[gid - 1] <> allIndices.[gid]) - || gid = 0 then - let leftResult = (%opAdd) (Some leftValues.[gid]) None - let rightResult = (%opAdd) None (Some rightValues.[gid]) - - (%PreparePositions.leftRight) gid leftResult rightResult isLeft allValues positions @> diff --git a/src/GraphBLAS-sharp.Backend/Vector/SparseVector/SparseVector.fs b/src/GraphBLAS-sharp.Backend/Vector/SparseVector/SparseVector.fs deleted file mode 100644 index bb3bdbf4..00000000 --- a/src/GraphBLAS-sharp.Backend/Vector/SparseVector/SparseVector.fs +++ /dev/null @@ -1,364 +0,0 @@ -namespace GraphBLAS.FSharp.Backend.Vector.Sparse - -open Brahma.FSharp -open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.Quotes -open Microsoft.FSharp.Control -open Microsoft.FSharp.Quotations -open GraphBLAS.FSharp.Backend.Predefined -open GraphBLAS.FSharp.Backend.Objects -open GraphBLAS.FSharp.Backend.Objects.ClVector -open GraphBLAS.FSharp.Backend.Objects.ClContext -open GraphBLAS.FSharp.Backend.Objects.ClCell - -module SparseVector = - - let private setPositions<'a when 'a: struct> (clContext: ClContext) workGroupSize = - - let sum = - PrefixSum.standardExcludeInplace clContext workGroupSize - - let valuesScatter = - Scatter.runInplace clContext workGroupSize - - let indicesScatter = - Scatter.runInplace clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (allValues: ClArray<'a>) (allIndices: ClArray) (positions: ClArray) -> - - let resultLength = - (sum processor positions).ToHostAndFree(processor) - - let resultValues = - clContext.CreateClArrayWithSpecificAllocationMode<'a>(allocationMode, resultLength) - - let resultIndices = - clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, resultLength) - - valuesScatter processor positions allValues resultValues - - indicesScatter processor positions allIndices resultIndices - - resultValues, resultIndices - - - let preparePositionsGeneral<'a, 'b, 'c> (clContext: ClContext) workGroupSize opAdd = - - let kernel = - clContext.Compile - <| Map2.preparePositionsGeneral opAdd - - fun (processor: MailboxProcessor<_>) (vectorLenght: int) (leftValues: ClArray<'a>) (leftIndices: ClArray) (rightValues: ClArray<'b>) (rightIndices: ClArray) -> - - let resultBitmap = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vectorLenght) - - let resultIndices = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vectorLenght) - - let resultValues = - clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, vectorLenght) - - let ndRange = - Range1D.CreateValid(vectorLenght, workGroupSize) - - let kernel = kernel.GetKernel() - - processor.Post( - Msg.MsgSetArguments - (fun () -> - kernel.KernelFunc - ndRange - vectorLenght - leftValues.Length - rightValues.Length - leftValues - leftIndices - rightValues - rightIndices - resultBitmap - resultValues - resultIndices) - ) - - processor.Post(Msg.CreateRunMsg<_, _> kernel) - - resultBitmap, resultValues, resultIndices - - let map2General<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> (clContext: ClContext) op workGroupSize = - - let prepare = - preparePositionsGeneral<'a, 'b, 'c> clContext workGroupSize op - - let setPositions = setPositions clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector.Sparse<'a>) (rightVector: ClVector.Sparse<'b>) -> - - let bitmap, allValues, allIndices = - prepare - processor - leftVector.Size - leftVector.Values - leftVector.Indices - rightVector.Values - rightVector.Indices - - let resultValues, resultIndices = - setPositions processor allocationMode allValues allIndices bitmap - - processor.Post(Msg.CreateFreeMsg<_>(allIndices)) - processor.Post(Msg.CreateFreeMsg<_>(allValues)) - processor.Post(Msg.CreateFreeMsg<_>(bitmap)) - - { Context = clContext - Values = resultValues - Indices = resultIndices - Size = max leftVector.Size rightVector.Size } - - let private merge<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) workGroupSize = - - let kernel = - clContext.Compile(Map2.merge workGroupSize) - - fun (processor: MailboxProcessor<_>) (firstIndices: ClArray) (firstValues: ClArray<'a>) (secondIndices: ClArray) (secondValues: ClArray<'b>) -> - - let firstSide = firstIndices.Length - - let secondSide = secondIndices.Length - - let sumOfSides = - firstIndices.Length + secondIndices.Length - - let allIndices = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) - - let firstResultValues = - clContext.CreateClArrayWithSpecificAllocationMode<'a>(DeviceOnly, sumOfSides) - - let secondResultValues = - clContext.CreateClArrayWithSpecificAllocationMode<'b>(DeviceOnly, sumOfSides) - - let isLeftBitmap = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, sumOfSides) - - let ndRange = - Range1D.CreateValid(sumOfSides, workGroupSize) - - let kernel = kernel.GetKernel() - - processor.Post( - Msg.MsgSetArguments - (fun () -> - kernel.KernelFunc - ndRange - firstSide - secondSide - sumOfSides - firstIndices - firstValues - secondIndices - secondValues - allIndices - firstResultValues - secondResultValues - isLeftBitmap) - ) - - processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - - allIndices, firstResultValues, secondResultValues, isLeftBitmap - - let private preparePositions<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> - (clContext: ClContext) - op - workGroupSize - = - - let kernel = - clContext.Compile(Map2.preparePositions op) - - fun (processor: MailboxProcessor<_>) (allIndices: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isLeft: ClArray) -> - - let length = allIndices.Length - - let allValues = - clContext.CreateClArrayWithSpecificAllocationMode<'c>(DeviceOnly, length) - - let positions = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, length) - - let ndRange = - Range1D.CreateValid(length, workGroupSize) - - let kernel = kernel.GetKernel() - - processor.Post( - Msg.MsgSetArguments - (fun () -> - kernel.KernelFunc ndRange length allIndices leftValues rightValues isLeft allValues positions) - ) - - processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - - allValues, positions - - ///. - ///. - ///Should be a power of 2 and greater than 1. - let map2<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> (clContext: ClContext) op workGroupSize = - - let merge = merge clContext workGroupSize - - let prepare = - preparePositions<'a, 'b, 'c> clContext op workGroupSize - - let setPositions = setPositions clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector.Sparse<'a>) (rightVector: ClVector.Sparse<'b>) -> - - let allIndices, leftValues, rightValues, isLeft = - merge processor leftVector.Indices leftVector.Values rightVector.Indices rightVector.Values - - let allValues, positions = - prepare processor allIndices leftValues rightValues isLeft - - processor.Post(Msg.CreateFreeMsg<_>(leftValues)) - processor.Post(Msg.CreateFreeMsg<_>(rightValues)) - processor.Post(Msg.CreateFreeMsg<_>(isLeft)) - - let resultValues, resultIndices = - setPositions processor allocationMode allValues allIndices positions - - processor.Post(Msg.CreateFreeMsg<_>(allIndices)) - processor.Post(Msg.CreateFreeMsg<_>(allValues)) - processor.Post(Msg.CreateFreeMsg<_>(positions)) - - { Context = clContext - Values = resultValues - Indices = resultIndices - Size = max leftVector.Size rightVector.Size } - - let map2AtLeastOne (clContext: ClContext) opAdd workGroupSize allocationMode = - map2 clContext (Convert.atLeastOneToOption opAdd) workGroupSize allocationMode - - let private preparePositionsAssignByMask<'a, 'b when 'a: struct and 'b: struct> - (clContext: ClContext) - op - workGroupSize - = - - let kernel = clContext.Compile(Map2.prepareAssign op) - - fun (processor: MailboxProcessor<_>) (vectorLenght: int) (leftValues: ClArray<'a>) (leftIndices: ClArray) (rightValues: ClArray<'b>) (rightIndices: ClArray) (value: ClCell<'a>) -> - - let resultBitmap = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vectorLenght) - - let resultIndices = - clContext.CreateClArrayWithSpecificAllocationMode(DeviceOnly, vectorLenght) - - let resultValues = - clContext.CreateClArrayWithSpecificAllocationMode<'a>(DeviceOnly, vectorLenght) - - let ndRange = - Range1D.CreateValid(vectorLenght, workGroupSize) - - let kernel = kernel.GetKernel() - - processor.Post( - Msg.MsgSetArguments - (fun () -> - kernel.KernelFunc - ndRange - vectorLenght - leftValues.Length - rightValues.Length - leftValues - leftIndices - rightValues - rightIndices - value - resultBitmap - resultValues - resultIndices) - ) - - processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - - resultBitmap, resultValues, resultIndices - - ///. - ///. - ///Should be a power of 2 and greater than 1. - let assignByMask<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) op workGroupSize = - - let prepare = - preparePositionsAssignByMask clContext op workGroupSize - - let setPositions = setPositions clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector.Sparse<'a>) (rightVector: ClVector.Sparse<'b>) (value: ClCell<'a>) -> - - let bitmap, values, indices = - prepare - processor - leftVector.Size - leftVector.Values - leftVector.Indices - rightVector.Values - rightVector.Indices - value - - let resultValues, resultIndices = - setPositions processor allocationMode values indices bitmap - - processor.Post(Msg.CreateFreeMsg<_>(indices)) - processor.Post(Msg.CreateFreeMsg<_>(values)) - processor.Post(Msg.CreateFreeMsg<_>(bitmap)) - - { Context = clContext - Values = resultValues - Indices = resultIndices - Size = rightVector.Size } - - let toDense (clContext: ClContext) workGroupSize = - - let toDense = - <@ fun (ndRange: Range1D) length (values: ClArray<'a>) (indices: ClArray) (resultArray: ClArray<'a option>) -> - let gid = ndRange.GlobalID0 - - if gid < length then - let index = indices.[gid] - - resultArray.[index] <- Some values.[gid] @> - - let kernel = clContext.Compile(toDense) - - let create = - ClArray.zeroCreate clContext workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (vector: ClVector.Sparse<'a>) -> - let resultVector = - create processor allocationMode vector.Size - - let ndRange = - Range1D.CreateValid(vector.Indices.Length, workGroupSize) - - let kernel = kernel.GetKernel() - - processor.Post( - Msg.MsgSetArguments - (fun () -> - kernel.KernelFunc ndRange vector.Indices.Length vector.Values vector.Indices resultVector) - ) - - processor.Post(Msg.CreateRunMsg<_, _>(kernel)) - - resultVector - - let reduce<'a when 'a: struct> (clContext: ClContext) workGroupSize (opAdd: Expr<'a -> 'a -> 'a>) = - - let reduce = - Reduce.reduce clContext workGroupSize opAdd - - fun (processor: MailboxProcessor<_>) (vector: ClVector.Sparse<'a>) -> reduce processor vector.Values diff --git a/src/GraphBLAS-sharp.Backend/Vector/Vector.fs b/src/GraphBLAS-sharp.Backend/Vector/Vector.fs index 70e4c821..9c94992b 100644 --- a/src/GraphBLAS-sharp.Backend/Vector/Vector.fs +++ b/src/GraphBLAS-sharp.Backend/Vector/Vector.fs @@ -5,8 +5,6 @@ open GraphBLAS.FSharp.Backend.Quotes open Microsoft.FSharp.Control open Microsoft.FSharp.Quotations open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.Vector.Dense -open GraphBLAS.FSharp.Backend.Vector.Sparse open GraphBLAS.FSharp.Backend.Objects open GraphBLAS.FSharp.Backend.Objects.ClContext open GraphBLAS.FSharp.Backend.Objects.ClVector @@ -27,7 +25,7 @@ module Vector = clContext.CreateClArrayWithSpecificAllocationMode( allocationMode, [| Unchecked.defaultof<'a> |] - ) + ) // TODO empty vector Size = size } | Dense -> ClVector.Dense @@ -35,13 +33,13 @@ module Vector = let ofList (clContext: ClContext) workGroupSize = let scatter = - Scatter.runInplace clContext workGroupSize + Scatter.lastOccurrence clContext workGroupSize let zeroCreate = ClArray.zeroCreate clContext workGroupSize let map = - ClArray.map clContext workGroupSize <@ Some @> + ClArray.map <@ Some @> clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode format size (elements: (int * 'a) list) -> match format with @@ -79,29 +77,23 @@ module Vector = ClVector.Dense result let copy (clContext: ClContext) workGroupSize = - let copy = ClArray.copy clContext workGroupSize - - let copyData = ClArray.copy clContext workGroupSize + let sparseCopy = + Sparse.Vector.copy clContext workGroupSize let copyOptionData = ClArray.copy clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (vector: ClVector<'a>) -> match vector with | ClVector.Sparse vector -> - { Context = clContext - Indices = copy processor allocationMode vector.Indices - Values = copyData processor allocationMode vector.Values - Size = vector.Size } - |> ClVector.Sparse + ClVector.Sparse + <| sparseCopy processor allocationMode vector | ClVector.Dense vector -> ClVector.Dense <| copyOptionData processor allocationMode vector - let mask = copy - let toSparse (clContext: ClContext) workGroupSize = let toSparse = - DenseVector.toSparse clContext workGroupSize + Dense.Vector.toSparse clContext workGroupSize let copy = copy clContext workGroupSize @@ -114,7 +106,7 @@ module Vector = let toDense (clContext: ClContext) workGroupSize = let toDense = - SparseVector.toDense clContext workGroupSize + Sparse.Vector.toDense clContext workGroupSize let copy = ClArray.copy clContext workGroupSize @@ -127,109 +119,70 @@ module Vector = ClVector.Dense <| toDense processor allocationMode vector - let map2 (clContext: ClContext) (opAdd: Expr<'a option -> 'b option -> 'c option>) workGroupSize = - let addDense = - DenseVector.map2 clContext opAdd workGroupSize + let map2 (opAdd: Expr<'a option -> 'b option -> 'c option>) (clContext: ClContext) workGroupSize = + let map2Dense = + Dense.Vector.map2 opAdd clContext workGroupSize - let addSparse = - SparseVector.map2 clContext opAdd workGroupSize + let map2Sparse = + Sparse.Vector.map2 opAdd clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector<'a>) (rightVector: ClVector<'b>) -> match leftVector, rightVector with | ClVector.Dense left, ClVector.Dense right -> ClVector.Dense - <| addDense processor allocationMode left right - | ClVector.Sparse left, ClVector.Sparse right -> - ClVector.Sparse - <| addSparse processor allocationMode left right - | _ -> failwith "Vector formats are not matching." - - let map2AtLeastOne (clContext: ClContext) (opAdd: Expr -> 'c option>) workGroupSize = - let addSparse = - SparseVector.map2AtLeastOne clContext opAdd workGroupSize - - let addDense = - DenseVector.map2AtLeastOne clContext opAdd workGroupSize - - fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector<'a>) (rightVector: ClVector<'b>) -> - match leftVector, rightVector with + <| map2Dense processor allocationMode left right | ClVector.Sparse left, ClVector.Sparse right -> ClVector.Sparse - <| addSparse processor allocationMode left right - | ClVector.Dense left, ClVector.Dense right -> - ClVector.Dense - <| addDense processor allocationMode left right + <| map2Sparse processor allocationMode left right | _ -> failwith "Vector formats are not matching." - let map2General<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> - (clContext: ClContext) - (opAdd: Expr<'a option -> 'b option -> 'c option>) - workGroupsSize - = - - let sparseEWise = - SparseVector.map2General clContext opAdd workGroupsSize + let map2AtLeastOne (opAdd: Expr -> 'c option>) (clContext: ClContext) workGroupSize = + let map2Sparse = + Sparse.Vector.map2AtLeastOne opAdd clContext workGroupSize - let denseEWise = - DenseVector.map2 clContext opAdd workGroupsSize + let map2Dense = + Dense.Vector.map2AtLeastOne opAdd clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (leftVector: ClVector<'a>) (rightVector: ClVector<'b>) -> match leftVector, rightVector with | ClVector.Sparse left, ClVector.Sparse right -> ClVector.Sparse - <| sparseEWise processor allocationMode left right + <| map2Sparse processor allocationMode left right | ClVector.Dense left, ClVector.Dense right -> ClVector.Dense - <| denseEWise processor allocationMode left right + <| map2Dense processor allocationMode left right | _ -> failwith "Vector formats are not matching." - let private assignByMaskGeneral<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) op workGroupSize = + let private assignByMaskGeneral<'a, 'b when 'a: struct and 'b: struct> op (clContext: ClContext) workGroupSize = let sparseFillVector = - SparseVector.assignByMask clContext op workGroupSize + Sparse.Vector.assignByMask op clContext workGroupSize let denseFillVector = - DenseVector.assignByMask clContext op workGroupSize - - let toSparseVector = - DenseVector.toSparse clContext workGroupSize - - let toSparseMask = - DenseVector.toSparse clContext workGroupSize + Dense.Vector.assignByMask op clContext workGroupSize fun (processor: MailboxProcessor<_>) allocationMode (vector: ClVector<'a>) (mask: ClVector<'b>) (value: ClCell<'a>) -> match vector, mask with | ClVector.Sparse vector, ClVector.Sparse mask -> - ClVector.Sparse - <| sparseFillVector processor allocationMode vector mask value - | ClVector.Sparse vector, ClVector.Dense mask -> - let mask = - toSparseMask processor allocationMode mask - - ClVector.Sparse - <| sparseFillVector processor allocationMode vector mask value - | ClVector.Dense vector, ClVector.Sparse mask -> - let vector = - toSparseVector processor allocationMode vector - ClVector.Sparse <| sparseFillVector processor allocationMode vector mask value | ClVector.Dense vector, ClVector.Dense mask -> ClVector.Dense <| denseFillVector processor allocationMode vector mask value + | _ -> failwith "Vector formats are not matching." - let assignByMask<'a, 'b when 'a: struct and 'b: struct> clContext op workGroupSize = - assignByMaskGeneral<'a, 'b> clContext (Convert.assignToOption op) workGroupSize + let assignByMask<'a, 'b when 'a: struct and 'b: struct> op clContext workGroupSize = + assignByMaskGeneral<'a, 'b> (Convert.assignToOption op) clContext workGroupSize - let assignByMaskComplemented<'a, 'b when 'a: struct and 'b: struct> clContext op workGroupSize = - assignByMaskGeneral<'a, 'b> clContext (Convert.assignComplementedToOption op) workGroupSize + let assignByMaskComplemented<'a, 'b when 'a: struct and 'b: struct> op clContext workGroupSize = + assignByMaskGeneral<'a, 'b> (Convert.assignComplementedToOption op) clContext workGroupSize - let reduce (clContext: ClContext) workGroupSize (opAdd: Expr<'a -> 'a -> 'a>) = + let reduce (opAdd: Expr<'a -> 'a -> 'a>) (clContext: ClContext) workGroupSize = let sparseReduce = - SparseVector.reduce clContext workGroupSize opAdd + Sparse.Vector.reduce opAdd clContext workGroupSize let denseReduce = - DenseVector.reduce clContext workGroupSize opAdd + Dense.Vector.reduce opAdd clContext workGroupSize fun (processor: MailboxProcessor<_>) (vector: ClVector<'a>) -> match vector with diff --git a/src/GraphBLAS-sharp.Backend/paket.references b/src/GraphBLAS-sharp.Backend/paket.references index 6f164f37..6051b92a 100644 --- a/src/GraphBLAS-sharp.Backend/paket.references +++ b/src/GraphBLAS-sharp.Backend/paket.references @@ -1,4 +1,4 @@ FSharp.Core Microsoft.SourceLink.GitHub - Brahma.FSharp +FSharp.Quotations.Evaluator \ No newline at end of file diff --git a/src/GraphBLAS-sharp/AlgebraicStructures.fs b/src/GraphBLAS-sharp/AlgebraicStructures.fs deleted file mode 100644 index 8a048043..00000000 --- a/src/GraphBLAS-sharp/AlgebraicStructures.fs +++ /dev/null @@ -1,55 +0,0 @@ -namespace GraphBLAS.FSharp - -open Microsoft.FSharp.Quotations - -type UnaryOp<'a, 'b> = UnaryOp of Expr<'a -> 'b> -type BinaryOp<'a, 'b, 'c> = BinaryOp of Expr<'a -> 'b -> 'c> - -type ClosedUnaryOp<'a> = ClosedUnaryOp of Expr<'a -> 'a> -type ClosedBinaryOp<'a> = ClosedBinaryOp of Expr<'a -> 'a -> 'a> - -/// Magma with associative (magma is set with closed binary operator) -type ISemigroup<'a> = - abstract Op : ClosedBinaryOp<'a> - -/// Semigroup with identity -type IMonoid<'a> = - abstract Plus : ClosedBinaryOp<'a> - abstract Zero : 'a - -/// Monoid with associative binary operator, -/// for wich Zero is annihilator -type ISemiring<'a> = - abstract Zero : 'a - abstract Plus : ClosedBinaryOp<'a> - abstract Times : ClosedBinaryOp<'a> - -type Semigroup<'a> = - { AssociativeOp: ClosedBinaryOp<'a> } - - interface ISemigroup<'a> with - member this.Op = this.AssociativeOp - -type Monoid<'a> = - { AssociativeOp: ClosedBinaryOp<'a> - Identity: 'a } - - interface ISemigroup<'a> with - member this.Op = this.AssociativeOp - - interface IMonoid<'a> with - member this.Plus = this.AssociativeOp - member this.Zero = this.Identity - -type Semiring<'a> = - { PlusMonoid: Monoid<'a> - TimesSemigroup: Semigroup<'a> } - - interface IMonoid<'a> with - member this.Zero = this.PlusMonoid.Identity - member this.Plus = this.PlusMonoid.AssociativeOp - - interface ISemiring<'a> with - member this.Times = this.TimesSemigroup.AssociativeOp - member this.Zero = this.PlusMonoid.Identity - member this.Plus = this.PlusMonoid.AssociativeOp diff --git a/src/GraphBLAS-sharp/Algorithms/BFS.fs b/src/GraphBLAS-sharp/Algorithms/BFS.fs deleted file mode 100644 index 5972939b..00000000 --- a/src/GraphBLAS-sharp/Algorithms/BFS.fs +++ /dev/null @@ -1,38 +0,0 @@ -namespace GraphBLAS.FSharp.Algorithms - -open GraphBLAS.FSharp.Predefined -open GraphBLAS.FSharp - -module BFS = - let levelSingleSource (matrix: Matrix) (source: int) = - graphblas { - let vertexCount = Matrix.rowCount matrix - let! levels = Vector.zeroCreate vertexCount // v - let! frontier = Vector.ofList vertexCount [ source, 1 ] // q[s] = true - let! transposed = Matrix.transpose matrix // A' - - let mutable currentLevel = 0 - let mutable break' = false - - while not break' do - currentLevel <- currentLevel + 1 - - let! currentLevelScalar = Scalar.create currentLevel - - let! frontierMask = Vector.mask frontier - do! Vector.fillSubVector levels frontierMask currentLevelScalar // v[q] = d - - let! levelsComplemented = Vector.complemented levels - - do! - Matrix.mxvWithMask AddMult.int levelsComplemented transposed frontier // q[!v] = (A' ||.&& q)' = q' ||.&& A -- replace + comp - >>= Vector.assignVector frontier - - let! succ = - Vector.reduce AddMult.int frontier - >>= Scalar.exportValue - - break' <- succ = 0 - - return levels - } diff --git a/src/GraphBLAS-sharp/Algorithms/BetweennessCentrality.fs b/src/GraphBLAS-sharp/Algorithms/BetweennessCentrality.fs deleted file mode 100644 index f07c1ebc..00000000 --- a/src/GraphBLAS-sharp/Algorithms/BetweennessCentrality.fs +++ /dev/null @@ -1,89 +0,0 @@ -namespace GraphBLAS.FSharp.Algorithms - -open GraphBLAS.FSharp.Predefined -open GraphBLAS.FSharp - -module BetweennessCentrality = - // NOTE matrix of bool? - let metric (matrix: Matrix) (source: int) = - graphblas { - let n = Matrix.rowCount matrix - let! delta = Vector.zeroCreate n - let! sigma = Matrix.zeroCreate n n - let! q = Vector.ofList n [ source, 1 ] - let! p = Vector.copy q - - let! pMask = Vector.complemented p - - do! - Matrix.vxmWithMask AddMult.int pMask q matrix - >>= Vector.assignVector q - - let mutable d = 0 - let mutable sum = 0 - let mutable break' = false - - while not break' || sum <> 0 do - break' <- true - - do! Matrix.assignRow sigma d q - - do! - Vector.eWiseAdd Add.int p q - >>= Vector.assignVector p // ? - - let! pMask = Vector.complemented p - - do! - Matrix.vxmWithMask AddMult.int pMask q matrix - >>= Vector.assignVector q - - let! sum' = Vector.reduce Add.int q >>= Scalar.exportValue - - sum <- sum' - d <- d + 1 - - let! t1 = Vector.zeroCreate n - let! t2 = Vector.zeroCreate n - let! t3 = Vector.zeroCreate n - let! t4 = Vector.zeroCreate n - - for i = d - 1 downto 1 do - // t1 <- 1 + delta - do! - Vector.apply (UnaryOp <@ (+) 1.f @>) delta - >>= Vector.assignVector t1 - - // t2 <- sigma.[i, *] - do! - Matrix.extractRow sigma i - >>= Vector.apply (UnaryOp <@ float32 @>) - >>= Vector.assignVector t2 - - // t2 <- t1 / t2 - let! qMask = Vector.mask q - - do! - Vector.apply (UnaryOp <@ (/) 1.f @>) t2 - >>= fun x -> Vector.eWiseMultWithMask AddMult.float32 qMask t1 x - >>= Vector.assignVector t2 - - do! - Matrix.apply (UnaryOp <@ float32 @>) matrix - >>= fun matrix -> Matrix.mxv AddMult.float32 matrix t2 - >>= Vector.assignVector t3 - - // t4 <- sigma.[i - 1, *] * t3 - do! - Matrix.extractRow sigma (i - 1) - >>= Vector.apply (UnaryOp <@ float32 @>) - >>= fun x -> Vector.eWiseMult AddMult.float32 x t3 - >>= Vector.assignVector t4 - - // delta <- delta + t4 - do! - Vector.eWiseAdd Add.float32 delta t4 - >>= Vector.assignVector delta - - return delta - } diff --git a/src/GraphBLAS-sharp/Algorithms/ShortestPath.fs b/src/GraphBLAS-sharp/Algorithms/ShortestPath.fs deleted file mode 100644 index 4fa82474..00000000 --- a/src/GraphBLAS-sharp/Algorithms/ShortestPath.fs +++ /dev/null @@ -1,24 +0,0 @@ -namespace GraphBLAS.FSharp.Algorithms - -open GraphBLAS.FSharp.Predefined -open GraphBLAS.FSharp -open Brahma.FSharp.OpenCL - -module ShortestPath = - // FIXME Unsupported call: min - let singleSource (matrix: Matrix) (source: int) = - graphblas { - let vertexCount = Matrix.rowCount matrix - let! distance = Vector.ofList vertexCount [ source, 0. ] - - let! transposed = Matrix.transpose matrix // A' - - // TODO terminate earlier if we reach a fixed point - for _ = 1 to vertexCount - 1 do - failwith "FIX ME! And rewrite." - //do! - // Matrix.mxv MinAdd.float transposed distance - // >>= Vector.assignVector distance - - return distance - } diff --git a/src/GraphBLAS-sharp/Algorithms/TriangleCounting.fs b/src/GraphBLAS-sharp/Algorithms/TriangleCounting.fs deleted file mode 100644 index e04a97a4..00000000 --- a/src/GraphBLAS-sharp/Algorithms/TriangleCounting.fs +++ /dev/null @@ -1,30 +0,0 @@ -namespace GraphBLAS.FSharp.Algorithms - -open GraphBLAS.FSharp.Predefined -open GraphBLAS.FSharp - -module TriangleCounting = - let sandia (matrix: Matrix) = - graphblas { - let! lowerTriangular = - matrix - |> Matrix.select (UnaryOp <@ fun (i, j, _) -> i <= j @>) - - let! matrix' = - lowerTriangular - |> Matrix.apply ( - UnaryOp - <@ function - | true -> 1 - | false -> 0 @> - ) - - let! transposed = matrix' |> Matrix.transpose - - let! lowerTriangularMask = lowerTriangular |> Matrix.mask - - return! - Matrix.mxmWithMask AddMult.int lowerTriangularMask matrix' transposed - >>= Matrix.reduce Add.int - >>= Scalar.exportValue - } diff --git a/src/GraphBLAS-sharp/GraphBLAS-sharp.fsproj b/src/GraphBLAS-sharp/GraphBLAS-sharp.fsproj index 97538119..698b8a17 100644 --- a/src/GraphBLAS-sharp/GraphBLAS-sharp.fsproj +++ b/src/GraphBLAS-sharp/GraphBLAS-sharp.fsproj @@ -16,25 +16,12 @@ - - + - - - - - - - - - Always diff --git a/src/GraphBLAS-sharp/GraphblasEvaluation.fs b/src/GraphBLAS-sharp/GraphblasEvaluation.fs deleted file mode 100644 index 4997a79a..00000000 --- a/src/GraphBLAS-sharp/GraphblasEvaluation.fs +++ /dev/null @@ -1,88 +0,0 @@ -namespace GraphBLAS.FSharp -// -//open Brahma.FSharp.ClTaskImpl -//open Brahma.FSharp.ClTask -//open Brahma.FSharp -// -//type GraphblasContext = { ClContext: ClContext } -// -//type GraphblasEvaluation<'a> = EvalGB of (GraphblasContext -> 'a) -// -//module EvalGB = -// let defaultEnv = { ClContext = ClContext() } -// -// let private runCl env (ClTask f) = f env -// -// let run env (EvalGB action) = action env -// -// let ask = EvalGB id -// -// let asks f = EvalGB f -// -// let bind f reader = -// EvalGB -// <| fun env -> -// let x = run env reader -// run env (f x) -// -// let (>>=) x f = bind f x -// -// let return' x = EvalGB <| fun _ -> x -// -// let returnFrom x = x -// -// let fromCl clEvaluation = -// EvalGB -// <| fun env -> runCl env.ClContext clEvaluation -// -// let withClContext clContext (EvalGB action) = -// ask -// >>= fun env -> -// return' -// <| action { env with ClContext = clContext } -// -// let runSync (EvalGB action) = -// let result = action defaultEnv -// result -// -//type GraphblasBuilder() = -// member this.Bind(x, f) = EvalGB.bind f x -// member this.Return x = EvalGB.return' x -// member this.ReturnFrom x = x -// -// member this.Zero() = EvalGB.return' () -// -// member this.Combine(m1, m2) = -// EvalGB -// <| fun env -> -// EvalGB.run env m1 -// EvalGB.run env m2 -// -// member this.Delay rest = -// EvalGB <| fun env -> EvalGB.run env <| rest () -// -// member this.While(predicate, body) = -// EvalGB -// <| fun env -> -// while predicate () do -// EvalGB.run env body -// -// member this.For(sequence, f) = -// EvalGB -// <| fun env -> -// for elem in sequence do -// EvalGB.run env (f elem) -// -// member this.TryWith(tryBlock, handler) = -// EvalGB -// <| fun env -> -// try -// EvalGB.run env tryBlock -// with -// | e -> EvalGB.run env (handler e) -// -//[] -//module GraphblasBuilder = -// let graphblas = GraphblasBuilder() -// -// let (>>=) x f = EvalGB.bind f x diff --git a/src/GraphBLAS-sharp/IO/MtxReader.fs b/src/GraphBLAS-sharp/IO/MtxReader.fs index 6059b8bc..f25ce8c0 100644 --- a/src/GraphBLAS-sharp/IO/MtxReader.fs +++ b/src/GraphBLAS-sharp/IO/MtxReader.fs @@ -34,15 +34,15 @@ type MtxReader(pathToFile: string) = streamReader.ReadLine().Split(' ') |> Array.map int - let nrows = size.[0] - let ncols = size.[1] + let rowsCount = size.[0] + let columnsCount = size.[1] let nnz = size.[2] - {| RowCount = nrows - ColumnCount = ncols - Nnz = nnz |} + {| RowCount = rowsCount + ColumnCount = columnsCount + NNZ = nnz |} - member this.ReadMatrix(converter: string -> 'a) : Matrix<'a> = + member this.ReadMatrix(converter: string -> 'a) : Matrix.COO<'a> = if object <> MtxMatrix then failwith "Object is not matrix" @@ -119,12 +119,11 @@ type MtxReader(pathToFile: string) = values.[i] <- value) sortedData - Matrix.COO - { Rows = rows - Columns = cols - Values = values - RowCount = n - ColumnCount = m } + { Matrix.COO.Rows = rows + Matrix.COO.Columns = cols + Matrix.COO.Values = values + Matrix.COO.RowCount = n + Matrix.COO.ColumnCount = m } match format with | Coordinate -> matrixFromCoordinateFormat () diff --git a/src/GraphBLAS-sharp/Objects/Matrix.fs b/src/GraphBLAS-sharp/Objects/Matrix.fs index 5dda085b..45754431 100644 --- a/src/GraphBLAS-sharp/Objects/Matrix.fs +++ b/src/GraphBLAS-sharp/Objects/Matrix.fs @@ -5,6 +5,51 @@ open GraphBLAS.FSharp.Backend.Objects open GraphBLAS.FSharp.Backend.Objects.ClMatrix module Matrix = + type CSR<'a when 'a: struct> = + { RowCount: int + ColumnCount: int + RowPointers: int [] + ColumnIndices: int [] + Values: 'a [] } + + static member FromArray2D(array: 'a [,], isZero: 'a -> bool) = + let rowsCount = array |> Array2D.length1 + let columnsCount = array |> Array2D.length2 + + let convertedMatrix = + [ for i in 0 .. rowsCount - 1 -> array.[i, *] |> List.ofArray ] + |> List.map + (fun row -> + row + |> List.mapi (fun i x -> (x, i)) + |> List.filter (fun pair -> not <| isZero (fst pair))) + |> List.fold + (fun (rowPointers, valueInx) row -> + ((rowPointers.Head + row.Length) :: rowPointers), valueInx @ row) + ([ 0 ], []) + + { Values = + convertedMatrix + |> (snd >> List.unzip >> fst) + |> List.toArray + ColumnIndices = + convertedMatrix + |> (snd >> List.unzip >> snd) + |> List.toArray + RowPointers = convertedMatrix |> fst |> List.rev |> List.toArray + RowCount = rowsCount + ColumnCount = columnsCount } + + member this.NNZ = this.Values.Length + + member this.ToDevice(context: ClContext) = + { Context = context + RowCount = this.RowCount + ColumnCount = this.ColumnCount + RowPointers = context.CreateClArray this.RowPointers + Columns = context.CreateClArray this.ColumnIndices + Values = context.CreateClArray this.Values } + type COO<'a when 'a: struct> = { RowCount: int ColumnCount: int @@ -19,6 +64,8 @@ module Matrix = sprintf "Values: %A \n" this.Values ] |> String.concat "" + member this.NNZ = this.Values.Length + static member FromTuples(rowCount: int, columnCount: int, rows: int [], columns: int [], values: 'a []) = { RowCount = rowCount ColumnCount = columnCount @@ -27,7 +74,7 @@ module Matrix = Values = values } static member FromArray2D(array: 'a [,], isZero: 'a -> bool) = - let rows, cols, vals = + let rows, cols, values = array |> Seq.cast<'a> |> Seq.mapi (fun idx v -> (idx / Array2D.length2 array, idx % Array2D.length2 array, v)) @@ -35,7 +82,7 @@ module Matrix = |> Array.ofSeq |> Array.unzip3 - COO.FromTuples(Array2D.length1 array, Array2D.length2 array, rows, cols, vals) + COO.FromTuples(Array2D.length1 array, Array2D.length2 array, rows, cols, values) member this.ToDevice(context: ClContext) = { Context = context @@ -45,47 +92,20 @@ module Matrix = Columns = context.CreateClArray this.Columns Values = context.CreateClArray this.Values } - type CSR<'a when 'a: struct> = - { RowCount: int - ColumnCount: int - RowPointers: int [] - ColumnIndices: int [] - Values: 'a [] } - - static member FromArray2D(array: 'a [,], isZero: 'a -> bool) = - let rowsCount = array |> Array2D.length1 - let columnsCount = array |> Array2D.length2 + member this.ToCSR = + let rowPointers = + let pointers = Array.zeroCreate this.RowCount - let convertedMatrix = - [ for i in 0 .. rowsCount - 1 -> array.[i, *] |> List.ofArray ] - |> List.map - (fun row -> - row - |> List.mapi (fun i x -> (x, i)) - |> List.filter (fun pair -> not <| isZero (fst pair))) - |> List.fold - (fun (rowPtrs, valueInx) row -> ((rowPtrs.Head + row.Length) :: rowPtrs), valueInx @ row) - ([ 0 ], []) + Array.countBy id this.Rows + |> Array.iter (fun (index, count) -> pointers.[index] <- count) - { Values = - convertedMatrix - |> (snd >> List.unzip >> fst) - |> List.toArray - ColumnIndices = - convertedMatrix - |> (snd >> List.unzip >> snd) - |> List.toArray - RowPointers = convertedMatrix |> fst |> List.rev |> List.toArray - RowCount = rowsCount - ColumnCount = columnsCount } + Array.scan (+) 0 pointers - member this.ToDevice(context: ClContext) = - { Context = context - RowCount = this.RowCount + { RowCount = this.RowCount ColumnCount = this.ColumnCount - RowPointers = context.CreateClArray this.RowPointers - Columns = context.CreateClArray this.ColumnIndices - Values = context.CreateClArray this.Values } + RowPointers = rowPointers + ColumnIndices = this.Columns + Values = this.Values } type CSC<'a when 'a: struct> = { RowCount: int @@ -106,7 +126,8 @@ module Matrix = |> List.mapi (fun i x -> (x, i)) |> List.filter (fun pair -> not <| isZero (fst pair))) |> List.fold - (fun (colPtrs, valueInx) col -> ((colPtrs.Head + col.Length) :: colPtrs), valueInx @ col) + (fun (colPointers, valueInx) col -> + ((colPointers.Head + col.Length) :: colPointers), valueInx @ col) ([ 0 ], []) { Values = @@ -121,6 +142,8 @@ module Matrix = RowCount = rowsCount ColumnCount = columnsCount } + member this.NNZ = this.Values.Length + member this.ToDevice(context: ClContext) = { Context = context RowCount = this.RowCount @@ -129,6 +152,44 @@ module Matrix = ColumnPointers = context.CreateClArray this.ColumnPointers Values = context.CreateClArray this.Values } + type LIL<'a when 'a: struct> = + { RowCount: int + ColumnCount: int + Rows: Vector.Sparse<'a> option list + NNZ: int } + + static member FromArray2D(array: 'a [,], isZero: 'a -> bool) = + let mutable nnz = 0 + + let rows = + [ for i in 0 .. Array2D.length1 array - 1 do + let vector = + Vector.Sparse.FromArray(array.[i, *], isZero) + + nnz <- nnz + vector.NNZ + + if vector.NNZ > 0 then + Some vector + else + None ] + + { RowCount = Array2D.length1 array + ColumnCount = Array2D.length2 array + Rows = rows + NNZ = nnz } + + member this.ToDevice(context: ClContext) = + + let rows = + this.Rows + |> List.map (Option.map (fun vector -> vector.ToDevice(context))) + + { Context = context + RowCount = this.RowCount + ColumnCount = this.ColumnCount + Rows = rows + NNZ = this.NNZ } + type Tuples<'a> = { RowIndices: int [] ColumnIndices: int [] @@ -139,27 +200,32 @@ type Matrix<'a when 'a: struct> = | CSR of Matrix.CSR<'a> | COO of Matrix.COO<'a> | CSC of Matrix.CSC<'a> + | LIL of Matrix.LIL<'a> member this.RowCount = match this with | CSR matrix -> matrix.RowCount | COO matrix -> matrix.RowCount | CSC matrix -> matrix.RowCount + | LIL matrix -> matrix.RowCount member this.ColumnCount = match this with | CSR matrix -> matrix.ColumnCount | COO matrix -> matrix.ColumnCount | CSC matrix -> matrix.ColumnCount + | LIL matrix -> matrix.ColumnCount member this.NNZ = match this with - | COO m -> m.Values.Length - | CSR m -> m.Values.Length - | CSC m -> m.Values.Length + | COO m -> m.NNZ + | CSR m -> m.NNZ + | CSC m -> m.NNZ + | LIL m -> m.NNZ member this.ToDevice(context: ClContext) = match this with | COO matrix -> ClMatrix.COO <| matrix.ToDevice context | CSR matrix -> ClMatrix.CSR <| matrix.ToDevice context | CSC matrix -> ClMatrix.CSC <| matrix.ToDevice context + | LIL matrix -> ClMatrix.LIL <| matrix.ToDevice context diff --git a/src/GraphBLAS-sharp/Objects/MatrixExtensions.fs b/src/GraphBLAS-sharp/Objects/MatrixExtensions.fs index b30ff16e..f310ca31 100644 --- a/src/GraphBLAS-sharp/Objects/MatrixExtensions.fs +++ b/src/GraphBLAS-sharp/Objects/MatrixExtensions.fs @@ -3,68 +3,109 @@ namespace GraphBLAS.FSharp.Objects open GraphBLAS.FSharp.Backend.Objects open Brahma.FSharp open Matrix +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Objects.ClVectorExtensions module MatrixExtensions = - type ClMatrix<'a when 'a: struct> with + // Matrix.Free + type ClMatrix.COO<'a when 'a: struct> with + member this.Free(q: MailboxProcessor<_>) = + this.Columns.Free q + this.Values.Free q + this.Rows.Free q + member this.ToHost(q: MailboxProcessor<_>) = - match this with - | ClMatrix.COO m -> - let rows = Array.zeroCreate m.Rows.Length - let columns = Array.zeroCreate m.Columns.Length - let values = Array.zeroCreate m.Values.Length + { RowCount = this.RowCount + ColumnCount = this.ColumnCount + Rows = this.Rows.ToHost q + Columns = this.Columns.ToHost q + Values = this.Values.ToHost q } + + member this.ToHostAndFree(q: MailboxProcessor<_>) = + let result = this.ToHost q + this.Free q - q.Post(Msg.CreateToHostMsg(m.Rows, rows)) + result - q.Post(Msg.CreateToHostMsg(m.Columns, columns)) + type ClMatrix.CSR<'a when 'a: struct> with + member this.Free(q: MailboxProcessor<_>) = + this.Values.Free q + this.Columns.Free q + this.RowPointers.Free q - ignore - <| q.PostAndReply(fun ch -> Msg.CreateToHostMsg(m.Values, values, ch)) + member this.ToHost(q: MailboxProcessor<_>) = + { RowCount = this.RowCount + ColumnCount = this.ColumnCount + RowPointers = this.RowPointers.ToHost q + ColumnIndices = this.Columns.ToHost q + Values = this.Values.ToHost q } + + member this.ToHostAndFree(q: MailboxProcessor<_>) = + let result = this.ToHost q + this.Free q - let result = - { RowCount = m.RowCount - ColumnCount = m.ColumnCount - Rows = rows - Columns = columns - Values = values } + result - Matrix.COO result - | ClMatrix.CSR m -> - let rows = Array.zeroCreate m.RowPointers.Length - let columns = Array.zeroCreate m.Columns.Length - let values = Array.zeroCreate m.Values.Length + type ClMatrix.CSC<'a when 'a: struct> with + member this.Free(q: MailboxProcessor<_>) = + this.Values.Free q + this.Rows.Free q + this.ColumnPointers.Free q - q.Post(Msg.CreateToHostMsg(m.RowPointers, rows)) + member this.ToHost(q: MailboxProcessor<_>) = + { RowCount = this.RowCount + ColumnCount = this.ColumnCount + RowIndices = this.Rows.ToHost q + ColumnPointers = this.ColumnPointers.ToHost q + Values = this.Values.ToHost q } - q.Post(Msg.CreateToHostMsg(m.Columns, columns)) + member this.ToHostAndFree(q: MailboxProcessor<_>) = + let result = this.ToHost q + this.Free q - ignore - <| q.PostAndReply(fun ch -> Msg.CreateToHostMsg(m.Values, values, ch)) + result - let result = - { RowCount = m.RowCount - ColumnCount = m.ColumnCount - RowPointers = rows - ColumnIndices = columns - Values = values } + type ClMatrix.LIL<'a when 'a: struct> with + member this.Free(q: MailboxProcessor<_>) = + this.Rows + |> List.iter (Option.iter (fun row -> row.Dispose q)) - Matrix.CSR result - | ClMatrix.CSC m -> - let rows = Array.zeroCreate m.Rows.Length - let columns = Array.zeroCreate m.ColumnPointers.Length - let values = Array.zeroCreate m.Values.Length + member this.ToHost(q: MailboxProcessor<_>) = + { RowCount = this.RowCount + ColumnCount = this.ColumnCount + Rows = + this.Rows + |> List.map (Option.map (fun row -> row.ToHost q)) + NNZ = this.NNZ } - q.Post(Msg.CreateToHostMsg(m.Rows, rows)) + member this.ToHostAndFree(q: MailboxProcessor<_>) = + let result = this.ToHost q + this.Free q + + result + + type ClMatrix<'a when 'a: struct> with + member this.ToHost(q: MailboxProcessor<_>) = + match this with + | ClMatrix.COO m -> m.ToHost q |> Matrix.COO + | ClMatrix.CSR m -> m.ToHost q |> Matrix.CSR + | ClMatrix.CSC m -> m.ToHost q |> Matrix.CSC + | ClMatrix.LIL m -> m.ToHost q |> Matrix.LIL + + member this.Free(q: MailboxProcessor<_>) = + match this with + | ClMatrix.COO m -> m.Free q + | ClMatrix.CSR m -> m.Free q + | ClMatrix.CSC m -> m.Free q + | ClMatrix.LIL m -> m.Free q - q.Post(Msg.CreateToHostMsg(m.ColumnPointers, columns)) + member this.FreeAndWait(processor: MailboxProcessor<_>) = + this.Free processor + processor.PostAndReply(MsgNotifyMe) - ignore - <| q.PostAndReply(fun ch -> Msg.CreateToHostMsg(m.Values, values, ch)) + member this.ToHostAndFree(processor: MailboxProcessor<_>) = + let result = this.ToHost processor - let result = - { RowCount = m.RowCount - ColumnCount = m.ColumnCount - RowIndices = rows - ColumnPointers = columns - Values = values } + this.Free processor - Matrix.CSC result + result diff --git a/src/GraphBLAS-sharp/Objects/Vector.fs b/src/GraphBLAS-sharp/Objects/Vector.fs index 7caa47b6..19b7e01a 100644 --- a/src/GraphBLAS-sharp/Objects/Vector.fs +++ b/src/GraphBLAS-sharp/Objects/Vector.fs @@ -33,15 +33,14 @@ module Vector = Size = size } static member FromArray(array: 'a [], isZero: 'a -> bool) = - let (indices, vals) = + let indices, values = array - |> Seq.cast<'a> |> Seq.mapi (fun idx v -> (idx, v)) |> Seq.filter (fun (_, v) -> not (isZero v)) |> Array.ofSeq |> Array.unzip - Sparse.FromTuples(indices, vals, array.Length) + Sparse.FromTuples(indices, values, array.Length) member this.NNZ = this.Values.Length diff --git a/src/GraphBLAS-sharp/Objects/VectorExtensions.fs b/src/GraphBLAS-sharp/Objects/VectorExtensions.fs index ad9333be..4bdb6a01 100644 --- a/src/GraphBLAS-sharp/Objects/VectorExtensions.fs +++ b/src/GraphBLAS-sharp/Objects/VectorExtensions.fs @@ -2,23 +2,17 @@ namespace GraphBLAS.FSharp.Objects open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions open GraphBLAS.FSharp.Backend.Objects -open Brahma.FSharp +open GraphBLAS.FSharp.Objects.Vector module ClVectorExtensions = + type ClVector.Sparse<'a> with + member this.ToHost(q: MailboxProcessor<_>) = + { Indices = this.Indices.ToHost q + Values = this.Values.ToHost q + Size = this.Size } + type ClVector<'a when 'a: struct> with member this.ToHost(q: MailboxProcessor<_>) = match this with - | ClVector.Sparse vector -> - let indices = Array.zeroCreate vector.Indices.Length - let values = Array.zeroCreate vector.Values.Length - - q.Post(Msg.CreateToHostMsg(vector.Indices, indices)) - - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(vector.Values, values, ch)) - |> ignore - - Vector.Sparse - <| { Indices = indices - Values = values - Size = this.Size } + | ClVector.Sparse vector -> Vector.Sparse <| vector.ToHost q | ClVector.Dense vector -> Vector.Dense <| vector.ToHost q diff --git a/src/GraphBLAS-sharp/Operations/Matrix.fs b/src/GraphBLAS-sharp/Operations/Matrix.fs deleted file mode 100644 index c36c7973..00000000 --- a/src/GraphBLAS-sharp/Operations/Matrix.fs +++ /dev/null @@ -1,371 +0,0 @@ -namespace GraphBLAS.FSharp - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend - -[] -module Matrix = - - (* - constructors - *) - - let build - (rowCount: int) - (columnCount: int) - (rows: int []) - (columns: int []) - (values: 'a []) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let ofTuples (rowCount: int) (columnCount: int) (tuples: MatrixTuples<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let ofList (rowCount: int) (columnCount: int) (elements: (int * int * 'a) list) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - // можно оставить, но с условием, что будет создаваться full matrix, - // которую можно будет проредить потом (но вообще это initом эмулируется) - // let ofArray2D (array: 'a[,]) : GraphblasEvaluation> = - // failwith "Not Implemented yet"" - - let init (rowCount: int) (columnCount: int) (initializer: int -> int -> 'a) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let create (rowCount: int) (columnCount: int) (value: 'a) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let zeroCreate<'a when 'a: struct> (rowCount: int) (columnCount: int) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - (* - methods - *) - - let rowCount (matrix: Matrix<'a>) : int = matrix.RowCount - let columnCount (matrix: Matrix<'a>) : int = matrix.ColumnCount - - let copy (matrix: Matrix<'a>) : GraphblasEvaluation> = failwith "Not Implemented yet" - - let resize (rowCount: int) (columnCount: int) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - // NOTE int cant be sync - let nnz (matrix: Matrix<'a>) : GraphblasEvaluation = failwith "Not Implemented yet" - - let tuples (matrix: Matrix<'a>) : GraphblasEvaluation> = - match matrix with - | MatrixCOO matrix -> COOMatrix.GetTuples.fromMatrix matrix - | MatrixCSR matrix -> CSRMatrix.GetTuples.fromMatrix matrix - |> EvalGB.fromCl - - let mask (matrix: Matrix<'a>) : GraphblasEvaluation = failwith "Not Implemented yet" - let complemented (matrix: Matrix<'a>) : GraphblasEvaluation = failwith "Not Implemented yet" - - let switch (matrixFormat: MatrixFromat) (matrix: Matrix<'a>) : GraphblasEvaluation> = - match matrix, matrixFormat with - | MatrixCOO matrix, CSR -> - opencl { - let! result = CSRMatrix.Convert.fromCoo matrix - return MatrixCSR result - } - | _ -> failwith "Not Implemented" - |> EvalGB.fromCl - - let synchronize (matrix: Matrix<'a>) : GraphblasEvaluation = failwith "Not Implemented yet" - - let synchronizeAndReturn (matrix: Matrix<'a>) : GraphblasEvaluation> = - match matrix with - | MatrixCSR matrix -> - opencl { - let! _ = - if matrix.RowPointers.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME! And rewrite." - //ToHost matrix.RowPointers - - let! _ = - if matrix.ColumnIndices.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME! And rewrite." - //ToHost matrix.ColumnIndices - - let! _ = - if matrix.Values.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME! And rewrite." - //ToHost matrix.Values - - return MatrixCSR matrix - } - | _ -> failwith "Not Implemented" - |> EvalGB.fromCl - - (* - assignment, extraction and filling - *) - - /// mat.[mask] - let extractSubMatrix (matrix: Matrix<'a>) (mask: Mask2D) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - /// mat.[rowIdx. *] - let extractRow (matrix: Matrix<'a>) (rowIdx: int) : GraphblasEvaluation> = failwith "Not Implemented yet" - - /// mat.[rowIdx, mask] - let extractSubRow (matrix: Matrix<'a>) (rowIdx: int) (mask: Mask2D) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - /// mat.[*, colIdx] - let extractCol (matrix: Matrix<'a>) (colIdx: int) : GraphblasEvaluation> = failwith "Not Implemented yet" - - /// mat.[mask. colIdx] - let extractSubCol (matrix: Matrix<'a>) (mask: Mask2D) (colIdx: int) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - /// mat.[rowIdx, colIdx] - let extractValue (matrix: Matrix<'a>) (rowIdx: int) (colIdx: int) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - /// t <- s - let assignMatrix (target: Matrix<'a>) (source: Matrix<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// t.[mask] <- s - let assignSubMatrix (target: Matrix<'a>) (mask: Mask2D) (source: Matrix<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// t.[rowIdx, *] <- s - let assignRow (target: Matrix<'a>) (rowIdx: int) (source: Vector<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// t.[rowIdx, mask] <- s - let assignSubRow - (target: Matrix<'a>) - (rowIdx: int) - (mask: Mask1D) - (source: Vector<'a>) - : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// t.[*, colIdx] <- s - let assignCol (target: Matrix<'a>) (colIdx: int) (source: Vector<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// t.[mask, colIdx] <- s - let assignSubCol - (target: Matrix<'a>) - (colIdx: int) - (mask: Mask1D) - (source: Vector<'a>) - : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// mat.[*, *] <- value - let fillMatrix (value: Scalar<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation = failwith "Not Implemented yet" - - /// mat.[mask] <- value - let fillSubMatrix (mask: Mask2D) (value: Scalar<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// mat.[rowIdx, *] <- value - let fillRow (rowIdx: int) (value: Scalar<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// mat.[rowIdx, mask] <- value - let fillSubRow (rowIdx: int) (mask: Mask1D) (value: Scalar<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// mat.[*, colIdx] <- value - let fillCol (colIdx: int) (value: Scalar<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// mat.[mask, colIdx] <- value - let fillSubCol (colIdx: int) (mask: Mask1D) (value: Scalar<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - (* - closed unmasked operations - *) - - let mxm - (semiring: ISemiring<'a>) - (leftMatrix: Matrix<'a>) - (rightMatrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented" - - let mxv (semiring: ISemiring<'a>) (matrix: Matrix<'a>) (vector: Vector<'a>) : GraphblasEvaluation> = - match matrix, vector with - | MatrixCSR matrix, VectorCOO vector -> - opencl { - let! result = CSRMatrix.SpMSpV.unmasked matrix vector semiring - return VectorCOO result - } - | _ -> failwith "Not Implemented" - |> EvalGB.fromCl - - let vxm (semiring: ISemiring<'a>) (vector: Vector<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented" - - let eWiseAdd - (monoid: IMonoid<'a>) - (leftMatrix: Matrix<'a>) - (rightMatrix: Matrix<'a>) - : GraphblasEvaluation> = - match leftMatrix, rightMatrix with - | MatrixCOO left, MatrixCOO right -> failwith "FIX ME! And rewrite." - //opencl { - // let! result = COOMatrix.EWiseAdd.run left right None monoid - // return MatrixCOO result - //} - | _ -> failwith "Not Implemented" - |> EvalGB.fromCl - - let eWiseMult - (semiring: ISemiring<'a>) - (leftMatrix: Matrix<'a>) - (rightMatrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let apply (mapper: UnaryOp<'a, 'b>) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let select (predicate: UnaryOp) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let reduceRows (monoid: IMonoid<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let reduceCols (monoid: IMonoid<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let reduce (monoid: IMonoid<'a>) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let transpose (matrix: Matrix<'a>) : GraphblasEvaluation> = - match matrix with - | MatrixCSR matrix -> - // map - opencl { - let! transposed = CSRMatrix.Transpose.transposeMatrix matrix - return MatrixCSR transposed - } - | _ -> failwith "Not Implemented" - |> EvalGB.fromCl - - let kronecker - (semiring: ISemiring<'a>) - (leftMatrix: Matrix<'a>) - (rightMatrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - (* - closed masked operations - *) - - let mxmWithMask - (semiring: ISemiring<'a>) - (mask: Mask2D) - (leftMatrix: Matrix<'a>) - (rightMatrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let mxvWithMask - (semiring: ISemiring<'a>) - (mask: Mask1D) - (matrix: Matrix<'a>) - (vector: Vector<'a>) - : GraphblasEvaluation> = - match matrix, vector, mask with - | MatrixCSR matrix, VectorCOO vector, mask when not mask.IsComplemented -> - opencl { - let! result = CSRMatrix.SpMSpV.masked matrix vector semiring mask - return VectorCOO result - } - | _ -> failwith "Not Implemented" - |> EvalGB.fromCl - - let vxmWithMask - (semiring: ISemiring<'a>) - (mask: Mask1D) - (vector: Vector<'a>) - (matrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let eWiseAddWithMask - (monoid: IMonoid<'a>) - (mask: Mask2D) - (leftMatrix: Matrix<'a>) - (rightMatrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let eWiseMultWithMask - (semiring: ISemiring<'a>) - (mask: Mask2D) - (leftMatrix: Matrix<'a>) - (rightMatrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let applyWithMask (mapper: UnaryOp<'a, 'b>) (mask: Mask2D) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let selectWithMask - (predicate: UnaryOp) - (mask: Mask2D) - (matrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let reduceRowsWithMask (monoid: IMonoid<'a>) (mask: Mask1D) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let reduceColsWithMask (monoid: IMonoid<'a>) (mask: Mask1D) (matrix: Matrix<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let kroneckerWithMask - (semiring: ISemiring<'a>) - (mask: Mask2D) - (leftMatrix: Matrix<'a>) - (rightMatrix: Matrix<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - -[] -module MatrixTuples = - let synchronize (matrixTuples: MatrixTuples<'a>) = - opencl { - let! _ = - if matrixTuples.RowIndices.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost matrixTuples.RowIndices - - let! _ = - if matrixTuples.ColumnIndices.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost matrixTuples.ColumnIndices - - let! _ = - if matrixTuples.Values.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost matrixTuples.Values - - return () - } - |> EvalGB.fromCl diff --git a/src/GraphBLAS-sharp/Operations/Scalar.fs b/src/GraphBLAS-sharp/Operations/Scalar.fs deleted file mode 100644 index 4c39d1da..00000000 --- a/src/GraphBLAS-sharp/Operations/Scalar.fs +++ /dev/null @@ -1,44 +0,0 @@ -namespace GraphBLAS.FSharp -// -//open Brahma.FSharp -// -//[] -//module Scalar = -// -// (* -// constructors -// *) -// -// let create (value: 'a) : GraphblasEvaluation> = -// graphblas { return ScalarWrapped { Value = [| value |] } } -// -// (* -// methods -// *) -// -// let copy (scalar: Scalar<'a>) : GraphblasEvaluation> = failwith "Not Implemented yet" -// -// let synchronize (scalar: Scalar<'a>) : GraphblasEvaluation = -// match scalar with -// | ScalarWrapped scalar -> -// opencl { -// failwith "FIX ME!" -// //let! _ = ToHost scalar.Value -// return () -// } -// |> EvalGB.fromCl -// -// (* -// assignment and extraction -// *) -// -// let exportValue (scalar: Scalar<'a>) : GraphblasEvaluation<'a> = -// graphblas { -// do! synchronize scalar -// -// match scalar with -// | ScalarWrapped scalar -> return scalar.Value.[0] -// } -// -// let assignValue (scalar: Scalar<'a>) (target: Scalar<'a>) : GraphblasEvaluation = -// failwith "Not Implemented yet" diff --git a/src/GraphBLAS-sharp/Operations/Vector.fs b/src/GraphBLAS-sharp/Operations/Vector.fs deleted file mode 100644 index 072ddfca..00000000 --- a/src/GraphBLAS-sharp/Operations/Vector.fs +++ /dev/null @@ -1,316 +0,0 @@ -namespace GraphBLAS.FSharp - -open Brahma.FSharp.OpenCL -open GraphBLAS.FSharp.Backend -open GraphBLAS.FSharp.Backend.Common - -[] -module Vector = - - (* - constructors - *) - - let build (size: int) (indices: int []) (values: 'a []) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let ofTuples (size: int) (tuples: VectorTuples<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let ofList (size: int) (elements: (int * 'a) list) : GraphblasEvaluation> = - let (indices, values) = - elements - |> Array.ofList - |> Array.sortBy fst - |> Array.unzip - - graphblas { - return - VectorCOO - <| COOVector.FromTuples(size, indices, values) - } - - // можно оставить, но с условием, что будет создаваться full vector - // let ofArray (array: 'a[]) : GraphblasEvaluation> = - // failwith "Not Implemented yet" - - let init (size: int) (initializer: int -> 'a) : GraphblasEvaluation> = failwith "Not Implemented yet" - - let create (size: int) (value: 'a) : GraphblasEvaluation> = failwith "Not Implemented yet" - - let zeroCreate<'a when 'a: struct> (size: int) : GraphblasEvaluation> = - graphblas { - return - VectorCOO - <| COOVector.FromTuples(size, [||], [||]) - } - - (* - methods - *) - - let size (vector: Vector<'a>) : int = failwith "Not Implemented yet" - let copy (vector: Vector<'a>) : GraphblasEvaluation> = failwith "Not Implemented yet" - let resize (size: int) (vector: Vector<'a>) : GraphblasEvaluation> = failwith "Not Implemented yet" - - // NOTE int cant be sync - let nnz (vector: Vector<'a>) : GraphblasEvaluation = failwith "Not Implemented yet" - - let tuples (vector: Vector<'a>) : GraphblasEvaluation> = - match vector with - | VectorCOO vector -> - opencl { - if vector.Values.Length = 0 then - return { Indices = [||]; Values = [||] } - else - failwith "FIX ME!" - let ind = [||] //let! ind = Copy.copyArray vector.Indices - let vals = [||] //let! vals = Copy.copyArray vector.Values - - return { Indices = ind; Values = vals } - } - |> EvalGB.fromCl - - let mask (vector: Vector<'a>) : GraphblasEvaluation = - match vector with - | VectorCOO vector -> - opencl { - failwith "FIX ME!" - let indices = [||] //let! indices = Copy.copyArray vector.Indices - return Mask1D(indices, vector.Size, false) - } - |> EvalGB.fromCl - - let complemented (vector: Vector<'a>) : GraphblasEvaluation = - match vector with - | VectorCOO vector -> - opencl { - failwith "FIX ME!" - let indices = [||] //let! indices = Copy.copyArray vector.Indices - - let! complementedMask = - Mask.GetComplemented.mask1D - <| Mask1D(indices, vector.Size, true) - - return complementedMask - } - |> EvalGB.fromCl - - let switch (vectorFormat: VectorFormat) (vector: Vector<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let synchronize (vector: Vector<'a>) : GraphblasEvaluation = - match vector with - | VectorCOO vector -> - opencl { - let! _ = - if vector.Indices.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost vector.Indices - - let! _ = - if vector.Values.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost vector.Values - - return () - } - |> EvalGB.fromCl - - let synchronizeAndReturn (vector: Vector<'a>) : GraphblasEvaluation> = - match vector with - | VectorCOO vector -> - opencl { - let! _ = - if vector.Indices.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost vector.Indices - - let! _ = - if vector.Values.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost vector.Values - - return VectorCOO vector - } - |> EvalGB.fromCl - - (* - assignment, extraction and filling - *) - - /// vec.[mask] - let extractSubVector (vector: Vector<'a>) (mask: Mask1D) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - /// vec.[idx] - let extractValue (vector: Vector<'a>) (idx: int) : GraphblasEvaluation> = failwith "Not Implemented yet" - - // assignToVector - /// t <- vec - let assignVector (target: Vector<'a>) (source: Vector<'a>) : GraphblasEvaluation = - if target.Size <> source.Size then - invalidArg "source" - <| sprintf "The size of source vector must be %A. Received: %A" target.Size source.Size - - match source, target with - | VectorCOO source, VectorCOO target -> - opencl { - target.Indices <- source.Indices - target.Values <- source.Values - } - |> EvalGB.fromCl - - /// t.[mask] <- vec - let assignSubVector (target: Vector<'a>) (mask: Mask1D) (source: Vector<'a>) : GraphblasEvaluation = - if target.Size <> mask.Size then - invalidArg "mask" - <| sprintf "The size of mask must be %A. Received: %A" target.Size mask.Size - - if target.Size <> source.Size then - invalidArg "source" - <| sprintf "The size of source vector must be %A. Received: %A" target.Size source.Size - - match source, target, mask with - | VectorCOO source, VectorCOO target, mask when not mask.IsComplemented -> - opencl { - let! (resultIndices, resultValues) = - COOVector.AssignSubVector.run target.Indices target.Values source.Indices source.Values mask.Indices - - target.Indices <- resultIndices - target.Values <- resultValues - } - | _ -> failwith "Not Implemented" - |> EvalGB.fromCl - - /// t.[idx] <- value - let assignValue (target: Vector<'a>) (idx: int) (value: Scalar<'a>) : GraphblasEvaluation = - failwith "Not Implemented yet" - - /// vec.[*] <- value - let fillVector (vector: Vector<'a>) (value: Scalar<'a>) : GraphblasEvaluation = failwith "Not Implemented yet" - - /// vec.[mask] <- value - let fillSubVector (vector: Vector<'a>) (mask: Mask1D) (value: Scalar<'a>) : GraphblasEvaluation = - match vector, value, mask with - | VectorCOO vector, ScalarWrapped scalar, mask when not mask.IsComplemented -> - opencl { - let! (resultIndices, resultValues) = - COOVector.FillSubVector.run vector.Indices vector.Values mask.Indices scalar.Value - - vector.Indices <- resultIndices - vector.Values <- resultValues - } - | _ -> failwith "Not Implemented" - |> EvalGB.fromCl - - (* - operations - *) - - let eWiseAdd - (monoid: IMonoid<'a>) - (leftVector: Vector<'a>) - (rightVector: Vector<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let eWiseMult - (semiring: ISemiring<'a>) - (leftVector: Vector<'a>) - (rightVector: Vector<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let apply (mapper: UnaryOp<'a, 'b>) (vector: Vector<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let select (predicate: UnaryOp<'a, bool>) (vector: Vector<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let reduce (monoid: IMonoid<'a>) (vector: Vector<'a>) : GraphblasEvaluation> = - let (ClosedBinaryOp plus) = monoid.Plus - - match vector with - | VectorCOO vector -> - opencl { - let! result = Sum.run vector.Values plus monoid.Zero - return ScalarWrapped { Value = result } - } - |> EvalGB.fromCl - - let eWiseAddWithMask - (monoid: IMonoid<'a>) - (mask: Mask1D) - (leftVector: Vector<'a>) - (rightVector: Vector<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let eWiseMultWithMask - (semiring: ISemiring<'a>) - (mask: Mask1D) - (leftVector: Vector<'a>) - (rightVector: Vector<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let applyWithMask (mapper: UnaryOp<'a, 'b>) (mask: Mask1D) (vector: Vector<'a>) : GraphblasEvaluation> = - failwith "Not Implemented yet" - - let selectWithMask - (predicate: UnaryOp<'a, bool>) - (mask: Mask1D) - (vector: Vector<'a>) - : GraphblasEvaluation> = - failwith "Not Implemented yet" - -[] -module VectorTuples = - let synchronize (vectorTuples: VectorTuples<'a>) = - opencl { - let! _ = - if vectorTuples.Indices.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost vectorTuples.Indices - - let! _ = - if vectorTuples.Values.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost vectorTuples.Values - - return () - } - |> EvalGB.fromCl - - let synchronizeAndReturn (vectorTuples: VectorTuples<'a>) = - opencl { - let! _ = - if vectorTuples.Indices.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost vectorTuples.Indices - - let! _ = - if vectorTuples.Values.Length = 0 then - opencl { return [||] } - else - failwith "FIX ME!" - //ToHost vectorTuples.Values - - return vectorTuples - } - |> EvalGB.fromCl diff --git a/src/GraphBLAS-sharp/Predefined/Monoids/Add.fs b/src/GraphBLAS-sharp/Predefined/Monoids/Add.fs deleted file mode 100644 index 24af1458..00000000 --- a/src/GraphBLAS-sharp/Predefined/Monoids/Add.fs +++ /dev/null @@ -1,32 +0,0 @@ -namespace GraphBLAS.FSharp.Predefined - -open GraphBLAS.FSharp - -module Add = - let int: Monoid = - { AssociativeOp = ClosedBinaryOp <@ (+) @> - Identity = 0 } - - let float: Monoid = - { AssociativeOp = ClosedBinaryOp <@ (+) @> - Identity = 0. } - - let float32: Monoid = - { AssociativeOp = ClosedBinaryOp <@ (+) @> - Identity = 0.f } - - let sbyte: Monoid = - { AssociativeOp = ClosedBinaryOp <@ (+) @> - Identity = 0y } - - let byte: Monoid = - { AssociativeOp = ClosedBinaryOp <@ (+) @> - Identity = 0uy } - - let int16: Monoid = - { AssociativeOp = ClosedBinaryOp <@ (+) @> - Identity = 0s } - - let uint16: Monoid = - { AssociativeOp = ClosedBinaryOp <@ (+) @> - Identity = 0us } diff --git a/src/GraphBLAS-sharp/Predefined/Monoids/Any.fs b/src/GraphBLAS-sharp/Predefined/Monoids/Any.fs deleted file mode 100644 index 3cbfa8d3..00000000 --- a/src/GraphBLAS-sharp/Predefined/Monoids/Any.fs +++ /dev/null @@ -1,8 +0,0 @@ -namespace GraphBLAS.FSharp.Predefined - -open GraphBLAS.FSharp - -module Any = - let bool: Monoid = - { AssociativeOp = ClosedBinaryOp <@ (||) @> - Identity = false } diff --git a/src/GraphBLAS-sharp/Predefined/Monoids/Min.fs b/src/GraphBLAS-sharp/Predefined/Monoids/Min.fs deleted file mode 100644 index 9249925d..00000000 --- a/src/GraphBLAS-sharp/Predefined/Monoids/Min.fs +++ /dev/null @@ -1,12 +0,0 @@ -namespace GraphBLAS.FSharp.Predefined - -open GraphBLAS.FSharp - -module Min = - let int: Monoid = - { AssociativeOp = ClosedBinaryOp <@ fun x y -> System.Math.Min(x, y) @> - Identity = System.Int32.MaxValue } - - let float: Monoid = - { AssociativeOp = ClosedBinaryOp <@ fun x y -> System.Math.Min(x, y) @> - Identity = System.Double.PositiveInfinity } diff --git a/src/GraphBLAS-sharp/Predefined/Semirings/AddMult.fs b/src/GraphBLAS-sharp/Predefined/Semirings/AddMult.fs deleted file mode 100644 index 4253e33f..00000000 --- a/src/GraphBLAS-sharp/Predefined/Semirings/AddMult.fs +++ /dev/null @@ -1,32 +0,0 @@ -namespace GraphBLAS.FSharp.Predefined - -open GraphBLAS.FSharp - -module AddMult = - let int: Semiring = - { PlusMonoid = Add.int - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (*) @> } } - - let float: Semiring = - { PlusMonoid = Add.float - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (*) @> } } - - let float32: Semiring = - { PlusMonoid = Add.float32 - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (*) @> } } - - let sbyte: Semiring = - { PlusMonoid = Add.sbyte - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (*) @> } } - - let byte: Semiring = - { PlusMonoid = Add.byte - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (*) @> } } - - let int16: Semiring = - { PlusMonoid = Add.int16 - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (*) @> } } - - let uint16: Semiring = - { PlusMonoid = Add.uint16 - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (*) @> } } diff --git a/src/GraphBLAS-sharp/Predefined/Semirings/AnyAll.fs b/src/GraphBLAS-sharp/Predefined/Semirings/AnyAll.fs deleted file mode 100644 index ea0d532b..00000000 --- a/src/GraphBLAS-sharp/Predefined/Semirings/AnyAll.fs +++ /dev/null @@ -1,8 +0,0 @@ -namespace GraphBLAS.FSharp.Predefined - -open GraphBLAS.FSharp - -module AnyAll = - let bool: Semiring = - { PlusMonoid = Any.bool - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (&&) @> } } diff --git a/src/GraphBLAS-sharp/Predefined/Semirings/MinAdd.fs b/src/GraphBLAS-sharp/Predefined/Semirings/MinAdd.fs deleted file mode 100644 index fd23eb3f..00000000 --- a/src/GraphBLAS-sharp/Predefined/Semirings/MinAdd.fs +++ /dev/null @@ -1,8 +0,0 @@ -namespace GraphBLAS.FSharp.Predefined - -open GraphBLAS.FSharp - -module MinAdd = - let float: Semiring = - { PlusMonoid = Min.float - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (+) @> } } diff --git a/tests/GraphBLAS-sharp.Tests/Algorithms/BFS.fs b/tests/GraphBLAS-sharp.Tests/Backend/Algorithms/BFS.fs similarity index 86% rename from tests/GraphBLAS-sharp.Tests/Algorithms/BFS.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Algorithms/BFS.fs index fa7febfe..a85d8424 100644 --- a/tests/GraphBLAS-sharp.Tests/Algorithms/BFS.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Algorithms/BFS.fs @@ -6,8 +6,8 @@ open GraphBLAS.FSharp.Backend.Common open GraphBLAS.FSharp.Backend.Quotes open GraphBLAS.FSharp.Tests open GraphBLAS.FSharp.Tests.Context -open GraphBLAS.FSharp.Tests.QuickGraph.Algorithms -open GraphBLAS.FSharp.Tests.QuickGraph.CreateGraph +open GraphBLAS.FSharp.Tests.Backend.QuickGraph.Algorithms +open GraphBLAS.FSharp.Tests.Backend.QuickGraph.CreateGraph open GraphBLAS.FSharp.Backend.Objects open GraphBLAS.FSharp.Objects.ClVectorExtensions open GraphBLAS.FSharp.Objects @@ -22,7 +22,11 @@ let testFixtures (testContext: TestContext) = sprintf "Test on %A" testContext.ClContext let bfs = - Algorithms.BFS.singleSource context ArithmeticOperations.intSum ArithmeticOperations.intMul workGroupSize + Algorithms.BFS.singleSource + ArithmeticOperations.intSumOption + ArithmeticOperations.intMulOption + context + workGroupSize testPropertyWithConfig config testName <| fun (matrix: int [,]) -> diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Blit.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Blit.fs new file mode 100644 index 00000000..771f3501 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Blit.fs @@ -0,0 +1,49 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.Blit + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let makeTest<'a> isEqual testFun (source: 'a [], sourceIndex, target: 'a [], targetIndex, count) = + + if source.Length > 0 && target.Length > 0 then + + let clSource = context.CreateClArray source + let clTarget = context.CreateClArray target + + testFun processor clSource sourceIndex clTarget targetIndex count + + clSource.Free processor + let actual = clTarget.ToHostAndFree processor + + // write to target --- target expected + Array.blit source sourceIndex target targetIndex count + + "Results should be the same" + |> Utils.compareArrays isEqual actual target + +let createTest<'a when 'a: equality> isEqual = + ClArray.blit context Utils.defaultWorkGroupSize + |> makeTest<'a> isEqual + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest (=) + + if Utils.isFloat64Available context.ClDevice then + createTest Utils.floatIsEqual + + createTest Utils.float32IsEqual + createTest (=) ] + |> testList "Blit" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Choose.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Choose.fs new file mode 100644 index 00000000..c79d035f --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Choose.fs @@ -0,0 +1,100 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.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 +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let workGroupSize = Utils.defaultWorkGroupSize + +let config = Utils.defaultConfig + +let makeTest<'a, 'b> testContext mapFun isEqual choose (array: 'a []) = + let context = testContext.ClContext + let q = testContext.Queue + + if array.Length > 0 then + + let clArray = context.CreateClArray array + + let (clResult: ClArray<'b> option) = choose q HostInterop clArray + + let expectedResult = Array.choose mapFun array + + match clResult with + | Some clResult -> + let hostResult = clResult.ToHostAndFree testContext.Queue + + "Result should be the same" + |> Utils.compareArrays isEqual hostResult expectedResult + | None -> + "Result must be empty" + |> Expect.isTrue (expectedResult.Length = 0) + +let createTest<'a, 'b> testContext mapFun mapFunQ isEqual = + ClArray.choose mapFunQ testContext.ClContext workGroupSize + |> makeTest<'a, 'b> testContext mapFun isEqual + |> testPropertyWithConfig config $"test on %A{typeof<'a>} -> %A{typeof<'b>}" + +let testFixtures testContext = + let device = testContext.ClContext.ClDevice + + [ createTest testContext id Map.id (=) + createTest testContext id Map.id (=) + createTest testContext id Map.id (=) + + if Utils.isFloat64Available device then + createTest testContext id Map.id Utils.floatIsEqual + + createTest testContext id Map.id Utils.float32IsEqual ] + +let tests = + TestCases.gpuTests "choose id" testFixtures + +let makeTest2 testContext isEqual opMap testFun (firstArray: 'a [], secondArray: 'a []) = + let context = testContext.ClContext + let processor = testContext.Queue + + if firstArray.Length > 0 && secondArray.Length > 0 then + + let expected = + Array.map2 opMap firstArray secondArray + |> Array.choose id + + let clFirstArray = context.CreateClArray firstArray + let clSecondArray = context.CreateClArray secondArray + + let (clActual: ClArray<_>) = + testFun processor HostInterop clFirstArray clSecondArray + + let actual = clActual.ToHostAndFree processor + clFirstArray.Free processor + clSecondArray.Free processor + + "Results must be the same" + |> Utils.compareArrays isEqual actual expected + +let createTest2 testsContext (isEqual: 'a -> 'a -> bool) (opMapQ, opMap) testFun = + testFun opMapQ testsContext.ClContext Utils.defaultWorkGroupSize + |> makeTest2 testsContext isEqual opMap + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let testsFixtures2 testContext = + let context = testContext.ClContext + + [ createTest2 testContext (=) ArithmeticOperations.intAdd ClArray.choose2 + + if Utils.isFloat64Available context.ClDevice then + createTest2 testContext (=) ArithmeticOperations.floatAdd ClArray.choose2 + + createTest2 testContext (=) ArithmeticOperations.float32Add ClArray.choose2 + createTest2 testContext (=) ArithmeticOperations.boolAdd ClArray.choose2 ] + +let tests2 = + TestCases.gpuTests "choose2 add" testsFixtures2 + +let allTests = testList "Choose" [ tests; tests2 ] diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/ChunkBySize.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/ChunkBySize.fs new file mode 100644 index 00000000..ae282f9a --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/ChunkBySize.fs @@ -0,0 +1,114 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.ChunkBySize + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let makeTestGetChunk<'a when 'a: equality> testFun (array: 'a [], startPosition, count) = + + if array.Length > 0 then + + let clArray = context.CreateClArray array + + let (clActual: ClArray<'a>) = + testFun processor HostInterop clArray startPosition count + + clArray.Free processor + let actual = clActual.ToHostAndFree processor + + "Results must be the same" + |> Expect.sequenceEqual actual (Array.sub array startPosition count) + +let creatTestSub<'a when 'a: equality> = + ClArray.sub context Utils.defaultWorkGroupSize + |> makeTestGetChunk<'a> + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let subTests = + [ creatTestSub + + if Utils.isFloat64Available context.ClDevice then + creatTestSub + + creatTestSub + creatTestSub + creatTestSub ] + |> testList "getChunk" + +let makeTestChunkBySize<'a when 'a: equality> isEqual testFun (array: 'a [], chunkSize: int) = + + if chunkSize > 0 && array.Length > 0 then + + let clArray = context.CreateClArray array + + let clActual: ClArray<'a> [] = + (testFun processor HostInterop chunkSize clArray) + + clArray.Free processor + + let actual = + clActual + |> Array.map (fun clArray -> clArray.ToHostAndFree processor) + + let expected = Array.chunkBySize chunkSize array + + "Results must be the same" + |> Utils.compareChunksArrays isEqual actual expected + +let chunkBySizeConfig = + { config with + arbitrary = [ typeof ] } + +let creatTestChunkBySize<'a when 'a: equality> isEqual = + ClArray.chunkBySize context Utils.defaultWorkGroupSize + |> makeTestChunkBySize<'a> isEqual + |> testPropertyWithConfig chunkBySizeConfig $"test on %A{typeof<'a>}" + +let chunkBySizeTests = + [ creatTestChunkBySize (=) + + if Utils.isFloat64Available context.ClDevice then + creatTestChunkBySize Utils.floatIsEqual + + creatTestChunkBySize Utils.float32IsEqual + creatTestChunkBySize (=) + creatTestChunkBySize (=) ] + |> testList "chanBySize" + +let creatTestChunkBySizeLazy<'a when 'a: equality> isEqual = + (fun processor allocationMode chunkSize array -> + ClArray.lazyChunkBySize context Utils.defaultWorkGroupSize processor allocationMode chunkSize array + |> Seq.map (fun lazyValue -> lazyValue.Value) + |> Seq.toArray) + |> makeTestChunkBySize<'a> isEqual + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let lazyChunkBySizeTests = + [ creatTestChunkBySizeLazy (=) + + if Utils.isFloat64Available context.ClDevice then + creatTestChunkBySizeLazy Utils.floatIsEqual + + creatTestChunkBySizeLazy Utils.float32IsEqual + creatTestChunkBySizeLazy (=) + creatTestChunkBySizeLazy (=) ] + |> testList "chunkBySize lazy" + +let allTests = + testList + "chunk" + [ subTests + chunkBySizeTests + lazyChunkBySizeTests ] diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Concat.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Concat.fs new file mode 100644 index 00000000..d27cdebf --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Concat.fs @@ -0,0 +1,50 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.Concat + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects.ClContext + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = Utils.defaultConfig + +let makeTest<'a> isEqual testFun (arrays: 'a [] []) = + + if Seq.length arrays > 0 + && arrays + |> Seq.forall (fun array -> array.Length > 0) then + + let clArrays = arrays |> Seq.map context.CreateClArray + + let clActual: ClArray<'a> = testFun processor HostInterop clArrays + + // release + let actual = clActual.ToHostAndFree processor + + clArrays + |> Seq.iter (fun array -> array.Free processor) + + let expected = Seq.concat arrays |> Seq.toArray + + "Results must be the same" + |> Utils.compareArrays isEqual actual expected + +let createTest<'a> isEqual = + ClArray.concat context Utils.defaultWorkGroupSize + |> makeTest<'a> isEqual + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest (=) + + if Utils.isFloat64Available context.ClDevice then + createTest Utils.floatIsEqual + + createTest Utils.float32IsEqual + createTest (=) ] + |> testList "Concat" diff --git a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Copy.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Copy.fs similarity index 83% rename from tests/GraphBLAS-sharp.Tests/Common/ClArray/Copy.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Copy.fs index dcf4ed83..2c8d2ba2 100644 --- a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Copy.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Copy.fs @@ -7,6 +7,7 @@ open Brahma.FSharp open GraphBLAS.FSharp.Tests open GraphBLAS.FSharp.Backend.Common open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions let logger = Log.create "ClArray.Copy.Tests" @@ -20,13 +21,13 @@ let config = Utils.defaultConfig let makeTest<'a when 'a: equality> copyFun (array: array<'a>) = if array.Length > 0 then - use clArray = context.CreateClArray array + let clArray = context.CreateClArray array let actual = - use clActual: ClArray<'a> = copyFun q HostInterop clArray + (copyFun q HostInterop clArray: ClArray<_>) + .ToHostAndFree q - let actual = Array.zeroCreate clActual.Length - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(clActual, actual, ch)) + clArray.Free q logger.debug ( eventX "Actual is {actual}" diff --git a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Exists.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Exists.fs similarity index 80% rename from tests/GraphBLAS-sharp.Tests/Common/ClArray/Exists.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Exists.fs index dbbb3415..ff061074 100644 --- a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Exists.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Exists.fs @@ -8,6 +8,7 @@ open Context open Brahma.FSharp open GraphBLAS.FSharp.Backend.Objects open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Objects.ClCell let logger = Log.create "ClArray.containsNonZero.Tests" @@ -28,17 +29,7 @@ let correctnessGenericTest<'a when 'a: struct and 'a: equality> isZero exists (a let result = match vector.ToDevice context with - | ClVector.Dense clArray -> - let resultCell = exists q clArray - let result = Array.zeroCreate 1 - - let res = - q.PostAndReply(fun ch -> Msg.CreateToHostMsg<_>(resultCell, result, ch)) - - q.Post(Msg.CreateFreeMsg<_>(resultCell)) - - res.[0] - + | ClVector.Dense clArray -> (exists q clArray: ClCell<_>).ToHostAndFree q | _ -> failwith "Unsupported vector format" $"The results should be the same, vector : {vector}" @@ -46,7 +37,7 @@ let correctnessGenericTest<'a when 'a: struct and 'a: equality> isZero exists (a let createTest<'a when 'a: struct and 'a: equality> isEqual zero = let exists = - ClArray.exists context wgSize Predicates.isSome + ClArray.exists Predicates.isSome context wgSize [ correctnessGenericTest<'a> (isEqual zero) exists |> testPropertyWithConfig config "FSCheck data" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Fill.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Fill.fs new file mode 100644 index 00000000..0921ff26 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Fill.fs @@ -0,0 +1,49 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.Fill + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects.ClContext + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let makeTest<'a> isEqual testFun (value: 'a, targetPosition, count, target: 'a []) = + if target.Length > 0 then + + let clTarget = context.CreateClArray target + let clValue = context.CreateClCell value + + testFun processor clValue targetPosition count clTarget + + // release + let actual = clTarget.ToHostAndFree processor + + // write to target + Array.fill target targetPosition count value + + "Results must be the same" + |> Utils.compareArrays isEqual actual target + +let createTest<'a> isEqual = + ClArray.fill context Utils.defaultWorkGroupSize + |> makeTest<'a> isEqual + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest (=) + + if Utils.isFloat64Available context.ClDevice then + createTest (=) + + createTest (=) + createTest (=) ] + |> testList "Fill" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Item.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Item.fs new file mode 100644 index 00000000..352f2517 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Item.fs @@ -0,0 +1,48 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.Item + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects.ClCell + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let makeTest<'a when 'a: equality> testFun (array: 'a [], position) = + + if array.Length > 0 then + + let clArray = context.CreateClArray array + + let result: ClCell<'a> = testFun processor position clArray + + clArray.Free processor + let actual = result.ToHost processor + + let expected = Array.item position array + + "Results must be the same" + |> Expect.equal actual expected + +let createTest<'a when 'a: equality> = + ClArray.item context Utils.defaultWorkGroupSize + |> makeTest<'a> + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest + + if Utils.isFloat64Available context.ClDevice then + createTest + + createTest + createTest ] + |> testList "Item" diff --git a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Map.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Map.fs similarity index 96% rename from tests/GraphBLAS-sharp.Tests/Common/ClArray/Map.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Map.fs index be501e41..a49ea492 100644 --- a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Map.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Map.fs @@ -44,8 +44,7 @@ let createTest<'a when 'a: equality> (testContext: TestContext) (zero: 'a) isEqu let context = testContext.ClContext let map = - ClArray.map context wgSize - <| Map.optionToValueOrZero zero + ClArray.map (Map.optionToValueOrZero zero) context wgSize makeTest testContext map zero isEqual |> testPropertyWithConfig config $"Correctness on {typeof<'a>}" diff --git a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Map2.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Map2.fs similarity index 96% rename from tests/GraphBLAS-sharp.Tests/Common/ClArray/Map2.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Map2.fs index 37c137a3..ae4342b8 100644 --- a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Map2.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Map2.fs @@ -4,7 +4,6 @@ open Brahma.FSharp open GraphBLAS.FSharp.Tests open GraphBLAS.FSharp.Tests.Context open GraphBLAS.FSharp.Backend.Common -open GraphBLAS.FSharp.Backend.Quotes open Expecto open GraphBLAS.FSharp.Backend.Objects.ClContext @@ -43,7 +42,7 @@ let createTest<'a when 'a: equality> (testContext: TestContext) isEqual hostMapF let context = testContext.ClContext - let map = ClArray.map2 context wgSize mapFunQ + let map = ClArray.map2 mapFunQ context wgSize makeTest<'a> testContext map hostMapFun isEqual |> testPropertyWithConfig config $"Correctness on {typeof<'a>}" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Pairwise.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Pairwise.fs new file mode 100644 index 00000000..5bd6957d --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Pairwise.fs @@ -0,0 +1,49 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.Pairwise + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects.ClContext + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let makeTest<'a> isEqual testFun (array: 'a []) = + if array.Length > 0 then + + let clArray = context.CreateClArray array + + match testFun processor HostInterop clArray with + | Some (actual: ClArray<_>) -> + let actual = actual.ToHostAndFree processor + + let expected = Array.pairwise array + + "First results must be the same" + |> Utils.compareArrays isEqual actual expected + | None -> + "Result must be empty" + |> Expect.isTrue (array.Size <= 1) + +let createTest<'a> isEqual = + ClArray.pairwise context Utils.defaultWorkGroupSize + |> makeTest<'a> isEqual + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest (=) + + if Utils.isFloat64Available context.ClDevice then + createTest (=) + + createTest (=) + createTest (=) ] + |> testList "Pairwise" diff --git a/tests/GraphBLAS-sharp.Tests/Common/ClArray/RemoveDuplicates.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/RemoveDuplicates.fs similarity index 100% rename from tests/GraphBLAS-sharp.Tests/Common/ClArray/RemoveDuplicates.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/RemoveDuplicates.fs diff --git a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Replicate.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Replicate.fs similarity index 84% rename from tests/GraphBLAS-sharp.Tests/Common/ClArray/Replicate.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Replicate.fs index c7067df5..0299eb05 100644 --- a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Replicate.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Replicate.fs @@ -7,6 +7,7 @@ open Brahma.FSharp open GraphBLAS.FSharp.Backend.Common open GraphBLAS.FSharp.Tests open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions let logger = Log.create "Replicate.Tests" @@ -20,13 +21,13 @@ let config = Utils.defaultConfig let makeTest<'a when 'a: equality> replicateFun (array: array<'a>) i = if array.Length > 0 && i > 0 then - use clArray = context.CreateClArray array + let clArray = context.CreateClArray array let actual = - use clActual: ClArray<'a> = replicateFun q HostInterop clArray i + (replicateFun q HostInterop clArray i: ClArray<'a>) + .ToHostAndFree q - let actual = Array.zeroCreate clActual.Length - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(clActual, actual, ch)) + clArray.Free q logger.debug ( eventX $"Actual is {actual}" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Set.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Set.fs new file mode 100644 index 00000000..a393b499 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/Set.fs @@ -0,0 +1,45 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.Set + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let makeTest<'a when 'a: equality> testFun (array: 'a [], position, value: 'a) = + + if array.Length > 0 then + + let clArray = context.CreateClArray array + + testFun processor clArray position value + + let actual = clArray.ToHostAndFree processor + Array.set array position value + + "Results must be the same" + |> Utils.compareArrays (=) actual array + +let createTest<'a when 'a: equality> = + ClArray.set context Utils.defaultWorkGroupSize + |> makeTest<'a> + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest + + if Utils.isFloat64Available context.ClDevice then + createTest + + createTest + createTest ] + |> testList "Set" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/UpperBound.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/UpperBound.fs new file mode 100644 index 00000000..78905478 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/ClArray/UpperBound.fs @@ -0,0 +1,60 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.UpperBound + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ClCell + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let makeTest testFun (array: 'a [], value: 'a) = + + if array.Length > 0 then + + let array = Array.sort array + + let clArray = context.CreateClArray array + let clValue = context.CreateClCell value + + let actual = + (testFun processor clArray clValue: ClCell<_>) + .ToHostAndFree processor + + let expected = + let mutable expected = 0 + + let array = Array.rev array + + for i in 0 .. array.Length - 1 do + let currentValue = array.[i] + + if value < currentValue then + expected <- i + + array.Length - expected - 1 + + "Results must be the same" + |> Expect.equal actual expected + +let createTest<'a when 'a: equality and 'a: comparison> = + ClArray.upperBound<'a> context Utils.defaultWorkGroupSize + |> makeTest + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest + + if Utils.isFloat64Available context.ClDevice then + createTest + + createTest + createTest ] + |> testList "UpperBound" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/Gather.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Gather.fs new file mode 100644 index 00000000..3019d9d3 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Gather.fs @@ -0,0 +1,127 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.Gather + +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Tests +open Expecto +open Microsoft.FSharp.Collections +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Quotes + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let check isEqual actual positions values target = + + HostPrimitives.gather positions values target + |> ignore + + "Results must be the same" + |> Utils.compareArrays isEqual actual target + +let makeTest isEqual testFun (array: (uint * 'a * 'a) []) = + + if array.Length > 0 then + + let positions, values, target = + Array.unzip3 array + |> fun (fst, snd, thd) -> Array.map int fst, snd, thd + + let clPositions = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, positions) + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values) + + let clTarget = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, target) + + testFun processor clPositions clValues clTarget + + clPositions.Free processor + clValues.Free processor + + let actual = clTarget.ToHostAndFree processor + + check isEqual actual positions values target + +let createTest<'a> (isEqual: 'a -> 'a -> bool) testFun = + + let testFun = + testFun context Utils.defaultWorkGroupSize + + makeTest isEqual testFun + |> testPropertyWithConfig Utils.defaultConfig $"test on %A{typeof<'a>}" + +let tests = + [ createTest (=) Gather.run + + if Utils.isFloat64Available context.ClDevice then + createTest Utils.floatIsEqual Gather.run + + createTest Utils.float32IsEqual Gather.run + createTest (=) Gather.run + createTest (=) Gather.run ] + |> testList "Gather" + + +let makeTestInit isEqual testFun indexMap (array: ('a * 'a) []) = + if array.Length > 0 then + + let positions, values, target = + Array.mapi (fun index (first, second) -> indexMap index, first, second) array + |> Array.unzip3 + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values) + + let clTarget = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, target) + + testFun processor clValues clTarget + + clValues.Free processor + + let actual = clTarget.ToHostAndFree processor + + check isEqual actual positions values target + +let createTestInit<'a> (isEqual: 'a -> 'a -> bool) testFun indexMapQ indexMap = + + let testFun = + testFun indexMapQ context Utils.defaultWorkGroupSize + + makeTestInit isEqual testFun indexMap + |> testPropertyWithConfig Utils.defaultConfig $"test on {typeof<'a>}" + +let initTests = + + let idTests = + [ createTestInit (=) Gather.runInit Map.id id + + if Utils.isFloat64Available context.ClDevice then + createTestInit Utils.floatIsEqual Gather.runInit Map.id id + + createTestInit Utils.float32IsEqual Gather.runInit Map.id id + createTestInit (=) Gather.runInit Map.id id + createTestInit (=) Gather.runInit Map.id id ] + |> testList "id" + + let inc = ((+) 1) + + let incTests = + [ createTestInit (=) Gather.runInit Map.inc inc + + if Utils.isFloat64Available context.ClDevice then + createTestInit Utils.floatIsEqual Gather.runInit Map.inc inc + + createTestInit Utils.float32IsEqual Gather.runInit Map.inc inc + createTestInit (=) Gather.runInit Map.inc inc + createTestInit (=) Gather.runInit Map.inc inc ] + |> testList "inc" + + testList "init" [ idTests; incTests ] + + +let allTests = testList "Gather" [ tests; initTests ] diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/Merge.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Merge.fs new file mode 100644 index 00000000..d937da3c --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Merge.fs @@ -0,0 +1,54 @@ +module GraphBLAS.FSharp.Tests.Common.Merge + +open Expecto +open Brahma.FSharp +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + endSize = 10000000 } + +let makeTest isEqual testFun (leftArray: 'a []) (rightArray: 'a []) = + if leftArray.Length > 0 && rightArray.Length > 0 then + + let leftArray = Array.sort leftArray |> Array.distinct + + let rightArray = Array.sort rightArray |> Array.distinct + + let clLeftArray = context.CreateClArray leftArray + let clRightArray = context.CreateClArray rightArray + + let clResult: ClArray<'a> = + testFun processor clLeftArray clRightArray + + let result = clResult.ToHostAndFree processor + clLeftArray.Free processor + clRightArray.Free processor + + let expected = + Array.concat [ leftArray; rightArray ] + |> Array.sort + + "Results must be the same" + |> Utils.compareArrays isEqual result expected + +let createTest<'a> isEqual = + Merge.run context Utils.defaultWorkGroupSize + |> makeTest isEqual + |> testPropertyWithConfig config $"test on {typeof<'a>}" + +let tests = + [ createTest (=) + + if Utils.isFloat64Available context.ClDevice then + createTest (=) + + createTest (=) + createTest (=) ] + |> testList "Merge" diff --git a/tests/GraphBLAS-sharp.Tests/Common/Reduce.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/Reduce.fs similarity index 86% rename from tests/GraphBLAS-sharp.Tests/Common/Reduce.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/Reduce.fs index 27ffeb6a..3500e639 100644 --- a/tests/GraphBLAS-sharp.Tests/Common/Reduce.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/Reduce.fs @@ -1,4 +1,4 @@ -module GraphBLAS.FSharp.Tests.Backend.Common.Reduce +module GraphBLAS.FSharp.Tests.Backend.Common.Reduce.Reduce open Expecto open Expecto.Logging @@ -6,6 +6,8 @@ open Expecto.Logging.Message open Brahma.FSharp open GraphBLAS.FSharp.Backend.Common open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ClCell +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions let logger = Log.create "Reduce.Tests" @@ -28,15 +30,11 @@ let makeTest (reduce: MailboxProcessor<_> -> ClArray<'a> -> ClCell<'a>) plus zer ) let actualSum = - use clArray = context.CreateClArray array + let clArray = context.CreateClArray array let total = reduce clArray - let actualSum = [| zero |] - - let sum = - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(total, actualSum, ch)) - - sum.[0] + clArray.Free q + total.ToHostAndFree q logger.debug ( eventX "Actual is {actual}\n" @@ -54,7 +52,7 @@ let makeTest (reduce: MailboxProcessor<_> -> ClArray<'a> -> ClCell<'a>) plus zer |> Expect.equal actualSum expectedSum let testFixtures plus plusQ zero name = - let reduce = Reduce.reduce context wgSize plusQ + let reduce = Reduce.reduce plusQ context wgSize makeTest reduce plus zero |> testPropertyWithConfig config $"Correctness on %s{name}" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/ReduceByKey.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/ReduceByKey.fs new file mode 100644 index 00000000..772eafb5 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/ReduceByKey.fs @@ -0,0 +1,547 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.Reduce.ByKey + +open Expecto +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ClContext +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = Utils.defaultConfig + +let getOffsets array = + Array.map fst array + |> HostPrimitives.getUniqueBitmapFirstOccurrence + |> HostPrimitives.getBitPositions + +let getOffsets2D array = + Array.map (fun (fst, snd, _) -> fst, snd) array + |> HostPrimitives.getUniqueBitmapFirstOccurrence + |> HostPrimitives.getBitPositions + +let checkResult isEqual actualKeys actualValues keys values reduceOp = + + let expectedKeys, expectedValues = + HostPrimitives.reduceByKey keys values reduceOp + + "Keys must be the same" + |> Utils.compareArrays (=) actualKeys expectedKeys + + "Values must the same" + |> Utils.compareArrays isEqual actualValues expectedValues + +let makeTest isEqual reduce reduceOp (arrayAndKeys: (int * 'a) []) = + let keys, values = + Array.sortBy fst arrayAndKeys |> Array.unzip + + if keys.Length > 0 then + let clKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, keys) + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values) + + let resultLength = Array.length <| Array.distinct keys + + let clActualValues, clActualKeys: ClArray<'a> * ClArray = + reduce processor HostInterop resultLength clKeys clValues + + clValues.Free processor + clKeys.Free processor + + let actualValues = clActualValues.ToHostAndFree processor + let actualKeys = clActualKeys.ToHostAndFree processor + + checkResult isEqual actualKeys actualValues keys values reduceOp + +let createTestSequential<'a> (isEqual: 'a -> 'a -> bool) reduceOp reduceOpQ = + + let reduce = + Reduce.ByKey.sequential reduceOpQ context Utils.defaultWorkGroupSize + + makeTest isEqual reduce reduceOp + |> testPropertyWithConfig config $"test on {typeof<'a>}" + +let sequentialTest = + let addTests = + testList + "add tests" + [ createTestSequential (=) (+) <@ (+) @> + createTestSequential (=) (+) <@ (+) @> + + if Utils.isFloat64Available context.ClDevice then + createTestSequential Utils.floatIsEqual (+) <@ (+) @> + + createTestSequential Utils.float32IsEqual (+) <@ (+) @> + createTestSequential (=) (||) <@ (||) @> ] + + let mulTests = + testList + "mul tests" + [ createTestSequential (=) (*) <@ (*) @> + createTestSequential (=) (*) <@ (*) @> + + if Utils.isFloat64Available context.ClDevice then + createTestSequential Utils.floatIsEqual (*) <@ (*) @> + + createTestSequential Utils.float32IsEqual (*) <@ (*) @> + createTestSequential (=) (&&) <@ (&&) @> ] + + testList "Sequential" [ addTests; mulTests ] + +let createTestOneWorkGroup<'a> (isEqual: 'a -> 'a -> bool) reduceOp reduceOpQ = + let reduce = + Reduce.ByKey.oneWorkGroupSegments reduceOpQ context Utils.defaultWorkGroupSize + + makeTest isEqual reduce reduceOp + |> testPropertyWithConfig + { config with + endSize = Utils.defaultWorkGroupSize } + $"test on {typeof<'a>}" + +let oneWorkGroupTest = + let addTests = + testList + "add tests" + [ createTestOneWorkGroup (=) (+) <@ (+) @> + createTestOneWorkGroup (=) (+) <@ (+) @> + + if Utils.isFloat64Available context.ClDevice then + createTestOneWorkGroup Utils.floatIsEqual (+) <@ (+) @> + + createTestOneWorkGroup Utils.float32IsEqual (+) <@ (+) @> + createTestOneWorkGroup (=) (||) <@ (||) @> ] + + let mulTests = + testList + "mul tests" + [ createTestOneWorkGroup (=) (*) <@ (*) @> + createTestOneWorkGroup (=) (*) <@ (*) @> + + if Utils.isFloat64Available context.ClDevice then + createTestOneWorkGroup Utils.floatIsEqual (*) <@ (*) @> + + createTestOneWorkGroup Utils.float32IsEqual (*) <@ (*) @> + createTestOneWorkGroup (=) (&&) <@ (&&) @> ] + + testList "One work group" [ addTests; mulTests ] + +let makeTestSequentialSegments isEqual reduce reduceOp (valuesAndKeys: (int * 'a) []) = + + let valuesAndKeys = Array.sortBy fst valuesAndKeys + + if valuesAndKeys.Length > 0 then + let offsets = + Array.map fst valuesAndKeys + |> HostPrimitives.getUniqueBitmapFirstOccurrence + |> HostPrimitives.getBitPositions + + let resultLength = offsets.Length + + let keys, values = Array.unzip valuesAndKeys + + let clOffsets = + context.CreateClArrayWithSpecificAllocationMode(HostInterop, offsets) + + let clKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, keys) + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values) + + let clReducedValues, clReducedKeys: ClArray<'a> * ClArray = + reduce processor DeviceOnly resultLength clOffsets clKeys clValues + + let reducedKeys = clReducedKeys.ToHostAndFree processor + let reducedValues = clReducedValues.ToHostAndFree processor + + checkResult isEqual reducedKeys reducedValues keys values reduceOp + + +let createTestSequentialSegments<'a> (isEqual: 'a -> 'a -> bool) reduceOp reduceOpQ = + let reduce = + Reduce.ByKey.segmentSequential reduceOpQ context Utils.defaultWorkGroupSize + + makeTestSequentialSegments isEqual reduce reduceOp + |> testPropertyWithConfig { config with startSize = 1000 } $"test on {typeof<'a>}" + +let sequentialSegmentTests = + let addTests = + testList + "add tests" + [ createTestSequentialSegments (=) (+) <@ (+) @> + createTestSequentialSegments (=) (+) <@ (+) @> + + if Utils.isFloat64Available context.ClDevice then + createTestSequentialSegments Utils.floatIsEqual (+) <@ (+) @> + + createTestSequentialSegments Utils.float32IsEqual (+) <@ (+) @> + createTestSequentialSegments (=) (||) <@ (||) @> ] + + let mulTests = + testList + "mul tests" + [ createTestSequentialSegments (=) (*) <@ (*) @> + createTestSequentialSegments (=) (*) <@ (*) @> + + if Utils.isFloat64Available context.ClDevice then + createTestSequentialSegments Utils.floatIsEqual (*) <@ (*) @> + + createTestSequentialSegments Utils.float32IsEqual (*) <@ (*) @> + createTestSequentialSegments (=) (&&) <@ (&&) @> ] + + testList "Sequential segments" [ addTests; mulTests ] + +let checkResult2D isEqual firstActualKeys secondActualKeys actualValues firstKeys secondKeys values reduceOp = + + let expectedFirstKeys, expectedSecondKeys, expectedValues = + HostPrimitives.reduceByKey2D firstKeys secondKeys values reduceOp + + "First keys must be the same" + |> Utils.compareArrays (=) firstActualKeys expectedFirstKeys + + "Second keys must be the same" + |> Utils.compareArrays (=) secondActualKeys expectedSecondKeys + + "Values must the same" + |> Utils.compareArrays isEqual actualValues expectedValues + +let makeTest2D isEqual reduce reduceOp (array: (int * int * 'a) []) = + let firstKeys, secondKeys, values = + array + |> Array.sortBy (fun (fst, snd, _) -> fst, snd) + |> Array.unzip3 + + if firstKeys.Length > 0 then + let clFirstKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, firstKeys) + + let clSecondKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, secondKeys) + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values) + + let resultLength = + Array.length + <| Array.distinctBy (fun (fst, snd, _) -> (fst, snd)) array + + let clActualValues, clFirstActualKeys, clSecondActualKeys: ClArray<'a> * ClArray * ClArray = + reduce processor HostInterop resultLength clFirstKeys clSecondKeys clValues + + clValues.Free processor + clFirstKeys.Free processor + clSecondKeys.Free processor + + let actualValues = clActualValues.ToHostAndFree processor + + let firstActualKeys = + clFirstActualKeys.ToHostAndFree processor + + let secondActualKeys = + clSecondActualKeys.ToHostAndFree processor + + checkResult2D isEqual firstActualKeys secondActualKeys actualValues firstKeys secondKeys values reduceOp + +let createTestSequential2D<'a> (isEqual: 'a -> 'a -> bool) reduceOp reduceOpQ = + + let reduce = + Reduce.ByKey2D.sequential reduceOpQ context Utils.defaultWorkGroupSize + + makeTest2D isEqual reduce reduceOp + |> testPropertyWithConfig + { config with + arbitrary = [ typeof ] + endSize = 10 } + $"test on {typeof<'a>}" + +let sequential2DTest = + let addTests = + testList + "add tests" + [ createTestSequential2D (=) (+) <@ (+) @> + createTestSequential2D (=) (+) <@ (+) @> + + if Utils.isFloat64Available context.ClDevice then + createTestSequential2D Utils.floatIsEqual (+) <@ (+) @> + + createTestSequential2D Utils.float32IsEqual (+) <@ (+) @> + createTestSequential2D (=) (||) <@ (||) @> ] + + let mulTests = + testList + "mul tests" + [ createTestSequential2D (=) (*) <@ (*) @> + createTestSequential2D (=) (*) <@ (*) @> + + if Utils.isFloat64Available context.ClDevice then + createTestSequential2D Utils.floatIsEqual (*) <@ (*) @> + + createTestSequential2D Utils.float32IsEqual (*) <@ (*) @> + createTestSequential2D (=) (&&) <@ (&&) @> ] + + testList "Sequential 2D" [ addTests; mulTests ] + +let makeTestSequentialSegments2D isEqual reduce reduceOp (array: (int * int * 'a) []) = + + if array.Length > 0 then + let array = + Array.sortBy (fun (fst, snd, _) -> fst, snd) array + + let offsets = + array + |> Array.map (fun (fst, snd, _) -> fst, snd) + |> HostPrimitives.getUniqueBitmapFirstOccurrence + |> HostPrimitives.getBitPositions + + let resultLength = offsets.Length + + let firstKeys, secondKeys, values = Array.unzip3 array + + let clOffsets = + context.CreateClArrayWithSpecificAllocationMode(HostInterop, offsets) + + let clFirstKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, firstKeys) + + let clSecondKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, secondKeys) + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values) + + let clReducedValues, clFirstActualKeys, clSecondActualKeys: ClArray<'a> * ClArray * ClArray = + reduce processor DeviceOnly resultLength clOffsets clFirstKeys clSecondKeys clValues + + let reducedFirsKeys = + clFirstActualKeys.ToHostAndFree processor + + let reducesSecondKeys = + clSecondActualKeys.ToHostAndFree processor + + let reducedValues = clReducedValues.ToHostAndFree processor + + checkResult2D isEqual reducedFirsKeys reducesSecondKeys reducedValues firstKeys secondKeys values reduceOp + +let createTestSequentialSegments2D<'a> (isEqual: 'a -> 'a -> bool) reduceOp reduceOpQ = + let reduce = + Reduce.ByKey2D.segmentSequential reduceOpQ context Utils.defaultWorkGroupSize + + makeTestSequentialSegments2D isEqual reduce reduceOp + |> testPropertyWithConfig + { config with + arbitrary = [ typeof ] } + $"test on {typeof<'a>}" + +let sequentialSegment2DTests = + let addTests = + testList + "add tests" + [ createTestSequentialSegments2D (=) (+) <@ (+) @> + createTestSequentialSegments2D (=) (+) <@ (+) @> + + if Utils.isFloat64Available context.ClDevice then + createTestSequentialSegments2D Utils.floatIsEqual (+) <@ (+) @> + + createTestSequentialSegments2D Utils.float32IsEqual (+) <@ (+) @> + createTestSequentialSegments2D (=) (||) <@ (||) @> ] + + let mulTests = + testList + "mul tests" + [ createTestSequentialSegments2D (=) (*) <@ (*) @> + createTestSequentialSegments2D (=) (*) <@ (*) @> + + if Utils.isFloat64Available context.ClDevice then + createTestSequentialSegments2D Utils.floatIsEqual (*) <@ (*) @> + + createTestSequentialSegments2D Utils.float32IsEqual (*) <@ (*) @> + createTestSequentialSegments2D (=) (&&) <@ (&&) @> ] + + testList "Sequential segments 2D" [ addTests; mulTests ] + +// segments sequential Option +let createReduceOp reduceOp left right = + match left, right with + | Some left, Some right -> reduceOp left right + | Some value, None + | None, Some value -> Some value + | _ -> None + +let checkResultOption isEqual keys values reduceOp actual = + + let reduceOp = createReduceOp reduceOp + + let expectedKeys, expectedValues = + Array.zip keys values + |> Array.groupBy fst + |> Array.map (fun (key, array) -> key, Array.map snd array) + |> Array.map + (fun (key, array) -> + Array.map Some array + |> Array.reduce reduceOp + |> fun result -> key, result) + |> Array.choose + (fun (key, value) -> + match value with + | Some value -> Some(key, value) + | _ -> None) + |> Array.unzip + + match actual with + | Some (actualValues, actualKeys) -> + "First keys must be the same" + |> Utils.compareArrays (=) actualKeys expectedKeys + + "Values must the same" + |> Utils.compareArrays isEqual actualValues expectedValues + | None -> Expect.isTrue (expectedValues.Length = 0) "Result should be Some _" + +let testOption<'a> isEqual reduceOp testFun (array: (int * 'a) []) = + if array.Length > 0 then + let array = Array.sortBy fst array + + let offsets = getOffsets array + + let keys, values = Array.unzip array + + let clOffsets = + context.CreateClArrayWithSpecificAllocationMode(HostInterop, offsets) + + let clKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, keys) + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values) + + testFun processor HostInterop offsets.Length clOffsets clKeys clValues + |> Option.bind + (fun ((clActualValues, clActualKeys): ClArray<_> * ClArray<_>) -> + let actualValues = clActualValues.ToHostAndFree processor + let actualKeys = clActualKeys.ToHostAndFree processor + + Some(actualValues, actualKeys)) + |> checkResultOption isEqual keys values reduceOp + +let createTestOption (isEqual: 'a -> 'a -> bool) (reduceOpQ, reduceOp) = + Reduce.ByKey.Option.segmentSequential reduceOpQ context Utils.defaultWorkGroupSize + |> testOption<'a> isEqual reduceOp + |> testPropertyWithConfig + { config with + arbitrary = [ typeof ] } + $"test on {typeof<'a>}" + +let testsSegmentsSequentialOption = + [ createTestOption (=) ArithmeticOperations.intAdd + + if Utils.isFloat64Available context.ClDevice then + createTestOption Utils.floatIsEqual ArithmeticOperations.floatAdd + + createTestOption Utils.float32IsEqual ArithmeticOperations.float32Add + createTestOption (=) ArithmeticOperations.boolAdd ] + |> testList "option" + + +// segments sequential Option 2D +let checkResult2DOption isEqual firstKeys secondKeys values reduceOp actual = + let reduceOp = createReduceOp reduceOp + + let expectedFirstKeys, expectedSecondKeys, expectedValues = + let keys = Array.zip firstKeys secondKeys + + Array.zip keys values + |> Array.groupBy fst + |> Array.map (fun (key, array) -> key, Array.map snd array) + |> Array.map + (fun (key, array) -> + Array.map Some array + |> Array.reduce reduceOp + |> fun result -> key, result) + |> Array.choose + (fun ((fstKey, sndKey), value) -> + match value with + | Some value -> Some(fstKey, sndKey, value) + | _ -> None) + |> Array.unzip3 + + match actual with + | Some (actualValues, firstActualKeys, secondActualKeys) -> + "First keys must be the same" + |> Utils.compareArrays (=) firstActualKeys expectedFirstKeys + + "Second keys must be the same" + |> Utils.compareArrays (=) secondActualKeys expectedSecondKeys + + "Values must the same" + |> Utils.compareArrays isEqual actualValues expectedValues + | None -> Expect.isTrue (expectedValues.Length = 0) "Result should be Some _" + +let test2DOption<'a> isEqual reduceOp reduce (array: (int * int * 'a) []) = + if array.Length > 0 then + let array = + Array.sortBy (fun (fst, snd, _) -> fst, snd) array + + let offsets = getOffsets2D array + + let firstKeys, secondKeys, values = Array.unzip3 array + + let clOffsets = + context.CreateClArrayWithSpecificAllocationMode(HostInterop, offsets) + + let clFirstKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, firstKeys) + + let clSecondKeys = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, secondKeys) + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(DeviceOnly, values) + + reduce processor DeviceOnly offsets.Length clOffsets clFirstKeys clSecondKeys clValues + |> Option.bind + (fun ((clReducedValues, clFirstActualKeys, clSecondActualKeys): ClArray<'a> * ClArray * ClArray) -> + let reducedFirstKeys = + clFirstActualKeys.ToHostAndFree processor + + let reducedSecondKeys = + clSecondActualKeys.ToHostAndFree processor + + let reducedValues = clReducedValues.ToHostAndFree processor + + Some(reducedValues, reducedFirstKeys, reducedSecondKeys)) + |> checkResult2DOption isEqual firstKeys secondKeys values reduceOp + +let createTest2DOption (isEqual: 'a -> 'a -> bool) (reduceOpQ, reduceOp) = + Reduce.ByKey2D.Option.segmentSequential reduceOpQ context Utils.defaultWorkGroupSize + |> test2DOption<'a> isEqual reduceOp + |> testPropertyWithConfig + { config with + arbitrary = [ typeof ] } + $"test on {typeof<'a>}" + +let testsSegmentsSequential2DOption = + [ createTest2DOption (=) ArithmeticOperations.intAdd + + if Utils.isFloat64Available context.ClDevice then + createTest2DOption Utils.floatIsEqual ArithmeticOperations.floatAdd + + createTest2DOption Utils.float32IsEqual ArithmeticOperations.float32Add + createTest2DOption (=) ArithmeticOperations.boolAdd ] + |> testList "2D option" + +let allTests = + testList + "Reduce.ByKey" + [ sequentialTest + oneWorkGroupTest + sequentialSegmentTests + sequential2DTest + sequentialSegment2DTests + testsSegmentsSequentialOption + testsSegmentsSequential2DOption ] diff --git a/tests/GraphBLAS-sharp.Tests/Common/Sum.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/Sum.fs similarity index 84% rename from tests/GraphBLAS-sharp.Tests/Common/Sum.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/Sum.fs index f3e2fffc..977b085e 100644 --- a/tests/GraphBLAS-sharp.Tests/Common/Sum.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Reduce/Sum.fs @@ -1,4 +1,4 @@ -module GraphBLAS.FSharp.Tests.Backend.Common.Sum +module GraphBLAS.FSharp.Tests.Backend.Common.Reduce.Sum open Expecto open Expecto.Logging @@ -8,6 +8,8 @@ open GraphBLAS.FSharp.Backend.Common open GraphBLAS.FSharp.Tests open FSharp.Quotations open Context +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open GraphBLAS.FSharp.Backend.Objects.ClCell let logger = Log.create "Sum.Test" @@ -27,11 +29,11 @@ let makeTest plus zero sum (array: 'a []) = ) let actualSum = - use clArray = context.CreateClArray array - use total = sum q clArray + let clArray = context.CreateClArray array + let (total: ClCell<_>) = sum q clArray - let actualSum = [| zero |] - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(total, actualSum, ch)).[0] + clArray.Free q + total.ToHostAndFree q logger.debug ( eventX "Actual is {actual}\n" @@ -49,7 +51,7 @@ let makeTest plus zero sum (array: 'a []) = |> Expect.equal actualSum expectedSum let testFixtures plus (plusQ: Expr<'a -> 'a -> 'a>) zero name = - Reduce.sum context wgSize plusQ zero + Reduce.sum plusQ zero context wgSize |> makeTest plus zero |> testPropertyWithConfig config (sprintf "Correctness on %s" name) diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/Scan/ByKey.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Scan/ByKey.fs new file mode 100644 index 00000000..a89b5f36 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Scan/ByKey.fs @@ -0,0 +1,111 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.Scan.ByKey + +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Objects.ClContext +open Expecto +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let checkResult isEqual keysAndValues actual hostScan = + + let expected = + HostPrimitives.scanByKey hostScan keysAndValues + + "Results must be the same" + |> Utils.compareArrays isEqual actual expected + +let makeTestSequentialSegments isEqual scanHost scanDevice (keysAndValues: (int * 'a) []) = + if keysAndValues.Length > 0 then + let keys, values = + Array.sortBy fst keysAndValues |> Array.unzip + + let offsets = + HostPrimitives.getUniqueBitmapFirstOccurrence keys + |> HostPrimitives.getBitPositions + + let uniqueKeysCount = Array.distinct keys |> Array.length + + let clKeys = + context.CreateClArrayWithSpecificAllocationMode(HostInterop, keys) + + let clValues = + context.CreateClArrayWithSpecificAllocationMode(HostInterop, values) + + let clOffsets = + context.CreateClArrayWithSpecificAllocationMode(HostInterop, offsets) + + scanDevice processor uniqueKeysCount clValues clKeys clOffsets + + let actual = clValues.ToHostAndFree processor + clKeys.Free processor + clOffsets.Free processor + + let keysAndValues = Array.zip keys values + + checkResult isEqual keysAndValues actual scanHost + +let createTest (zero: 'a) opAddQ opAdd isEqual deviceScan hostScan = + + let hostScan = hostScan zero opAdd + + let deviceScan = + deviceScan opAddQ zero context Utils.defaultWorkGroupSize + + makeTestSequentialSegments isEqual hostScan deviceScan + |> testPropertyWithConfig Utils.defaultConfig $"test on {typeof<'a>}" + +let sequentialSegmentsTests = + let excludeTests = + [ createTest 0 <@ (+) @> (+) (=) PrefixSum.ByKey.sequentialExclude HostPrimitives.prefixSumExclude + + if Utils.isFloat64Available context.ClDevice then + createTest + 0.0 + <@ (+) @> + (+) + Utils.floatIsEqual + PrefixSum.ByKey.sequentialExclude + HostPrimitives.prefixSumExclude + + createTest + 0.0f + <@ (+) @> + (+) + Utils.float32IsEqual + PrefixSum.ByKey.sequentialExclude + HostPrimitives.prefixSumExclude + + createTest false <@ (||) @> (||) (=) PrefixSum.ByKey.sequentialExclude HostPrimitives.prefixSumExclude + createTest 0u <@ (+) @> (+) (=) PrefixSum.ByKey.sequentialExclude HostPrimitives.prefixSumExclude ] + |> testList "exclude" + + let includeTests = + [ createTest 0 <@ (+) @> (+) (=) PrefixSum.ByKey.sequentialInclude HostPrimitives.prefixSumInclude + + if Utils.isFloat64Available context.ClDevice then + createTest + 0.0 + <@ (+) @> + (+) + Utils.floatIsEqual + PrefixSum.ByKey.sequentialInclude + HostPrimitives.prefixSumInclude + + createTest + 0.0f + <@ (+) @> + (+) + Utils.float32IsEqual + PrefixSum.ByKey.sequentialInclude + HostPrimitives.prefixSumInclude + + createTest false <@ (||) @> (||) (=) PrefixSum.ByKey.sequentialInclude HostPrimitives.prefixSumInclude + createTest 0u <@ (+) @> (+) (=) PrefixSum.ByKey.sequentialInclude HostPrimitives.prefixSumInclude ] + + |> testList "include" + + testList "Sequential segments" [ excludeTests; includeTests ] diff --git a/tests/GraphBLAS-sharp.Tests/Common/ClArray/PrefixSum.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Scan/PrefixSum.fs similarity index 83% rename from tests/GraphBLAS-sharp.Tests/Common/ClArray/PrefixSum.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Common/Scan/PrefixSum.fs index 18d61544..fbf12398 100644 --- a/tests/GraphBLAS-sharp.Tests/Common/ClArray/PrefixSum.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Scan/PrefixSum.fs @@ -1,4 +1,4 @@ -module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.PrefixSum +module GraphBLAS.FSharp.Tests.Backend.Common.Scan.PrefixSum open Expecto open Expecto.Logging @@ -8,6 +8,7 @@ open GraphBLAS.FSharp.Backend.Common open GraphBLAS.FSharp.Tests.Context open GraphBLAS.FSharp open GraphBLAS.FSharp.Backend.Objects.ClCell +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions let logger = Log.create "ClArray.PrefixSum.Tests" @@ -28,12 +29,12 @@ let makeTest plus zero isEqual scan (array: 'a []) = ) let actual, actualSum = - use clArray = context.CreateClArray array + let clArray = context.CreateClArray array let (total: ClCell<_>) = scan q clArray zero - let actual = Array.zeroCreate<'a> clArray.Length - let actualSum = total.ToHostAndFree(q) - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(clArray, actual, ch)), actualSum + let actual = clArray.ToHostAndFree q + let actualSum = total.ToHostAndFree q + actual, actualSum logger.debug ( eventX "Actual is {actual}\n" @@ -60,9 +61,9 @@ let makeTest plus zero isEqual scan (array: 'a []) = |> Tests.Utils.compareArrays isEqual actual expected let testFixtures plus plusQ zero isEqual name = - ClArray.prefixSumIncludeInplace plusQ context wgSize + PrefixSum.runIncludeInPlace plusQ context wgSize |> makeTest plus zero isEqual - |> testPropertyWithConfig config (sprintf "Correctness on %s" name) + |> testPropertyWithConfig config $"Correctness on %s{name}" let tests = q.Error.Add(fun e -> failwithf "%A" e) diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/Scatter.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Scatter.fs new file mode 100644 index 00000000..a72de22b --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Scatter.fs @@ -0,0 +1,114 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.Scatter + +open Expecto +open Expecto.Logging +open Brahma.FSharp +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Context +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let logger = Log.create "Scatter.Tests" + +let context = defaultContext.ClContext + +let config = Utils.defaultConfig + +let wgSize = Utils.defaultWorkGroupSize + +let q = defaultContext.Queue + +let makeTest<'a when 'a: equality> hostScatter scatter (array: (int * 'a) []) (result: 'a []) = + if array.Length > 0 then + let positions, values = Array.sortBy fst array |> Array.unzip + + let expected = + Array.copy result |> hostScatter positions values + + let actual = + let clPositions = context.CreateClArray positions + let clValues = context.CreateClArray values + let clResult = context.CreateClArray result + + scatter q clPositions clValues clResult + + clValues.Free q + clPositions.Free q + clResult.ToHostAndFree q + + $"Arrays should be equal." + |> Utils.compareArrays (=) actual expected + +let testFixturesLast<'a when 'a: equality> = + Scatter.lastOccurrence context wgSize + |> makeTest<'a> HostPrimitives.scatterLastOccurrence + |> testPropertyWithConfig config $"Correctness on %A{typeof<'a>}" + +let testFixturesFirst<'a when 'a: equality> = + Scatter.firstOccurrence context wgSize + |> makeTest<'a> HostPrimitives.scatterFirstOccurrence + |> testPropertyWithConfig config $"Correctness on %A{typeof<'a>}" + +let tests = + q.Error.Add(fun e -> failwithf $"%A{e}") + + let last = + [ testFixturesLast + testFixturesLast + testFixturesLast ] + |> testList "Last Occurrence" + + let first = + [ testFixturesFirst + testFixturesFirst + testFixturesFirst ] + |> testList "First Occurrence" + + testList "ones occurrence" [ first; last ] + +let makeTestInit<'a when 'a: equality> hostScatter valueMap scatter (positions: int []) (result: 'a []) = + if positions.Length > 0 then + + let values = Array.init positions.Length valueMap + let positions = Array.sort positions + + let expected = + Array.copy result |> hostScatter positions values + + let clPositions = context.CreateClArray positions + let clResult = context.CreateClArray result + + scatter q clPositions clResult + + clPositions.Free q + let actual = clResult.ToHostAndFree q + + $"Arrays should be equal." + |> Utils.compareArrays (=) actual expected + +let createInitTest clScatter hostScatter name valuesMap valuesMapQ = + let scatter = + clScatter valuesMapQ context Utils.defaultWorkGroupSize + + makeTestInit<'a> hostScatter valuesMap scatter + |> testPropertyWithConfig config name + +let initTests = + q.Error.Add(fun e -> failwithf $"%A{e}") + + let inc = ((+) 1) + + let firstOccurrence = + [ createInitTest Scatter.initFirsOccurrence HostPrimitives.scatterFirstOccurrence "id" id Map.id + createInitTest Scatter.initFirsOccurrence HostPrimitives.scatterFirstOccurrence "inc" inc Map.inc ] + |> testList "first occurrence" + + let lastOccurrence = + [ createInitTest Scatter.initLastOccurrence HostPrimitives.scatterLastOccurrence "id" id Map.id + createInitTest Scatter.initLastOccurrence HostPrimitives.scatterLastOccurrence "inc" inc Map.inc ] + |> testList "last occurrence" + + testList "init" [ firstOccurrence; lastOccurrence ] + +let allTests = testList "Scatter" [ tests; initTests ] diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/Sort/Bitonic.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Sort/Bitonic.fs new file mode 100644 index 00000000..60705e76 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Sort/Bitonic.fs @@ -0,0 +1,80 @@ +namespace GraphBLAS.FSharp.Tests.Backend.Common.Sort + +open Expecto +open Expecto.Logging +open Expecto.Logging.Message +open GraphBLAS.FSharp.Backend.Common +open Brahma.FSharp +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Context +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +module Bitonic = + let logger = Log.create "BitonicSort.Tests" + + let context = defaultContext.ClContext + + let config = + { Utils.defaultConfig with + endSize = 1000000 } + + let wgSize = Utils.defaultWorkGroupSize + + let q = defaultContext.Queue + + let makeTest sort (array: ('n * 'n * 'a) []) = + if array.Length > 0 then + let projection (row: 'n) (col: 'n) (_: 'a) = row, col + + logger.debug ( + eventX "Initial size is {size}" + >> setField "size" $"%A{array.Length}" + ) + + let rows, cols, vals = Array.unzip3 array + + let clRows = context.CreateClArray rows + let clColumns = context.CreateClArray cols + let clValues = context.CreateClArray vals + + let actualRows, actualCols, actualValues = + sort q clRows clColumns clValues + + let rows = clRows.ToHostAndFree q + let columns = clColumns.ToHostAndFree q + let values = clValues.ToHostAndFree q + + rows, columns, values + + let expectedRows, expectedCols, expectedValues = + (rows, cols, vals) + |||> Array.zip3 + |> Array.sortBy ((<|||) projection) + |> Array.unzip3 + + $"Row arrays should be equal. Actual is \n%A{actualRows}, expected \n%A{expectedRows}, input is \n%A{rows}" + |> Utils.compareArrays (=) actualRows expectedRows + + $"Column arrays should be equal. Actual is \n%A{actualCols}, expected \n%A{expectedCols}, input is \n%A{cols}" + |> Utils.compareArrays (=) actualCols expectedCols + + $"Value arrays should be equal. Actual is \n%A{actualValues}, expected \n%A{expectedValues}, input is \n%A{vals}" + |> Utils.compareArrays (=) actualValues expectedValues + + let testFixtures<'a when 'a: equality> = + Sort.Bitonic.sortKeyValuesInplace context wgSize + |> makeTest + |> testPropertyWithConfig config $"Correctness on %A{typeof<'a>}" + + let tests = + q.Error.Add(fun e -> failwithf "%A" e) + + [ testFixtures + + if Utils.isFloat64Available context.ClDevice then + testFixtures + + testFixtures + testFixtures + testFixtures ] + |> testList "Backend.Common.BitonicSort tests" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Common/Sort/Radix.fs b/tests/GraphBLAS-sharp.Tests/Backend/Common/Sort/Radix.fs new file mode 100644 index 00000000..2f565f3e --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Common/Sort/Radix.fs @@ -0,0 +1,83 @@ +module GraphBLAS.FSharp.Tests.Backend.Common.Sort.Radix + +open Expecto +open GraphBLAS.FSharp.Backend.Common.Sort +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects.ClContext + +let config = + { Utils.defaultConfig with + startSize = 1000000 } + +let workGroupSize = Utils.defaultWorkGroupSize + +let processor = Context.defaultContext.Queue + +let context = Context.defaultContext.ClContext + +let checkResultByKeys (inputArray: (int * 'a) []) (actualValues: 'a []) = + let expectedValues = Seq.sortBy fst inputArray |> Seq.map snd + + "Values must be the same" + |> Expect.sequenceEqual expectedValues actualValues + +let makeTestByKeys<'a when 'a: equality> sortFun (array: (int * 'a) []) = + + if array.Length > 0 then + let keys = Array.map fst array + let values = Array.map snd array + + let clKeys = keys.ToDevice context + let clValues = values.ToDevice context + + let clActualValues: ClArray<'a> = + sortFun processor HostInterop clKeys clValues + + let actualValues = clActualValues.ToHostAndFree processor + + checkResultByKeys array actualValues + +let createTestByKeys<'a when 'a: equality and 'a: struct> = + let sort = + Radix.runByKeysStandard context workGroupSize + + makeTestByKeys<'a> sort + |> testPropertyWithConfig config $"test on {typeof<'a>}" + +let testByKeys = + [ createTestByKeys + createTestByKeys + + if Utils.isFloat64Available context.ClDevice then + createTestByKeys + + createTestByKeys + createTestByKeys ] + |> testList "Radix sort by keys" + +let makeTestKeysOnly sort (keys: uint []) = + if keys.Length > 0 then + let keys = Array.map int keys + + let clKeys = keys.ToDevice context + + let actual = + (sort processor clKeys: ClArray) + .ToHostAndFree processor + + let expected = Array.sort keys + + "Keys must be the same" + |> Expect.sequenceEqual expected actual + +let testKeysOnly = + let sort = + Radix.standardRunKeysOnly context workGroupSize + + makeTestKeysOnly sort + |> testPropertyWithConfig config $"keys only" + +let allTests = + testList "Radix" [ testKeysOnly; testByKeys ] diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/ByRows.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/ByRows.fs new file mode 100644 index 00000000..98270784 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/ByRows.fs @@ -0,0 +1,60 @@ +module GraphBLAS.FSharp.Tests.Matrix.ByRows + +open Expecto +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Objects.ClVectorExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = Utils.defaultConfig + +let makeTest<'a when 'a: struct> isEqual zero testFun (array: 'a [,]) = + + let matrix = + Matrix.CSR.FromArray2D(array, isEqual zero) + + if matrix.NNZ > 0 then + + let clMatrix = matrix.ToDevice context + + let rows = testFun processor HostInterop clMatrix + + "Rows count must be the same" + |> Expect.equal (Seq.length rows) (Array2D.length1 array) + + rows + |> Seq.iteri + (fun index -> + function + | Some (actualRow: ClVector.Sparse<_>) -> + let expectedRow = + Vector.Sparse.FromArray(array.[index, *], (isEqual zero)) + + let actualHost = actualRow.ToHost processor + + Utils.compareSparseVectors isEqual actualHost expectedRow + | None -> + "Expected row must be None" + |> Expect.isFalse (Array.exists ((<<) not <| isEqual zero) array.[index, *])) + +let createTest isEqual (zero: 'a) = + CSR.Matrix.byRows context Utils.defaultWorkGroupSize + |> makeTest<'a> isEqual zero + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest (=) 0 + + if Utils.isFloat64Available context.ClDevice then + createTest Utils.floatIsEqual 0.0 + + createTest Utils.float32IsEqual 0.0f + createTest (=) false ] + |> testList "CSR byRows" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Convert.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Convert.fs new file mode 100644 index 00000000..c27bf511 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Convert.fs @@ -0,0 +1,87 @@ +module GraphBLAS.FSharp.Tests.Backend.Matrix.Convert + +open Expecto +open Expecto.Logging +open Expecto.Logging.Message +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Context +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Objects.MatrixExtensions +open GraphBLAS.FSharp.Backend.Objects.ClContext + +let logger = Log.create "Convert.Tests" + +let config = Utils.defaultConfig + +let workGroupSize = Utils.defaultWorkGroupSize + +let context = defaultContext.ClContext + +let q = defaultContext.Queue + +q.Error.Add(fun e -> failwithf "%A" e) + +let makeTest context q formatFrom formatTo convertFun isZero (array: 'a [,]) = + let mtx = + Utils.createMatrixFromArray2D formatFrom array isZero + + if mtx.NNZ > 0 then + let actual = + let mBefore = mtx.ToDevice context + let mAfter: ClMatrix<'a> = convertFun q HostInterop mBefore + let res = mAfter.ToHost q + mBefore.Dispose q + mAfter.Dispose q + res + + logger.debug ( + eventX "Actual is {actual}" + >> setField "actual" (sprintf "%A" actual) + ) + + let expected = + Utils.createMatrixFromArray2D formatTo array isZero + + "Row count should be the same" + |> Expect.equal actual.RowCount (Array2D.length1 array) + + "Column count should be the same" + |> Expect.equal actual.ColumnCount (Array2D.length2 array) + + "Matrices should be equal" + |> Expect.equal actual expected + +let createTest<'a when 'a: struct and 'a: equality> convertFun formatTo (isZero: 'a -> bool) = + let convertFun = + convertFun context Utils.defaultWorkGroupSize + + Utils.listOfUnionCases + |> List.map + (fun formatFrom -> + makeTest context q formatFrom formatTo convertFun isZero + |> testPropertyWithConfig config $"test on %A{typeof<'a>} from %A{formatFrom}") + +let testFixtures formatTo = + match formatTo with + | COO -> + [ createTest Matrix.toCOO formatTo ((=) 0) + createTest Matrix.toCOO formatTo ((=) false) ] + | CSR -> + [ createTest Matrix.toCSR formatTo ((=) 0) + createTest Matrix.toCSR formatTo ((=) false) ] + | CSC -> + [ createTest Matrix.toCSC formatTo ((=) 0) + createTest Matrix.toCSC formatTo ((=) false) ] + | LIL -> + [ createTest Matrix.toLIL formatTo ((=) 0) + createTest Matrix.toLIL formatTo ((=) false) ] + |> List.concat + |> testList $"%A{formatTo}" + +let tests = + Utils.listOfUnionCases + |> List.map testFixtures + |> testList "Convert" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/ExpandRows.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/ExpandRows.fs new file mode 100644 index 00000000..413df587 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/ExpandRows.fs @@ -0,0 +1,49 @@ +module GraphBLAS.FSharp.Tests.Backend.Matrix.ExpandRows + +open Expecto +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects.ClContext +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = Utils.defaultConfig + +let makeTest isZero testFun (array: 'a [,]) = + + let matrix = Matrix.CSR.FromArray2D(array, isZero) + + if matrix.NNZ > 0 then + + let clMatrix = matrix.ToDevice context + + let (clRows: ClArray) = testFun processor HostInterop clMatrix + + let actual = clRows.ToHostAndFree processor + + let expected = + Matrix.COO.FromArray2D(array, isZero).Rows + + "Result must be the same" + |> Expect.sequenceEqual actual expected + +let createTest (isZero: 'a -> bool) = + CSR.Matrix.expandRowPointers context Utils.defaultWorkGroupSize + |> makeTest isZero + |> testPropertyWithConfig config $"test on {typeof<'a>}" + +let tests = + [ createTest ((=) 0) + + if Utils.isFloat64Available context.ClDevice then + createTest ((=) 0.0) + + createTest ((=) 0.0f) + createTest ((=) false) ] + |> testList "Expand rows" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Kronecker.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Kronecker.fs new file mode 100644 index 00000000..add171ee --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Kronecker.fs @@ -0,0 +1,92 @@ +module GraphBLAS.FSharp.Tests.Backend.Matrix.Kronecker + +open Expecto +open Expecto.Logging +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Context +open GraphBLAS.FSharp.Tests.TestCases +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Objects.MatrixExtensions + +let config = + { Utils.defaultConfig with + endSize = 100 + maxTest = 20 } + +let logger = Log.create "kronecker.Tests" + +let workGroupSize = Utils.defaultWorkGroupSize + +let makeTest testContext zero isEqual op kroneckerFun (leftMatrix: 'a [,], rightMatrix: 'a [,]) = + let context = testContext.ClContext + let processor = testContext.Queue + + let m1 = + Utils.createMatrixFromArray2D CSR leftMatrix (isEqual zero) + + let m2 = + Utils.createMatrixFromArray2D CSR rightMatrix (isEqual zero) + + let expected = + HostPrimitives.array2DKroneckerProduct leftMatrix rightMatrix op + + let expected = + Utils.createMatrixFromArray2D COO expected (isEqual zero) + + let expectedOption = + if expected.NNZ = 0 then + None + else + expected |> Some + + if m1.NNZ > 0 && m2.NNZ > 0 then + let m1 = m1.ToDevice context + let m2 = m2.ToDevice context + + let result = + kroneckerFun processor ClContext.HostInterop m1 m2 + + let actual = + Option.map (fun (m: ClMatrix<'a>) -> m.ToHost processor) result + + m1.Dispose processor + m2.Dispose processor + + match result with + | Some m -> m.Dispose processor + | _ -> () + + // Check result + "Matrices should be equal" + |> Expect.equal actual expectedOption + +let createGeneralTest testContext (zero: 'a) isEqual op opQ testName = + Matrix.kronecker opQ testContext.ClContext workGroupSize + |> makeTest testContext zero isEqual op + |> testPropertyWithConfig config $"test on %A{typeof<'a>} %s{testName}" + +let generalTests (testContext: TestContext) = + [ testContext.Queue.Error.Add(fun e -> failwithf "%A" e) + + createGeneralTest testContext false (=) (&&) ArithmeticOperations.boolMulOption "mul" + createGeneralTest testContext false (=) (||) ArithmeticOperations.boolSumOption "sum" + + createGeneralTest testContext 0 (=) (*) ArithmeticOperations.intMulOption "mul" + createGeneralTest testContext 0 (=) (+) ArithmeticOperations.intSumOption "sum" + + createGeneralTest testContext 0uy (=) (*) ArithmeticOperations.byteMulOption "mul" + createGeneralTest testContext 0uy (=) (+) ArithmeticOperations.byteSumOption "sum" + + createGeneralTest testContext 0.0f Utils.float32IsEqual (*) ArithmeticOperations.float32MulOption "mul" + createGeneralTest testContext 0.0f Utils.float32IsEqual (+) ArithmeticOperations.float32SumOption "sum" + + if Utils.isFloat64Available testContext.ClContext.ClDevice then + createGeneralTest testContext 0.0 Utils.floatIsEqual (*) ArithmeticOperations.floatMulOption "mul" + createGeneralTest testContext 0.0 Utils.floatIsEqual (+) ArithmeticOperations.floatSumOption "sum" ] + +let tests = + gpuTests "Backend.Matrix.kronecker tests" generalTests diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Map.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Map.fs new file mode 100644 index 00000000..6276019b --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Map.fs @@ -0,0 +1,153 @@ +module GraphBLAS.FSharp.Tests.Backend.Matrix.Map + +open Expecto +open Expecto.Logging +open Expecto.Logging.Message +open Microsoft.FSharp.Collections +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Backend +open GraphBLAS.FSharp.Tests.TestCases +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Objects.MatrixExtensions + +let logger = Log.create "Map.Tests" + +let config = Utils.defaultConfig +let wgSize = Utils.defaultWorkGroupSize + +let getCorrectnessTestName case datatype = + $"Correctness on %s{datatype}, %A{case}" + +let checkResult isEqual op zero (baseMtx: 'a [,]) (actual: Matrix<'a>) = + let rows = Array2D.length1 baseMtx + let columns = Array2D.length2 baseMtx + Expect.equal columns actual.ColumnCount "The number of columns should be the same." + Expect.equal rows actual.RowCount "The number of rows should be the same." + + let expected2D = Array2D.create rows columns zero + + for i in 0 .. rows - 1 do + for j in 0 .. columns - 1 do + expected2D.[i, j] <- op baseMtx.[i, j] + + let actual2D = Array2D.create rows columns zero + + match actual with + | Matrix.COO actual -> + for i in 0 .. actual.Columns.Length - 1 do + if isEqual zero actual.Values.[i] then + failwith "Resulting zeroes should be filtered." + + actual2D.[actual.Rows.[i], actual.Columns.[i]] <- actual.Values.[i] + | _ -> failwith "Resulting matrix should be converted to COO format." + + "Arrays must be the same" + |> Utils.compare2DArrays isEqual actual2D expected2D + +let correctnessGenericTest + zero + op + (addFun: MailboxProcessor<_> -> AllocationFlag -> ClMatrix<'a> -> ClMatrix<'b>) + toCOOFun + (isEqual: 'a -> 'a -> bool) + q + (case: OperationCase) + (matrix: 'a [,]) + = + match case.Format with + | LIL -> () + | _ -> + let mtx = + Utils.createMatrixFromArray2D case.Format matrix (isEqual zero) + + if mtx.NNZ > 0 then + try + let m = mtx.ToDevice case.TestContext.ClContext + + let res = addFun q HostInterop m + + m.Dispose q + + let (cooRes: ClMatrix<'a>) = toCOOFun q HostInterop res + let actual = cooRes.ToHost q + + cooRes.Dispose q + res.Dispose q + + logger.debug ( + eventX "Actual is {actual}" + >> setField "actual" (sprintf "%A" actual) + ) + + checkResult isEqual op zero matrix actual + with + | ex when ex.Message = "InvalidBufferSize" -> () + | ex -> raise ex + +let createTestMap case (zero: 'a) (constant: 'a) binOp isEqual opQ = + let getCorrectnessTestName = getCorrectnessTestName case + + let context = case.TestContext.ClContext + let q = case.TestContext.Queue + + let unaryOp = binOp constant + let unaryOpQ = opQ zero constant + + let map = Matrix.map unaryOpQ context wgSize + + let toCOO = Matrix.toCOO context wgSize + + case + |> correctnessGenericTest zero unaryOp map toCOO isEqual q + |> testPropertyWithConfig config (getCorrectnessTestName $"{typeof<'a>}") + +let testFixturesMapNot case = + [ let q = case.TestContext.Queue + q.Error.Add(fun e -> failwithf "%A" e) + + createTestMap case false true (fun _ -> not) (=) (fun _ _ -> ArithmeticOperations.notOption) ] + +let notTests = + operationGPUTests "not" testFixturesMapNot + +let testFixturesMapAdd case = + [ let context = case.TestContext.ClContext + let q = case.TestContext.Queue + q.Error.Add(fun e -> failwithf "%A" e) + + createTestMap case 0 10 (+) (=) ArithmeticOperations.addLeftConst + + if Utils.isFloat64Available context.ClDevice then + createTestMap case 0.0 10.0 (+) Utils.floatIsEqual ArithmeticOperations.addLeftConst + + createTestMap case 0.0f 10.0f (+) Utils.float32IsEqual ArithmeticOperations.addLeftConst + + createTestMap case 0uy 10uy (+) (=) ArithmeticOperations.addLeftConst ] + +let addTests = + operationGPUTests "add" testFixturesMapAdd + +let testFixturesMapMul case = + [ let context = case.TestContext.ClContext + let q = case.TestContext.Queue + q.Error.Add(fun e -> failwithf "%A" e) + + createTestMap case 0 10 (*) (=) ArithmeticOperations.mulLeftConst + + if Utils.isFloat64Available context.ClDevice then + createTestMap case 0.0 10.0 (*) Utils.floatIsEqual ArithmeticOperations.mulLeftConst + + createTestMap case 0.0f 10.0f (*) Utils.float32IsEqual ArithmeticOperations.mulLeftConst + + createTestMap case 0uy 10uy (*) (=) ArithmeticOperations.mulLeftConst ] + +let mulTests = + operationGPUTests "mul" testFixturesMapMul + +let allTests = + testList "Map" [ addTests; mulTests; notTests ] diff --git a/tests/GraphBLAS-sharp.Tests/Matrix/Map2.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Map2.fs similarity index 66% rename from tests/GraphBLAS-sharp.Tests/Matrix/Map2.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Matrix/Map2.fs index 3c3db762..1a8e2dab 100644 --- a/tests/GraphBLAS-sharp.Tests/Matrix/Map2.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Map2.fs @@ -46,11 +46,8 @@ let checkResult isEqual op zero (baseMtx1: 'a [,]) (baseMtx2: 'a [,]) (actual: M actual2D.[actual.Rows.[i], actual.Columns.[i]] <- actual.Values.[i] | _ -> failwith "Resulting matrix should be converted to COO format." - for i in 0 .. rows - 1 do - for j in 0 .. columns - 1 do - Expect.isTrue - (isEqual actual2D.[i, j] expected2D.[i, j]) - $"Values should be the same. Actual is {actual2D.[i, j]}, expected {expected2D.[i, j]}." + "Arrays must be the same" + |> Utils.compare2DArrays isEqual actual2D expected2D let correctnessGenericTest zero @@ -62,39 +59,41 @@ let correctnessGenericTest (case: OperationCase) (leftMatrix: 'a [,], rightMatrix: 'a [,]) = + match case.Format with // TODO(map2 on LIL) + | LIL -> () + | _ -> + let mtx1 = + Utils.createMatrixFromArray2D case.Format leftMatrix (isEqual zero) - let mtx1 = - Utils.createMatrixFromArray2D case.Format leftMatrix (isEqual zero) - - let mtx2 = - Utils.createMatrixFromArray2D case.Format rightMatrix (isEqual zero) + let mtx2 = + Utils.createMatrixFromArray2D case.Format rightMatrix (isEqual zero) - if mtx1.NNZ > 0 && mtx2.NNZ > 0 then - try - let m1 = mtx1.ToDevice case.TestContext.ClContext + if mtx1.NNZ > 0 && mtx2.NNZ > 0 then + try + let m1 = mtx1.ToDevice case.TestContext.ClContext - let m2 = mtx2.ToDevice case.TestContext.ClContext + let m2 = mtx2.ToDevice case.TestContext.ClContext - let res = addFun q HostInterop m1 m2 + let res = addFun q HostInterop m1 m2 - m1.Dispose q - m2.Dispose q + m1.Dispose q + m2.Dispose q - let (cooRes: ClMatrix<'a>) = toCOOFun q HostInterop res - let actual = cooRes.ToHost q + let (cooRes: ClMatrix<'a>) = toCOOFun q HostInterop res + let actual = cooRes.ToHost q - cooRes.Dispose q - res.Dispose q + cooRes.Dispose q + res.Dispose q - logger.debug ( - eventX "Actual is {actual}" - >> setField "actual" (sprintf "%A" actual) - ) + logger.debug ( + eventX "Actual is {actual}" + >> setField "actual" (sprintf "%A" actual) + ) - checkResult isEqual op zero leftMatrix rightMatrix actual - with - | ex when ex.Message = "InvalidBufferSize" -> () - | ex -> raise ex + checkResult isEqual op zero leftMatrix rightMatrix actual + with + | ex when ex.Message = "InvalidBufferSize" -> () + | ex -> raise ex let creatTestMap2Add case (zero: 'a) add isEqual addQ map2 = let getCorrectnessTestName = getCorrectnessTestName case @@ -102,7 +101,7 @@ let creatTestMap2Add case (zero: 'a) add isEqual addQ map2 = let context = case.TestContext.ClContext let q = case.TestContext.Queue - let map2 = map2 context addQ wgSize + let map2 = map2 addQ context wgSize let toCOO = Matrix.toCOO context wgSize @@ -115,14 +114,14 @@ let testFixturesMap2Add case = let q = case.TestContext.Queue q.Error.Add(fun e -> failwithf "%A" e) - creatTestMap2Add case false (||) (=) ArithmeticOperations.boolSum Matrix.map2 - creatTestMap2Add case 0 (+) (=) ArithmeticOperations.intSum Matrix.map2 + creatTestMap2Add case false (||) (=) ArithmeticOperations.boolSumOption Matrix.map2 + creatTestMap2Add case 0 (+) (=) ArithmeticOperations.intSumOption Matrix.map2 if Utils.isFloat64Available context.ClDevice then - creatTestMap2Add case 0.0 (+) Utils.floatIsEqual ArithmeticOperations.floatSum Matrix.map2 + creatTestMap2Add case 0.0 (+) Utils.floatIsEqual ArithmeticOperations.floatSumOption Matrix.map2 - creatTestMap2Add case 0.0f (+) Utils.float32IsEqual ArithmeticOperations.float32Sum Matrix.map2 - creatTestMap2Add case 0uy (+) (=) ArithmeticOperations.byteSum Matrix.map2 ] + creatTestMap2Add case 0.0f (+) Utils.float32IsEqual ArithmeticOperations.float32SumOption Matrix.map2 + creatTestMap2Add case 0uy (+) (=) ArithmeticOperations.byteSumOption Matrix.map2 ] let addTests = operationGPUTests "Backend.Matrix.map2 add tests" testFixturesMap2Add @@ -152,36 +151,6 @@ let testFixturesMap2AddAtLeastOne case = let addAtLeastOneTests = operationGPUTests "Backend.Matrix.map2AtLeastOne add tests" testFixturesMap2AddAtLeastOne -let testFixturesMap2AddAtLeastOneToCOO case = - [ let context = case.TestContext.ClContext - let q = case.TestContext.Queue - q.Error.Add(fun e -> failwithf "%A" e) - - creatTestMap2Add case false (||) (=) ArithmeticOperations.boolSumAtLeastOne Matrix.map2AtLeastOneToCOO - creatTestMap2Add case 0 (+) (=) ArithmeticOperations.intSumAtLeastOne Matrix.map2AtLeastOneToCOO - - if Utils.isFloat64Available context.ClDevice then - creatTestMap2Add - case - 0.0 - (+) - Utils.floatIsEqual - ArithmeticOperations.floatSumAtLeastOne - Matrix.map2AtLeastOneToCOO - - creatTestMap2Add - case - 0.0f - (+) - Utils.float32IsEqual - ArithmeticOperations.float32SumAtLeastOne - Matrix.map2AtLeastOneToCOO - - creatTestMap2Add case 0uy (+) (=) ArithmeticOperations.byteSumAtLeastOne Matrix.map2AtLeastOneToCOO ] - -let addAtLeastOneToCOOTests = - operationGPUTests "Backend.Matrix.map2AtLeastOneToCOO add tests" testFixturesMap2AddAtLeastOneToCOO - let testFixturesMap2MulAtLeastOne case = [ let context = case.TestContext.ClContext let q = case.TestContext.Queue @@ -205,3 +174,10 @@ let testFixturesMap2MulAtLeastOne case = let mulAtLeastOneTests = operationGPUTests "Backend.Matrix.map2AtLeastOne multiplication tests" testFixturesMap2MulAtLeastOne + +let allTests = + testList + "Map2" + [ addTests + addAtLeastOneTests + mulAtLeastOneTests ] diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Merge.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Merge.fs new file mode 100644 index 00000000..fef357de --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Merge.fs @@ -0,0 +1,177 @@ +module GraphBLAS.FSharp.Tests.Matrix.Merge + +open Brahma.FSharp +open Expecto +open Microsoft.FSharp.Collections +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Backend +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = Utils.defaultConfig + +let checkResult isEqual zero (actual: Matrix.COO<'a>) (leftArray: 'a [,]) (rightArray: 'a [,]) = + + let leftMatrix = + Matrix.COO.FromArray2D(leftArray, isEqual zero) + + let rightMatrix = + Matrix.COO.FromArray2D(rightArray, isEqual zero) + + let expectedRows, expectedColumns, expectedValues = + let leftKeys = + Seq.zip3 leftMatrix.Rows leftMatrix.Columns leftMatrix.Values + + let rightKeys = + Seq.zip3 rightMatrix.Rows rightMatrix.Columns rightMatrix.Values + + // right first + Seq.concat [ rightKeys; leftKeys ] + |> Seq.sortBy (fun (fstKey, sndKey, _) -> (fstKey, sndKey)) + |> Seq.toArray + |> Array.unzip3 + + "Rows must be the same" + |> Expect.sequenceEqual actual.Rows expectedRows + + "Columns must be the same" + |> Expect.sequenceEqual actual.Columns expectedColumns + + "Values must be the same" + |> Utils.compareArrays isEqual actual.Values expectedValues + +let makeTestCOO isEqual zero testFun (leftArray: 'a [,], rightArray: 'a [,]) = + + let leftMatrix = + Matrix.COO.FromArray2D(leftArray, isEqual zero) + + let rightMatrix = + Matrix.COO.FromArray2D(rightArray, isEqual zero) + + if leftMatrix.NNZ > 0 && rightMatrix.NNZ > 0 then + + let clLeftMatrix = leftMatrix.ToDevice context + + let clRightMatrix = rightMatrix.ToDevice context + + let ((clRows: ClArray), + (clColumns: ClArray), + (clLeftValues: ClArray<'a>), + (clRightValues: ClArray<'a>), + (clIsLeft: ClArray)) = + testFun processor clLeftMatrix clRightMatrix + + clLeftMatrix.Dispose processor + clRightMatrix.Dispose processor + + let leftValues = clLeftValues.ToHostAndFree processor + let rightValues = clRightValues.ToHostAndFree processor + let isLeft = clIsLeft.ToHostAndFree processor + + let actualValues = + Array.map3 + (fun leftValue rightValue isLeft -> + if isLeft = 1 then + leftValue + else + rightValue) + <| leftValues + <| rightValues + <| isLeft + + let actual = + { Matrix.COO.RowCount = leftMatrix.RowCount + Matrix.COO.ColumnCount = leftMatrix.ColumnCount + Matrix.COO.Rows = clRows.ToHostAndFree processor + Matrix.COO.Columns = clColumns.ToHostAndFree processor + Matrix.COO.Values = actualValues } + + checkResult isEqual zero actual leftArray rightArray + +let createTestCOO isEqual (zero: 'a) = + Matrix.COO.Merge.run context Utils.defaultWorkGroupSize + |> makeTestCOO isEqual zero + |> testPropertyWithConfig config $"test on {typeof<'a>}" + +let testsCOO = + [ createTestCOO (=) 0 + + if Utils.isFloat64Available context.ClDevice then + createTestCOO (=) 0.0 + + createTestCOO (=) 0.0f + createTestCOO (=) false ] + |> testList "COO" + +let makeTestCSR isEqual zero testFun (leftArray: 'a [,], rightArray: 'a [,]) = + let leftMatrix = + Matrix.CSR.FromArray2D(leftArray, isEqual zero) + + let rightMatrix = + Matrix.CSR.FromArray2D(rightArray, isEqual zero) + + if leftMatrix.NNZ > 0 && rightMatrix.NNZ > 0 then + + let clLeftMatrix = leftMatrix.ToDevice context + + let clRightMatrix = rightMatrix.ToDevice context + + let ((clRows: ClArray), + (clColumns: ClArray), + (clLeftValues: ClArray<'a>), + (clRightValues: ClArray<'a>), + (clIsEndOfRow: ClArray), + (clIsLeft: ClArray)) = + testFun processor clLeftMatrix clRightMatrix + + clLeftMatrix.Dispose processor + clRightMatrix.Dispose processor + + let leftValues = clLeftValues.ToHostAndFree processor + let rightValues = clRightValues.ToHostAndFree processor + clIsEndOfRow.Free processor + let isLeft = clIsLeft.ToHostAndFree processor + + let actualValues = + Array.map3 + (fun leftValue rightValue isLeft -> + if isLeft = 1 then + leftValue + else + rightValue) + <| leftValues + <| rightValues + <| isLeft + + let actual = + { Matrix.COO.RowCount = leftMatrix.RowCount + Matrix.COO.ColumnCount = leftMatrix.ColumnCount + Matrix.COO.Rows = clRows.ToHostAndFree processor + Matrix.COO.Columns = clColumns.ToHostAndFree processor + Matrix.COO.Values = actualValues } + + checkResult isEqual zero actual leftArray rightArray + +let createTestCSR isEqual (zero: 'a) = + Matrix.CSR.Merge.run context Utils.defaultWorkGroupSize + |> makeTestCSR isEqual zero + |> testPropertyWithConfig config $"test on {typeof<'a>}" + +let testsCSR = + [ createTestCSR (=) 0 + + if Utils.isFloat64Available context.ClDevice then + createTestCSR (=) 0.0 + + createTestCSR (=) 0.0f + createTestCSR (=) false ] + |> testList "CSR" + +let allTests = + [ testsCSR; testsCOO ] |> testList "Merge" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/RowsLengths.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/RowsLengths.fs new file mode 100644 index 00000000..6aab0988 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/RowsLengths.fs @@ -0,0 +1,65 @@ +module GraphBLAS.FSharp.Tests.Backend.Matrix.RowsLengths + +open Expecto +open Microsoft.FSharp.Collections +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Backend +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects.ClContext + +let processor = Context.defaultContext.Queue + +let context = Context.defaultContext.ClContext + +let config = Utils.defaultConfig + +let makeTest isZero testFun (array: 'a [,]) = + + let matrix = Matrix.CSR.FromArray2D(array, isZero) + + if matrix.NNZ > 0 then + + let clMatrix = matrix.ToDevice context + let (clActual: ClArray) = testFun processor HostInterop clMatrix + + clMatrix.Dispose processor + let actual = clActual.ToHostAndFree processor + + let expected = + Array.zeroCreate <| Array2D.length1 array + + // count nnz in each row + for i in 0 .. Array2D.length1 array - 1 do + let nnzRowCount = + array.[i, *] + |> Array.fold + (fun count item -> + if not <| isZero item then + count + 1 + else + count) + 0 + + expected.[i] <- nnzRowCount + + "Results must be the same" + |> Utils.compareArrays (=) actual expected + +let createTest<'a when 'a: struct> (isZero: 'a -> bool) = + CSR.Matrix.NNZInRows context Utils.defaultWorkGroupSize + |> makeTest isZero + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest <| (=) 0 + + if Utils.isFloat64Available context.ClDevice then + createTest <| Utils.floatIsEqual 0.0 + + createTest <| Utils.float32IsEqual 0.0f + createTest <| (=) false ] + |> testList "CSR.RowsLengths" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/SpGeMM/Expand.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/SpGeMM/Expand.fs new file mode 100644 index 00000000..67eac9d3 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/SpGeMM/Expand.fs @@ -0,0 +1,235 @@ +module GraphBLAS.FSharp.Tests.Matrix.SpGeMM.Expand + +open Expecto +open GraphBLAS.FSharp.Backend.Matrix.SpGeMM +open GraphBLAS.FSharp.Backend.Quotes +open GraphBLAS.FSharp.Test +open Microsoft.FSharp.Collections +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Backend +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Objects.MatrixExtensions + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let getSegmentsPointers (leftMatrixColumns: int []) (rightRowsPointers: int []) = + Array.map + (fun item -> + rightRowsPointers.[item + 1] + - rightRowsPointers.[item]) + leftMatrixColumns + |> HostPrimitives.prefixSumExclude 0 (+) + +let makeTest isZero testFun (leftArray: 'a [,], rightArray: 'a [,]) = + + let leftMatrix = + Matrix.CSR.FromArray2D(leftArray, isZero) + + let rightMatrix = + Matrix.CSR.FromArray2D(rightArray, isZero) + + if leftMatrix.NNZ > 0 && rightMatrix.NNZ > 0 then + + let clLeftMatrix = leftMatrix.ToDevice context + + let clRightMatrix = rightMatrix.ToDevice context + + let actualLength, (clActual: ClArray) = + testFun processor clLeftMatrix.Columns clRightMatrix.RowPointers + + clLeftMatrix.Dispose processor + clRightMatrix.Dispose processor + + let actualPointers = clActual.ToHostAndFree processor + + let expectedPointers, expectedLength = + getSegmentsPointers leftMatrix.ColumnIndices rightMatrix.RowPointers + + "Results lengths must be the same" + |> Expect.equal actualLength expectedLength + + "Result pointers must be the same" + |> Expect.sequenceEqual actualPointers expectedPointers + +let createTest<'a when 'a: struct> (isZero: 'a -> bool) = + Expand.getSegmentPointers context Utils.defaultWorkGroupSize + |> makeTest isZero + |> testPropertyWithConfig config $"test on {typeof<'a>}" + +let getSegmentsTests = + [ createTest ((=) 0) + + if Utils.isFloat64Available context.ClDevice then + createTest ((=) 0.0) + + createTest ((=) 0f) + createTest ((=) false) + createTest ((=) 0uy) ] + |> testList "get segment pointers" + +let expand length segmentPointers (leftMatrix: Matrix.COO<'a>) (rightMatrix: Matrix.CSR<'b>) = + let segmentsLengths = + Array.append segmentPointers [| length |] + |> Array.pairwise + |> Array.map (fun (fst, snd) -> snd - fst) + + let leftMatrixValues, expectedRows = + let tripleFst (fst, _, _) = fst + + Array.zip3 segmentsLengths leftMatrix.Values leftMatrix.Rows + // select items each segment length not zero + |> Array.filter (tripleFst >> ((=) 0) >> not) + |> Array.collect (fun (length, value, rowIndex) -> Array.create length (value, rowIndex)) + |> Array.unzip + + let rightMatrixValues, expectedColumns = + let valuesAndColumns = + Array.zip rightMatrix.Values rightMatrix.ColumnIndices + + Array.map2 + (fun column length -> + let rowStart = rightMatrix.RowPointers.[column] + Array.take length valuesAndColumns.[rowStart..]) + leftMatrix.Columns + segmentsLengths + |> Array.concat + |> Array.unzip + + leftMatrixValues, rightMatrixValues, expectedColumns, expectedRows + +// Expand tests (debug only) +let makeExpandTest isEqual zero testFun (leftArray: 'a [,], rightArray: 'a [,]) = + + let leftMatrix = + Matrix.COO.FromArray2D(leftArray, isEqual zero) + + let rightMatrix = + Matrix.CSR.FromArray2D(rightArray, isEqual zero) + + if leftMatrix.NNZ > 0 && rightMatrix.NNZ > 0 then + + let segmentPointers, length = + getSegmentsPointers leftMatrix.Columns rightMatrix.RowPointers + + if length > 0 then + let clLeftMatrix = leftMatrix.ToDevice context + let clRightMatrix = rightMatrix.ToDevice context + let clSegmentPointers = context.CreateClArray segmentPointers + + let (clActualLeftValues: ClArray<'a>, + clActualRightValues: ClArray<'a>, + clActualColumns: ClArray, + clActualRows: ClArray) = + testFun processor length clSegmentPointers clLeftMatrix clRightMatrix + + clLeftMatrix.Dispose processor + clRightMatrix.Dispose processor + clSegmentPointers.Free processor + + let actualLeftValues = + clActualLeftValues.ToHostAndFree processor + + let actualRightValues = + clActualRightValues.ToHostAndFree processor + + let actualColumns = clActualColumns.ToHostAndFree processor + let actualRows = clActualRows.ToHostAndFree processor + + let expectedLeftMatrixValues, expectedRightMatrixValues, expectedColumns, expectedRows = + expand length segmentPointers leftMatrix rightMatrix + + "Left values must be the same" + |> Utils.compareArrays isEqual actualLeftValues expectedLeftMatrixValues + + "Right values must be the same" + |> Utils.compareArrays isEqual actualRightValues expectedRightMatrixValues + + "Columns must be the same" + |> Utils.compareArrays (=) actualColumns expectedColumns + + "Rows must be the same" + |> Utils.compareArrays (=) actualRows expectedRows + +let createExpandTest isEqual (zero: 'a) testFun = + testFun context Utils.defaultWorkGroupSize + |> makeExpandTest isEqual zero + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +// expand phase tests +let expandTests = + [ createExpandTest (=) 0 Expand.expand + + if Utils.isFloat64Available context.ClDevice then + createExpandTest Utils.floatIsEqual 0.0 Expand.expand + + createExpandTest Utils.float32IsEqual 0f Expand.expand + createExpandTest (=) false Expand.expand + createExpandTest (=) 0uy Expand.expand ] + |> testList "Expand.expand" + +let makeGeneralTest zero isEqual opAdd opMul testFun (leftArray: 'a [,], rightArray: 'a [,]) = + + let leftMatrix = + Utils.createMatrixFromArray2D CSR leftArray (isEqual zero) + + let rightMatrix = + Utils.createMatrixFromArray2D CSR rightArray (isEqual zero) + + if leftMatrix.NNZ > 0 && rightMatrix.NNZ > 0 then + let clLeftMatrix = leftMatrix.ToDevice context + let clRightMatrix = rightMatrix.ToDevice context + + let (clMatrixActual: ClMatrix.COO<_> option) = + testFun processor HostInterop clLeftMatrix clRightMatrix + + let expected = + HostPrimitives.array2DMultiplication zero opMul opAdd leftArray rightArray + |> fun array -> Matrix.COO.FromArray2D(array, isEqual zero) + + match clMatrixActual with + | Some clMatrixActual -> + + let matrixActual = clMatrixActual.ToHost processor + clMatrixActual.Dispose processor + + Utils.compareCOOMatrix isEqual matrixActual expected + | None -> + "Expected should be empty" + |> Expect.isTrue (expected.NNZ = 0) + +let createGeneralTest (zero: 'a) isEqual (opAddQ, opAdd) (opMulQ, opMul) testFun = + testFun opAddQ opMulQ context Utils.defaultWorkGroupSize + |> makeGeneralTest zero isEqual opAdd opMul + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let generalTests = + [ createGeneralTest 0 (=) ArithmeticOperations.intAdd ArithmeticOperations.intMul Matrix.SpGeMM.expand + + if Utils.isFloat64Available context.ClDevice then + createGeneralTest + 0.0 + Utils.floatIsEqual + ArithmeticOperations.floatAdd + ArithmeticOperations.floatMul + Matrix.SpGeMM.expand + + createGeneralTest + 0.0f + Utils.float32IsEqual + ArithmeticOperations.float32Add + ArithmeticOperations.float32Mul + Matrix.SpGeMM.expand + createGeneralTest false (=) ArithmeticOperations.boolAdd ArithmeticOperations.boolMul Matrix.SpGeMM.expand ] + |> testList "general" diff --git a/tests/GraphBLAS-sharp.Tests/Matrix/Mxm.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/SpGeMM/Masked.fs similarity index 91% rename from tests/GraphBLAS-sharp.Tests/Matrix/Mxm.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Matrix/SpGeMM/Masked.fs index 236f0973..7304b96e 100644 --- a/tests/GraphBLAS-sharp.Tests/Matrix/Mxm.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/SpGeMM/Masked.fs @@ -1,4 +1,4 @@ -module GraphBLAS.FSharp.Tests.Backend.Matrix.Mxm +module GraphBLAS.FSharp.Tests.Backend.Matrix.SpGeMM.Masked open Expecto open Expecto.Logging @@ -11,7 +11,7 @@ open GraphBLAS.FSharp.Backend.Objects open GraphBLAS.FSharp.Objects.MatrixExtensions open GraphBLAS.FSharp.Test -let logger = Log.create "Mxm.Tests" +let logger = Log.create "SpGeMM.Masked.Tests" let context = defaultContext.ClContext let workGroupSize = Utils.defaultWorkGroupSize @@ -79,7 +79,7 @@ let tests = let mult = <@ fun x y -> Some(x * y) @> let mxmFun = - Matrix.mxm add mult context workGroupSize + Matrix.SpGeMM.masked add mult context workGroupSize makeTest context q 0 (=) (+) (*) mxmFun |> testPropertyWithConfig config (getCorrectnessTestName "int") @@ -105,8 +105,8 @@ let tests = res @> let mxmFun = - Matrix.mxm logicalOr logicalAnd context workGroupSize + Matrix.SpGeMM.masked logicalOr logicalAnd context workGroupSize makeTest context q false (=) (||) (&&) mxmFun |> testPropertyWithConfig config (getCorrectnessTestName "bool") ] - |> testList "Mxm tests" + |> testList "SpGeMM masked tests" diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Matrix/SubRows.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/SubRows.fs new file mode 100644 index 00000000..e48a20e0 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/SubRows.fs @@ -0,0 +1,66 @@ +module GraphBLAS.FSharp.Tests.Backend.Matrix.SubRows + +open Expecto +open GraphBLAS.FSharp.Test +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Backend.Matrix +open GraphBLAS.FSharp.Backend.Objects.ClContext +open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Objects.MatrixExtensions +open GraphBLAS.FSharp.Objects.Matrix + +let context = Context.defaultContext.ClContext + +let processor = Context.defaultContext.Queue + +let config = + { Utils.defaultConfig with + arbitrary = [ typeof ] } + +let makeTest isEqual zero testFun (array: 'a [,], sourceRow, count) = + + let matrix = + Matrix.CSR.FromArray2D(array, isEqual zero) + + if matrix.NNZ > 0 then + + let clMatrix = matrix.ToDevice context + + let clActual: ClMatrix.COO<'a> = + testFun processor HostInterop sourceRow count clMatrix + + let actual = clActual.ToHostAndFree processor + + let expected = + array + |> Array2D.mapi (fun rowIndex columnIndex value -> (value, rowIndex, columnIndex)) + |> fun array -> array.[sourceRow..sourceRow + count - 1, *] + |> Seq.cast<'a * int * int> + |> Seq.filter (fun (value, _, _) -> (not <| isEqual zero value)) + |> Seq.toArray + |> Array.unzip3 + |> fun (values, rows, columns) -> + { RowCount = Array2D.length1 array + ColumnCount = Array2D.length2 array + Rows = rows + Columns = columns + Values = values } + + Utils.compareCOOMatrix isEqual actual expected + +let createTest isEqual (zero: 'a) = + CSR.Matrix.subRows context Utils.defaultWorkGroupSize + |> makeTest isEqual zero + |> testPropertyWithConfig config $"test on {typeof<'a>}" + +let tests = + [ createTest (=) 0 + + if Utils.isFloat64Available context.ClDevice then + createTest (=) 0.0 + + createTest (=) 0.0f + createTest (=) false ] + |> testList "Blit" diff --git a/tests/GraphBLAS-sharp.Tests/Matrix/Transpose.fs b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Transpose.fs similarity index 85% rename from tests/GraphBLAS-sharp.Tests/Matrix/Transpose.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Matrix/Transpose.fs index 4e894609..01e78bf7 100644 --- a/tests/GraphBLAS-sharp.Tests/Matrix/Transpose.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Matrix/Transpose.fs @@ -77,28 +77,32 @@ let checkResult areEqual zero actual (expected2D: 'a [,]) = "Value arrays should be equal" |> Utils.compareArrays areEqual actual.Values expected.Values + | _ -> () // TODO() let makeTestRegular context q transposeFun hostTranspose isEqual zero case (array: 'a [,]) = - let mtx = - Utils.createMatrixFromArray2D case.Format array (isEqual zero) - - if mtx.NNZ > 0 then - let actual = - let m = mtx.ToDevice context - let (mT: ClMatrix<'a>) = transposeFun q HostInterop m - let res = mT.ToHost q - m.Dispose q - mT.Dispose q - res - - logger.debug ( - eventX "Actual is {actual}" - >> setField "actual" $"%A{actual}" - ) - - let expected2D = hostTranspose array - - checkResult isEqual zero actual expected2D + match case.Format with + | LIL -> () + | _ -> + let mtx = + Utils.createMatrixFromArray2D case.Format array (isEqual zero) + + if mtx.NNZ > 0 then + let actual = + let m = mtx.ToDevice context + let (mT: ClMatrix<'a>) = transposeFun q HostInterop m + let res = mT.ToHost q + m.Dispose q + mT.Dispose q + res + + logger.debug ( + eventX "Actual is {actual}" + >> setField "actual" $"%A{actual}" + ) + + let expected2D = hostTranspose array + + checkResult isEqual zero actual expected2D let createTest<'a when 'a: equality and 'a: struct> case (zero: 'a) isEqual = let context = case.TestContext.ClContext diff --git a/tests/GraphBLAS-sharp.Tests/QuickGraph/Algorithms/BFS.fs b/tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/Algorithms/BFS.fs similarity index 97% rename from tests/GraphBLAS-sharp.Tests/QuickGraph/Algorithms/BFS.fs rename to tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/Algorithms/BFS.fs index 287d2b3a..77af14b0 100644 --- a/tests/GraphBLAS-sharp.Tests/QuickGraph/Algorithms/BFS.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/Algorithms/BFS.fs @@ -1,4 +1,4 @@ -namespace GraphBLAS.FSharp.Tests.QuickGraph.Algorithms +namespace GraphBLAS.FSharp.Tests.Backend.QuickGraph.Algorithms open System.Collections.Generic open QuikGraph diff --git a/tests/GraphBLAS-sharp.Tests/QuickGraph/Algorithms/ConnectedComponents.fs b/tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/Algorithms/ConnectedComponents.fs similarity index 92% rename from tests/GraphBLAS-sharp.Tests/QuickGraph/Algorithms/ConnectedComponents.fs rename to tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/Algorithms/ConnectedComponents.fs index bbf89add..1f9f0f65 100644 --- a/tests/GraphBLAS-sharp.Tests/QuickGraph/Algorithms/ConnectedComponents.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/Algorithms/ConnectedComponents.fs @@ -1,4 +1,4 @@ -namespace GraphBLAS.FSharp.Tests.QuickGraph.Algorithms +namespace GraphBLAS.FSharp.Tests.Backend.QuickGraph.Algorithms open System.Collections.Generic open QuikGraph diff --git a/tests/GraphBLAS-sharp.Tests/QuickGraph/CreateGraph.fs b/tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/CreateGraph.fs similarity index 94% rename from tests/GraphBLAS-sharp.Tests/QuickGraph/CreateGraph.fs rename to tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/CreateGraph.fs index d3f68d07..7684d586 100644 --- a/tests/GraphBLAS-sharp.Tests/QuickGraph/CreateGraph.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/QuickGraph/CreateGraph.fs @@ -1,4 +1,4 @@ -namespace GraphBLAS.FSharp.Tests.QuickGraph +namespace GraphBLAS.FSharp.Tests.Backend.QuickGraph open QuikGraph diff --git a/tests/GraphBLAS-sharp.Tests/Vector/AssignByMask.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/AssignByMask.fs similarity index 98% rename from tests/GraphBLAS-sharp.Tests/Vector/AssignByMask.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Vector/AssignByMask.fs index c4193eb3..50dab7c2 100644 --- a/tests/GraphBLAS-sharp.Tests/Vector/AssignByMask.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Vector/AssignByMask.fs @@ -96,7 +96,7 @@ let createTest case (isZero: 'a -> bool) isComplemented fill = let context = case.TestContext.ClContext let getCorrectnessTestName = getCorrectnessTestName case - let fill = fill context Mask.assign wgSize + let fill = fill Mask.assign context wgSize let toCoo = Vector.toDense context wgSize diff --git a/tests/GraphBLAS-sharp.Tests/Vector/Convert.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/Convert.fs similarity index 100% rename from tests/GraphBLAS-sharp.Tests/Vector/Convert.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Vector/Convert.fs diff --git a/tests/GraphBLAS-sharp.Tests/Vector/Copy.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/Copy.fs similarity index 100% rename from tests/GraphBLAS-sharp.Tests/Vector/Copy.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Vector/Copy.fs diff --git a/tests/GraphBLAS-sharp.Tests/Vector/Map2.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/Map2.fs similarity index 70% rename from tests/GraphBLAS-sharp.Tests/Vector/Map2.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Vector/Map2.fs index f5327daf..e5eadaa4 100644 --- a/tests/GraphBLAS-sharp.Tests/Vector/Map2.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Vector/Map2.fs @@ -90,7 +90,7 @@ let correctnessGenericTest let createTest case isEqual (zero: 'a) plus plusQ map2 = let context = case.TestContext.ClContext - let map2 = map2 context plusQ wgSize + let map2 = map2 plusQ context wgSize let intToDense = Vector.toDense context wgSize @@ -101,32 +101,30 @@ let createTest case isEqual (zero: 'a) plus plusQ map2 = let addTestFixtures case = let context = case.TestContext.ClContext - [ createTest case (=) 0 (+) ArithmeticOperations.intSum Vector.map2 + [ createTest case (=) 0 (+) ArithmeticOperations.intSumOption Vector.map2 if Utils.isFloat64Available context.ClDevice then - createTest case Utils.floatIsEqual 0.0 (+) ArithmeticOperations.floatSum Vector.map2 + createTest case Utils.floatIsEqual 0.0 (+) ArithmeticOperations.floatSumOption Vector.map2 - createTest case Utils.float32IsEqual 0.0f (+) ArithmeticOperations.float32Sum Vector.map2 - createTest case (=) false (||) ArithmeticOperations.boolSum Vector.map2 - createTest case (=) 0uy (+) ArithmeticOperations.byteSum Vector.map2 ] + createTest case Utils.float32IsEqual 0.0f (+) ArithmeticOperations.float32SumOption Vector.map2 + createTest case (=) false (||) ArithmeticOperations.boolSumOption Vector.map2 + createTest case (=) 0uy (+) ArithmeticOperations.byteSumOption Vector.map2 ] -let addTests = - operationGPUTests "Backend.Vector.Map2 add tests" addTestFixtures +let addTests = operationGPUTests "add" addTestFixtures let mulTestFixtures case = let context = case.TestContext.ClContext - [ createTest case (=) 0 (*) ArithmeticOperations.intMul Vector.map2 + [ createTest case (=) 0 (*) ArithmeticOperations.intMulOption Vector.map2 if Utils.isFloat64Available context.ClDevice then - createTest case Utils.floatIsEqual 0.0 (*) ArithmeticOperations.floatMul Vector.map2 + createTest case Utils.floatIsEqual 0.0 (*) ArithmeticOperations.floatMulOption Vector.map2 - createTest case Utils.float32IsEqual 0.0f (*) ArithmeticOperations.float32Mul Vector.map2 - createTest case (=) false (&&) ArithmeticOperations.boolMul Vector.map2 - createTest case (=) 0uy (*) ArithmeticOperations.byteMul Vector.map2 ] + createTest case Utils.float32IsEqual 0.0f (*) ArithmeticOperations.float32MulOption Vector.map2 + createTest case (=) false (&&) ArithmeticOperations.boolMulOption Vector.map2 + createTest case (=) 0uy (*) ArithmeticOperations.byteMulOption Vector.map2 ] -let mulTests = - operationGPUTests "Backend.Vector.map2 mul tests" addTestFixtures +let mulTests = operationGPUTests "mul" addTestFixtures let addAtLeastOneTestFixtures case = let context = case.TestContext.ClContext @@ -141,7 +139,7 @@ let addAtLeastOneTestFixtures case = createTest case (=) 0uy (+) ArithmeticOperations.byteSumAtLeastOne Vector.map2AtLeastOne ] let addAtLeastOneTests = - operationGPUTests "Backend.Vector.Map2LeastOne add tests" addTestFixtures + operationGPUTests "addAtLeastOne" addTestFixtures let mulAtLeastOneTestFixtures case = let context = case.TestContext.ClContext @@ -156,34 +154,7 @@ let mulAtLeastOneTestFixtures case = createTest case (=) 0uy (*) ArithmeticOperations.byteMulAtLeastOne Vector.map2AtLeastOne ] let mulAtLeastOneTests = - operationGPUTests "Backend.Vector.Map2AtLeasOne mul tests" mulTestFixtures - -let addGeneralTestFixtures (case: OperationCase) = - let context = case.TestContext.ClContext - - [ createTest case (=) 0 (+) ArithmeticOperations.intSum Vector.map2General - - if Utils.isFloat64Available context.ClDevice then - createTest case Utils.floatIsEqual 0.0 (+) ArithmeticOperations.floatSum Vector.map2General - - createTest case Utils.float32IsEqual 0.0f (+) ArithmeticOperations.float32Sum Vector.map2General - createTest case (=) false (||) ArithmeticOperations.boolSum Vector.map2General - createTest case (=) 0uy (+) ArithmeticOperations.byteSum Vector.map2General ] - -let addGeneralTests = - operationGPUTests "Backend.Vector.Map2Gen add tests" addGeneralTestFixtures - -let mulGeneralTestFixtures case = - let context = case.TestContext.ClContext - - [ createTest case (=) 0 (*) ArithmeticOperations.intMul Vector.map2General - - if Utils.isFloat64Available context.ClDevice then - createTest case Utils.floatIsEqual 0.0 (*) ArithmeticOperations.floatMul Vector.map2General - - createTest case Utils.float32IsEqual 0.0f (*) ArithmeticOperations.float32Mul Vector.map2General - createTest case (=) false (&&) ArithmeticOperations.boolMul Vector.map2General - createTest case (=) 0uy (*) ArithmeticOperations.byteMul Vector.map2General ] + operationGPUTests "mulAtLeastOne" mulTestFixtures let fillSubVectorComplementedQ<'a, 'b> value = <@ fun (left: 'a option) (right: 'b option) -> @@ -198,13 +169,10 @@ let fillSubVectorFun value zero isEqual = else right -let mulGeneralTests = - operationGPUTests "Backend.Vector.SparseVector.map2Gen mul tests" mulGeneralTestFixtures - let complementedGeneralTestFixtures case = let context = case.TestContext.ClContext - [ createTest case (=) 0 (fillSubVectorFun 1 0 (=)) (fillSubVectorComplementedQ 1) Vector.map2General + [ createTest case (=) 0 (fillSubVectorFun 1 0 (=)) (fillSubVectorComplementedQ 1) Vector.map2 if Utils.isFloat64Available context.ClDevice then createTest @@ -213,7 +181,7 @@ let complementedGeneralTestFixtures case = 0.0 (fillSubVectorFun 1.0 0.0 Utils.floatIsEqual) (fillSubVectorComplementedQ 1.0) - Vector.map2General + Vector.map2 createTest case @@ -221,12 +189,21 @@ let complementedGeneralTestFixtures case = 0.0f (fillSubVectorFun 1.0f 0.0f Utils.float32IsEqual) (fillSubVectorComplementedQ 1.0f) - Vector.map2General + Vector.map2 - createTest case (=) false (fillSubVectorFun true false (=)) (fillSubVectorComplementedQ true) Vector.map2General + createTest case (=) false (fillSubVectorFun true false (=)) (fillSubVectorComplementedQ true) Vector.map2 - createTest case (=) 0uy (fillSubVectorFun 1uy 0uy (=)) (fillSubVectorComplementedQ 1uy) Vector.map2General ] + createTest case (=) 0uy (fillSubVectorFun 1uy 0uy (=)) (fillSubVectorComplementedQ 1uy) Vector.map2 ] let complementedGeneralTests = - operationGPUTests "Backend.Vector.Map2Gen mask tests" complementedGeneralTestFixtures + operationGPUTests "mask" complementedGeneralTestFixtures + +let allTests = + testList + "Map" + [ addTests + mulTests + addAtLeastOneTests + mulAtLeastOneTests + complementedGeneralTests ] diff --git a/tests/GraphBLAS-sharp.Tests/Backend/Vector/Merge.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/Merge.fs new file mode 100644 index 00000000..af693c80 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Backend/Vector/Merge.fs @@ -0,0 +1,92 @@ +module GraphBLAS.FSharp.Tests.Vector.Merge + +open GraphBLAS.FSharp.Backend.Vector +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Backend.Objects.ArraysExtensions +open Brahma.FSharp +open Expecto +open GraphBLAS.FSharp.Backend + +let processor = Context.defaultContext.Queue + +let context = Context.defaultContext.ClContext + +let config = Utils.defaultConfig + +let makeTest isEqual zero testFun (firstArray: 'a []) (secondArray: 'a []) = + let firstVector = + Vector.Sparse.FromArray(firstArray, isEqual zero) + + let secondVector = + Vector.Sparse.FromArray(secondArray, isEqual zero) + + if firstVector.NNZ > 0 && secondVector.NNZ > 0 then + + // actual run + let clFirstVector = firstVector.ToDevice context + + let clSecondVector = secondVector.ToDevice context + + let ((allIndices: ClArray), + (firstValues: ClArray<'a>), + (secondValues: ClArray<'a>), + (isLeftBitmap: ClArray)) = + testFun processor clFirstVector clSecondVector + + clFirstVector.Dispose processor + clSecondVector.Dispose processor + + let actualIndices = allIndices.ToHostAndFree processor + let actualFirstValues = firstValues.ToHostAndFree processor + let actualSecondValues = secondValues.ToHostAndFree processor + let actualIsLeftBitmap = isLeftBitmap.ToHostAndFree processor + + let actualValues = + (actualFirstValues, actualSecondValues, actualIsLeftBitmap) + |||> Array.map3 + (fun leftValue rightValue isLeft -> + if isLeft = 1 then + leftValue + else + rightValue) + + // expected run + let firstValuesAndIndices = + Array.map2 (fun value index -> (value, index)) firstVector.Values firstVector.Indices + + let secondValuesAndIndices = + Array.map2 (fun value index -> (value, index)) secondVector.Values secondVector.Indices + + // preserve order of values then use stable sort + let allValuesAndIndices = + Array.concat [ firstValuesAndIndices + secondValuesAndIndices ] + + // stable sort + let expectedValues, expectedIndices = + Seq.sortBy snd allValuesAndIndices + |> Seq.toArray + |> Array.unzip + + "Values should be the same" + |> Utils.compareArrays isEqual actualValues expectedValues + + "Indices should be the same" + |> Utils.compareArrays (=) actualIndices expectedIndices + +let createTest<'a when 'a: struct> isEqual (zero: 'a) = + Vector.Sparse.Merge.run context Utils.defaultWorkGroupSize + |> makeTest isEqual zero + |> testPropertyWithConfig config $"test on %A{typeof<'a>}" + +let tests = + [ createTest (=) 0 + + if Utils.isFloat64Available context.ClDevice then + createTest (=) 0.0 + + createTest Utils.float32IsEqual 0.0f + createTest (=) false ] + |> testList "Merge" diff --git a/tests/GraphBLAS-sharp.Tests/Vector/OfList.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/OfList.fs similarity index 100% rename from tests/GraphBLAS-sharp.Tests/Vector/OfList.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Vector/OfList.fs diff --git a/tests/GraphBLAS-sharp.Tests/Vector/Reduce.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/Reduce.fs similarity index 79% rename from tests/GraphBLAS-sharp.Tests/Vector/Reduce.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Vector/Reduce.fs index cfbca46b..42f29688 100644 --- a/tests/GraphBLAS-sharp.Tests/Vector/Reduce.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Vector/Reduce.fs @@ -7,7 +7,7 @@ open GraphBLAS.FSharp.Tests open Brahma.FSharp open FSharp.Quotations open TestCases -open GraphBLAS.FSharp.Backend.Objects +open GraphBLAS.FSharp.Backend.Objects.ClCell open GraphBLAS.FSharp.Backend.Vector let logger = Log.create "Vector.reduce.Tests" @@ -22,15 +22,7 @@ let checkResult zero op (actual: 'a) (vector: 'a []) = "Results should be the same" |> Expect.equal actual expected -let correctnessGenericTest - isEqual - zero - op - opQ - (reduce: Expr<'a -> 'a -> 'a> -> MailboxProcessor<_> -> ClVector<'a> -> ClCell<'a>) - case - (array: 'a []) - = +let correctnessGenericTest isEqual zero op reduce case (array: 'a []) = let vector = Utils.createVectorFromArray case.Format array (isEqual zero) @@ -41,27 +33,18 @@ let correctnessGenericTest let clVector = vector.ToDevice context - let resultCell = reduce opQ q clVector - - let result = Array.zeroCreate 1 - let result = - let res = - q.PostAndReply(fun ch -> Msg.CreateToHostMsg<_>(resultCell, result, ch)) - - q.Post(Msg.CreateFreeMsg<_>(resultCell)) - - res.[0] + (reduce q clVector: ClCell<_>).ToHostAndFree q checkResult zero op result array let createTest<'a when 'a: equality and 'a: struct> case isEqual (zero: 'a) plus plusQ name = let context = case.TestContext.ClContext - let reduce = Vector.reduce context wgSize + let reduce = Vector.reduce plusQ context wgSize case - |> correctnessGenericTest isEqual zero plus plusQ reduce + |> correctnessGenericTest isEqual zero plus reduce |> testPropertyWithConfig config $"Correctness on %A{typeof<'a>}, %s{name} %A{case.Format}" diff --git a/tests/GraphBLAS-sharp.Tests/Vector/SpMV.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/SpMV.fs similarity index 88% rename from tests/GraphBLAS-sharp.Tests/Vector/SpMV.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Vector/SpMV.fs index 90d90ef4..e19ade53 100644 --- a/tests/GraphBLAS-sharp.Tests/Vector/SpMV.fs +++ b/tests/GraphBLAS-sharp.Tests/Backend/Vector/SpMV.fs @@ -76,9 +76,8 @@ let correctnessGenericTest let res = spMV testContext.Queue HostInterop m v (ClMatrix.CSR m).Dispose q - v.Dispose q - let hostRes = res.ToHost q - res.Dispose q + v.Free q + let hostRes = res.ToHostAndFree q checkResult isEqual sumOp mulOp zero matrix vector hostRes | _ -> failwith "Impossible" @@ -93,7 +92,7 @@ let createTest testContext (zero: 'a) isEqual add mul addQ mulQ = let getCorrectnessTestName datatype = $"Correctness on %s{datatype}, %A{testContext.ClContext}" - let spMV = SpMV.run context addQ mulQ wgSize + let spMV = SpMV.run addQ mulQ context wgSize testContext |> correctnessGenericTest zero add mul spMV isEqual q @@ -105,8 +104,8 @@ let testFixturesSpMV (testContext: TestContext) = let q = testContext.Queue q.Error.Add(fun e -> failwithf "%A" e) - createTest testContext false (=) (||) (&&) ArithmeticOperations.boolSum ArithmeticOperations.boolMul - createTest testContext 0 (=) (+) (*) ArithmeticOperations.intSum ArithmeticOperations.intMul + createTest testContext false (=) (||) (&&) ArithmeticOperations.boolSumOption ArithmeticOperations.boolMulOption + createTest testContext 0 (=) (+) (*) ArithmeticOperations.intSumOption ArithmeticOperations.intMulOption if Utils.isFloat64Available context.ClDevice then createTest @@ -115,8 +114,8 @@ let testFixturesSpMV (testContext: TestContext) = Utils.floatIsEqual (+) (*) - ArithmeticOperations.floatSum - ArithmeticOperations.floatMul + ArithmeticOperations.floatSumOption + ArithmeticOperations.floatMulOption createTest testContext @@ -124,10 +123,10 @@ let testFixturesSpMV (testContext: TestContext) = Utils.float32IsEqual (+) (*) - ArithmeticOperations.float32Sum - ArithmeticOperations.float32Mul + ArithmeticOperations.float32SumOption + ArithmeticOperations.float32MulOption - createTest testContext 0uy (=) (+) (*) ArithmeticOperations.byteSum ArithmeticOperations.byteMul ] + createTest testContext 0uy (=) (+) (*) ArithmeticOperations.byteSumOption ArithmeticOperations.byteMulOption ] let tests = gpuTests "Backend.Vector.SpMV tests" testFixturesSpMV diff --git a/tests/GraphBLAS-sharp.Tests/Vector/ZeroCreate.fs b/tests/GraphBLAS-sharp.Tests/Backend/Vector/ZeroCreate.fs similarity index 100% rename from tests/GraphBLAS-sharp.Tests/Vector/ZeroCreate.fs rename to tests/GraphBLAS-sharp.Tests/Backend/Vector/ZeroCreate.fs diff --git a/tests/GraphBLAS-sharp.Tests/Common/BitonicSort.fs b/tests/GraphBLAS-sharp.Tests/Common/BitonicSort.fs deleted file mode 100644 index 99f54495..00000000 --- a/tests/GraphBLAS-sharp.Tests/Common/BitonicSort.fs +++ /dev/null @@ -1,85 +0,0 @@ -module GraphBLAS.FSharp.Tests.Backend.Common.BitonicSort - -open Expecto -open Expecto.Logging -open Expecto.Logging.Message -open GraphBLAS.FSharp.Backend.Common -open Brahma.FSharp -open GraphBLAS.FSharp.Tests -open GraphBLAS.FSharp.Tests.Context - -let logger = Log.create "BitonicSort.Tests" - -let context = defaultContext.ClContext - -let config = - { Utils.defaultConfig with - endSize = 1000000 } - -let wgSize = Utils.defaultWorkGroupSize - -let q = defaultContext.Queue - -let makeTest sort (array: ('n * 'n * 'a) []) = - if array.Length > 0 then - let projection (row: 'n) (col: 'n) (_: 'a) = row, col - - logger.debug ( - eventX "Initial size is {size}" - >> setField "size" $"%A{array.Length}" - ) - - let rows, cols, vals = Array.unzip3 array - - use clRows = context.CreateClArray rows - use clColumns = context.CreateClArray cols - use clValues = context.CreateClArray vals - - let actualRows, actualCols, actualValues = - sort q clRows clColumns clValues - - let rows = Array.zeroCreate<'n> clRows.Length - let columns = Array.zeroCreate<'n> clColumns.Length - let values = Array.zeroCreate<'a> clValues.Length - - q.Post(Msg.CreateToHostMsg(clRows, rows)) - q.Post(Msg.CreateToHostMsg(clColumns, columns)) - - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(clValues, values, ch)) - |> ignore - - rows, columns, values - - let expectedRows, expectedCols, expectedValues = - (rows, cols, vals) - |||> Array.zip3 - |> Array.sortBy ((<|||) projection) - |> Array.unzip3 - - $"Row arrays should be equal. Actual is \n%A{actualRows}, expected \n%A{expectedRows}, input is \n%A{rows}" - |> Utils.compareArrays (=) actualRows expectedRows - - $"Column arrays should be equal. Actual is \n%A{actualCols}, expected \n%A{expectedCols}, input is \n%A{cols}" - |> Utils.compareArrays (=) actualCols expectedCols - - $"Value arrays should be equal. Actual is \n%A{actualValues}, expected \n%A{expectedValues}, input is \n%A{vals}" - |> Utils.compareArrays (=) actualValues expectedValues - -let testFixtures<'a when 'a: equality> = - BitonicSort.sortKeyValuesInplace context wgSize - |> makeTest - |> testPropertyWithConfig config $"Correctness on %A{typeof<'a>}" - -let tests = - q.Error.Add(fun e -> failwithf "%A" e) - - [ testFixtures - - if Utils.isFloat64Available context.ClDevice then - testFixtures - - testFixtures - - testFixtures - testFixtures ] - |> testList "Backend.Common.BitonicSort tests" diff --git a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Choose.fs b/tests/GraphBLAS-sharp.Tests/Common/ClArray/Choose.fs deleted file mode 100644 index 628ff51a..00000000 --- a/tests/GraphBLAS-sharp.Tests/Common/ClArray/Choose.fs +++ /dev/null @@ -1,57 +0,0 @@ -module GraphBLAS.FSharp.Tests.Backend.Common.ClArray.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 testContext id Map.id (=) - createTest testContext id Map.id (=) - createTest testContext id Map.id (=) - - if Utils.isFloat64Available device then - createTest testContext id Map.id Utils.floatIsEqual - - createTest testContext id Map.id Utils.float32IsEqual ] - -let tests = - TestCases.gpuTests "ClArray.choose id tests" testFixtures diff --git a/tests/GraphBLAS-sharp.Tests/Common/Scatter.fs b/tests/GraphBLAS-sharp.Tests/Common/Scatter.fs deleted file mode 100644 index 5730ca2e..00000000 --- a/tests/GraphBLAS-sharp.Tests/Common/Scatter.fs +++ /dev/null @@ -1,63 +0,0 @@ -module GraphBLAS.FSharp.Tests.Backend.Common.Scatter - -open Expecto -open Expecto.Logging -open Brahma.FSharp -open GraphBLAS.FSharp.Tests.Context -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Backend.Common - -let logger = Log.create "Scatter.Tests" - -let context = defaultContext.ClContext - -let config = - { Tests.Utils.defaultConfig with - endSize = 1000000 } - -let wgSize = Tests.Utils.defaultWorkGroupSize - -let q = defaultContext.Queue - -let makeTest scatter (array: (int * 'a) []) (result: 'a []) = - if array.Length > 0 then - let expected = Array.copy result - - array - |> Array.pairwise - |> Array.iter - (fun ((i, u), (j, _)) -> - if i <> j && 0 <= i && i < expected.Length then - expected.[i] <- u) - - let i, u = array.[array.Length - 1] - - if 0 <= i && i < expected.Length then - expected.[i] <- u - - let positions, values = Array.unzip array - - let actual = - use clPositions = context.CreateClArray positions - use clValues = context.CreateClArray values - use clResult = context.CreateClArray result - - scatter q clPositions clValues clResult - - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(clResult, Array.zeroCreate result.Length, ch)) - - $"Arrays should be equal. Actual is \n%A{actual}, expected \n%A{expected}" - |> Tests.Utils.compareArrays (=) actual expected - -let testFixtures<'a when 'a: equality> = - Scatter.runInplace<'a> context wgSize - |> makeTest - |> testPropertyWithConfig config $"Correctness on %A{typeof<'a>}" - -let tests = - q.Error.Add(fun e -> failwithf $"%A{e}") - - [ testFixtures - testFixtures - testFixtures ] - |> testList "Backend.Common.Scatter tests" diff --git a/tests/GraphBLAS-sharp.Tests/Generators.fs b/tests/GraphBLAS-sharp.Tests/Generators.fs index 2183d0b9..38d3e388 100644 --- a/tests/GraphBLAS-sharp.Tests/Generators.fs +++ b/tests/GraphBLAS-sharp.Tests/Generators.fs @@ -6,31 +6,6 @@ open Expecto.Logging open Expecto.Logging.Message open FSharp.Quotations.Evaluator -[] -module Extensions = - type ClosedBinaryOp<'a> with - member this.Invoke = - let (ClosedBinaryOp f) = this - QuotationEvaluator.Evaluate f - -module CustomDatatypes = - // мб заменить рекорд на структуру (не помогает) - [] - type WrappedInt = - { InnerValue: int } - static member (+)(x: WrappedInt, y: WrappedInt) = - { InnerValue = x.InnerValue + y.InnerValue } - - static member (*)(x: WrappedInt, y: WrappedInt) = - { InnerValue = x.InnerValue * y.InnerValue } - - let addMultSemiringOnWrappedInt: Semiring = - { PlusMonoid = - { AssociativeOp = ClosedBinaryOp <@ (+) @> - Identity = { InnerValue = 0 } } - - TimesSemigroup = { AssociativeOp = ClosedBinaryOp <@ (*) @> } } - module Generators = let logger = Log.create "Generators" @@ -38,26 +13,32 @@ module Generators = /// Generates empty matrices as well. /// let dimension2DGenerator = - Gen.sized - <| fun size -> Gen.choose (1, size) |> Gen.two + fun size -> Gen.choose (1, size) + |> Gen.sized + |> Gen.two let dimension3DGenerator = - Gen.sized - <| fun size -> Gen.choose (1, size) |> Gen.three + fun size -> Gen.choose (1, size) + |> Gen.sized + |> Gen.three let rec normalFloat32Generator (random: System.Random) = gen { - let result = random.NextSingle() + let rawValue = random.NextSingle() + + if System.Single.IsNormal rawValue then + let sign = float32 <| sign rawValue + let processedValue = ((+) 1.0f) <| (abs <| rawValue) - if System.Single.IsNormal result then - return result + return processedValue * sign else - return! normalFloat32Generator random + return 0.0f } let genericSparseGenerator zero valuesGen handler = - let maxSparsity = 100 - let sparsityGen = Gen.choose (0, maxSparsity) + let maxSparsity = 10 + let upperBound = 100 + let sparsityGen = Gen.choose (1, maxSparsity) let genWithSparsity sparseValuesGenProvider = gen { @@ -74,8 +55,8 @@ module Generators = genWithSparsity <| fun sparsity -> - [ (maxSparsity - sparsity, valuesGen) - (sparsity, Gen.constant zero) ] + [ (sparsity, valuesGen) + (upperBound - sparsity, Gen.constant zero) ] |> Gen.frequency |> handler @@ -248,6 +229,66 @@ module Generators = |> genericSparseGenerator false Arb.generate |> Arb.fromGen + type PairOfSparseMatricesWithCompatibleSizes() = + static let pairOfMatricesOfEqualSizeGenerator (valuesGenerator: Gen<'a>) = + gen { + let! firstCount, secondCount, thirdCount = dimension3DGenerator + + let! matrixA = + valuesGenerator + |> Gen.array2DOfDim (firstCount, secondCount) + + let! matrixB = + valuesGenerator + |> Gen.array2DOfDim (secondCount, thirdCount) + + return (matrixA, matrixB) + } + + static member IntType() = + pairOfMatricesOfEqualSizeGenerator + |> genericSparseGenerator 0 Arb.generate + |> Arb.fromGen + + static member FloatType() = + pairOfMatricesOfEqualSizeGenerator + |> genericSparseGenerator + 0. + (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + pairOfMatricesOfEqualSizeGenerator + |> genericSparseGenerator 0.0f (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + pairOfMatricesOfEqualSizeGenerator + |> genericSparseGenerator 0y Arb.generate + |> Arb.fromGen + + static member ByteType() = + pairOfMatricesOfEqualSizeGenerator + |> genericSparseGenerator 0uy Arb.generate + |> Arb.fromGen + + static member Int16Type() = + pairOfMatricesOfEqualSizeGenerator + |> genericSparseGenerator 0s Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + pairOfMatricesOfEqualSizeGenerator + |> genericSparseGenerator 0us Arb.generate + |> Arb.fromGen + + static member BoolType() = + pairOfMatricesOfEqualSizeGenerator + |> genericSparseGenerator false Arb.generate + |> Arb.fromGen + type PairOfSparseMatrixAndVectorsCompatibleSize() = static let pairOfMatrixAndVectorOfCompatibleSizeGenerator (valuesGenerator: Gen<'a>) = gen { @@ -306,14 +347,65 @@ module Generators = |> genericSparseGenerator false Arb.generate |> Arb.fromGen - static member WrappedInt() = - pairOfMatrixAndVectorOfCompatibleSizeGenerator + type PairOfSparseVectorAndMatrixAndMaskOfCompatibleSize() = + static let pairOfVectorAndMatrixOfCompatibleSizeGenerator (valuesGenerator: Gen<'a>) = + gen { + let! nRows, nColumns = dimension2DGenerator + let! vector = valuesGenerator |> Gen.arrayOfLength nRows + + let! matrix = + valuesGenerator + |> Gen.array2DOfDim (nRows, nColumns) + + let! mask = Arb.generate |> Gen.arrayOfLength nColumns + return (vector, matrix, mask) + } + + static member IntType() = + pairOfVectorAndMatrixOfCompatibleSizeGenerator + |> genericSparseGenerator 0 Arb.generate + |> Arb.fromGen + + static member FloatType() = + pairOfVectorAndMatrixOfCompatibleSizeGenerator |> genericSparseGenerator - CustomDatatypes.addMultSemiringOnWrappedInt.PlusMonoid.Identity - Arb.generate + 0. + (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + pairOfVectorAndMatrixOfCompatibleSizeGenerator + |> genericSparseGenerator 0.0f (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + pairOfVectorAndMatrixOfCompatibleSizeGenerator + |> genericSparseGenerator 0y Arb.generate + |> Arb.fromGen + + static member ByteType() = + pairOfVectorAndMatrixOfCompatibleSizeGenerator + |> genericSparseGenerator 0uy Arb.generate |> Arb.fromGen - type PairOfSparseVectorAndMatrixOfCompatibleSize() = + static member Int16Type() = + pairOfVectorAndMatrixOfCompatibleSizeGenerator + |> genericSparseGenerator 0s Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + pairOfVectorAndMatrixOfCompatibleSizeGenerator + |> genericSparseGenerator 0us Arb.generate + |> Arb.fromGen + + static member BoolType() = + pairOfVectorAndMatrixOfCompatibleSizeGenerator + |> genericSparseGenerator false Arb.generate + |> Arb.fromGen + + type VectorXMatrix() = static let pairOfVectorAndMatrixOfCompatibleSizeGenerator (valuesGenerator: Gen<'a>) = gen { let! nRows, nColumns = dimension2DGenerator @@ -323,8 +415,7 @@ module Generators = valuesGenerator |> Gen.array2DOfDim (nRows, nColumns) - let! mask = Arb.generate |> Gen.arrayOfLength nColumns - return (vector, matrix, mask) + return (vector, matrix) } static member IntType() = @@ -506,6 +597,81 @@ module Generators = |> Arb.fromGen type ArrayOfDistinctKeys() = + static let arrayOfDistinctKeysGenerator (keysGenerator: Gen<'n>) (valuesGenerator: Gen<'a>) = + let tuplesGenerator = + Gen.zip <| keysGenerator <| valuesGenerator + + gen { + let! length = Gen.sized <| fun size -> Gen.choose (1, size) + + let! array = Gen.arrayOfLength <| length <| tuplesGenerator + + return Array.distinctBy fst array + } + + static member IntType() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + arrayOfDistinctKeysGenerator + <| Arb.generate + <| Arb.generate + |> Arb.fromGen + + type ArrayOfDistinctKeys2D() = static let arrayOfDistinctKeysGenerator (keysGenerator: Gen<'n>) (valuesGenerator: Gen<'a>) = let tuplesGenerator = Gen.zip3 @@ -817,3 +983,472 @@ module Generators = static member BoolType() = pairOfVectorsOfEqualSize <| Arb.generate |> Arb.fromGen + + type Sub() = + static let arrayAndChunkPosition (valuesGenerator: Gen<'a>) = + gen { + let! length = Gen.sized <| fun size -> Gen.choose (2, size + 2) + + let! array = Gen.arrayOfLength length valuesGenerator + + let! startPosition = Gen.choose (0, length - 2) + let! count = Gen.choose (1, length - startPosition - 1) + + return (array, startPosition, count) + } + + static member IntType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + arrayAndChunkPosition + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + arrayAndChunkPosition + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + type ChunkBySize() = + static let arrayAndChunkPosition (valuesGenerator: Gen<'a>) = + gen { + let! length = Gen.sized <| fun size -> Gen.choose (2, size + 2) + + let! array = Gen.arrayOfLength length valuesGenerator + + let! chunkSize = Gen.choose (1, length) + + return (array, chunkSize) + } + + static member IntType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + arrayAndChunkPosition + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + arrayAndChunkPosition + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + type Blit() = + static let pairOfVectorsOfEqualSize (valuesGenerator: Gen<'a>) = + gen { + let! targetArrayLength = Gen.sized <| fun size -> Gen.choose (0, size) + + let! targetArray = Gen.arrayOfLength targetArrayLength valuesGenerator + + let! sourceArrayLength = Gen.sized <| fun size -> Gen.choose (0, size) + + let! sourceArray = Gen.arrayOfLength sourceArrayLength valuesGenerator + + let! targetIndex = Gen.choose (0, targetArrayLength) + + let! sourceIndex = Gen.choose (0, sourceArrayLength) + + let! count = Gen.choose (0, (min (targetArrayLength - targetIndex) (sourceArrayLength - sourceIndex))) + + return (sourceArray, sourceIndex, targetArray, targetIndex, count) + } + + static member IntType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + pairOfVectorsOfEqualSize + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + pairOfVectorsOfEqualSize + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + type Fill() = + static let pairOfVectorsOfEqualSize (valuesGenerator: Gen<'a>) = + gen { + let! value = valuesGenerator + + let! targetArrayLength = Gen.sized <| fun size -> Gen.choose (1, size + 1) + + let! targetArray = Gen.arrayOfLength targetArrayLength valuesGenerator + + let! targetPosition = Gen.choose (0, targetArrayLength) + + let! targetCount = Gen.choose (0, targetArrayLength - targetPosition) + + return (value, targetPosition, targetCount, targetArray) + } + + static member IntType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + pairOfVectorsOfEqualSize + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + pairOfVectorsOfEqualSize + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + type UpperBound() = + static let arrayAndChunkPosition (valuesGenerator: Gen<'a>) = + gen { + let! size = Gen.sized <| fun size -> Gen.choose (1, size + 1) + + let! array = Gen.arrayOfLength size valuesGenerator + + let! valueIndex = Gen.choose (0, array.Length - 1) + + let value = array.[valueIndex] + + return (array, value) + } + + static member IntType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + arrayAndChunkPosition + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + arrayAndChunkPosition + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + module ClArray = + type Set() = + static let arrayAndChunkPosition (valuesGenerator: Gen<'a>) = + gen { + let! size = Gen.sized <| fun size -> Gen.choose (1, size + 1) + + let! array = Gen.arrayOfLength size valuesGenerator + + let! position = Gen.choose (0, array.Length - 1) + + let! value = valuesGenerator + + return (array, position, value) + } + + static member IntType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + arrayAndChunkPosition + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + arrayAndChunkPosition + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + type Item() = + static let arrayAndChunkPosition (valuesGenerator: Gen<'a>) = + gen { + let! size = Gen.sized <| fun size -> Gen.choose (1, size + 1) + + let! array = Gen.arrayOfLength size valuesGenerator + + let! position = Gen.choose (0, array.Length - 1) + + return (array, position) + } + + static member IntType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + arrayAndChunkPosition + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + arrayAndChunkPosition + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + module Matrix = + type Sub() = + static let arrayAndChunkPosition (valuesGenerator: Gen<'a>) = + gen { + let! rowsCount = Gen.sized <| fun size -> Gen.choose (2, size + 2) + let! columnsCount = Gen.sized <| fun size -> Gen.choose (1, size + 1) + + let! array = Gen.array2DOfDim (rowsCount, columnsCount) valuesGenerator + + let! startPosition = Gen.choose (0, rowsCount - 2) + let! count = Gen.choose (1, rowsCount - startPosition - 1) + + return (array, startPosition, count) + } + + static member IntType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + arrayAndChunkPosition + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> Arb.fromGen + + static member Float32Type() = + arrayAndChunkPosition + <| (normalFloat32Generator <| System.Random()) + |> Arb.fromGen + + static member SByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member ByteType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt16Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member Int32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member UInt32Type() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen + + static member BoolType() = + arrayAndChunkPosition <| Arb.generate + |> Arb.fromGen diff --git a/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj b/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj index 14bbf3ff..75a4f492 100644 --- a/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj +++ b/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj @@ -13,38 +13,60 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/GraphBLAS-sharp.Tests/Helpers.fs b/tests/GraphBLAS-sharp.Tests/Helpers.fs index bfbe4450..1811c40b 100644 --- a/tests/GraphBLAS-sharp.Tests/Helpers.fs +++ b/tests/GraphBLAS-sharp.Tests/Helpers.fs @@ -25,8 +25,8 @@ module Utils = typeof typeof typeof - typeof - typeof + typeof + typeof typeof typeof typeof @@ -63,6 +63,9 @@ module Utils = | CSC -> Matrix.CSC <| Matrix.CSC.FromArray2D(array, isZero) + | LIL -> + Matrix.LIL + <| Matrix.LIL.FromArray2D(array, isZero) let createVectorFromArray vectorCase array isZero = match vectorCase with @@ -96,9 +99,85 @@ module Utils = for i in 0 .. actual.Length - 1 do if not (areEqual actual.[i] expected.[i]) then $"%s{message}. Arrays differ at position %A{i} of %A{actual.Length - 1}. - Actual value is %A{actual.[i]}, expected %A{expected.[i]}" + Actual value is %A{actual.[i]}, expected %A{expected.[i]}, \n actual: %A{actual} \n expected: %A{expected}" |> failtestf "%s" + let compareChunksArrays areEqual (actual: 'a [] []) (expected: 'a [] []) message = + $"%s{message}. Lengths should be equal. Actual is %A{actual}, expected %A{expected}" + |> Expect.equal actual.Length expected.Length + + for i in 0 .. actual.Length - 1 do + compareArrays areEqual actual.[i] expected.[i] message + + let compare2DArrays areEqual (actual: 'a [,]) (expected: 'a [,]) message = + $"%s{message}. Lengths should be equal. Actual is %A{actual}, expected %A{expected}" + |> Expect.equal actual.Length expected.Length + + for i in 0 .. Array2D.length1 actual - 1 do + for j in 0 .. Array2D.length2 actual - 1 do + if not (areEqual actual.[i, j] expected.[i, j]) then + $"%s{message}. Arrays differ at position [%d{i}, %d{j}] of [%A{Array2D.length1 actual}, %A{Array2D.length2 actual}]. + Actual value is %A{actual.[i, j]}, expected %A{expected.[i, j]}" + |> failtestf "%s" + + let compareSparseVectors isEqual (actual: Vector.Sparse<'a>) (expected: Vector.Sparse<'a>) = + "Sparse vector size must be the same" + |> Expect.equal actual.Size expected.Size + + "Value must be the same" + |> compareArrays isEqual actual.Values expected.Values + + "Indices must be the same" + |> compareArrays (=) actual.Indices expected.Indices + + let compareLILMatrix isEqual (actual: Matrix.LIL<'a>) (expected: Matrix.LIL<'a>) = + "Column count must be the same" + |> Expect.equal actual.ColumnCount expected.ColumnCount + + "Rows count must be the same" + |> Expect.equal actual.RowCount expected.RowCount + + List.iter2 + (fun actualRow expected -> + match actualRow, expected with + | Some actualVector, Some expectedVector -> compareSparseVectors isEqual actualVector expectedVector + | None, None -> () + | _ -> failwith "Rows are not matching") + <| actual.Rows + <| expected.Rows + + let compareCSRMatrix isEqual (actual: Matrix.CSR<'a>) (expected: Matrix.CSR<'a>) = + "Column count must be the same" + |> Expect.equal actual.ColumnCount expected.ColumnCount + + "Rows count must be the same" + |> Expect.equal actual.RowCount expected.RowCount + + "Values must be the same" + |> compareArrays isEqual actual.Values expected.Values + + "Column indices must be the same" + |> compareArrays (=) actual.ColumnIndices expected.ColumnIndices + + "Row pointers" + |> compareArrays (=) actual.RowPointers expected.RowPointers + + let compareCOOMatrix isEqual (actual: Matrix.COO<'a>) (expected: Matrix.COO<'a>) = + "Column count must be the same" + |> Expect.equal actual.ColumnCount expected.ColumnCount + + "Rows count must be the same" + |> Expect.equal actual.RowCount expected.RowCount + + "Values must be the same" + |> compareArrays isEqual actual.Values expected.Values + + "Column indices must be the same" + |> compareArrays (=) actual.Columns expected.Columns + + "Row pointers" + |> compareArrays (=) actual.Rows expected.Rows + let listOfUnionCases<'a> = FSharpType.GetUnionCases typeof<'a> |> Array.map (fun caseInfo -> FSharpValue.MakeUnion(caseInfo, [||]) :?> 'a) @@ -129,6 +208,137 @@ module Utils = result +module HostPrimitives = + let prefixSumInclude zero add array = + Array.scan add zero array + |> fun scanned -> scanned.[1..], Array.last scanned + + let prefixSumExclude zero add sourceArray = + prefixSumInclude zero add sourceArray + |> (fst >> Array.insertAt 0 zero) + |> fun array -> Array.take sourceArray.Length array, Array.last array + + let getUniqueBitmapLastOccurrence array = + Array.pairwise array + |> fun pairs -> + Array.init + array.Length + (fun index -> + if index = array.Length - 1 + || fst pairs.[index] <> snd pairs.[index] then + 1 + else + 0) + + let getUniqueBitmapFirstOccurrence (sourceArray: _ []) = + let resultArray = Array.zeroCreate sourceArray.Length + + for i in 0 .. sourceArray.Length - 1 do + if i = 0 || sourceArray.[i] <> sourceArray.[i - 1] then + resultArray.[i] <- 1 + + resultArray + + let getBitPositions bitmap = + bitmap + |> Array.mapi (fun index bit -> if bit = 1 then Some index else None) + |> Array.choose id + + let reduceByKey keys value reduceOp = + Array.zip keys value + |> Array.groupBy fst + |> Array.map + (fun (key, array) -> + Array.map snd array + |> Array.reduce reduceOp + |> fun value -> key, value) + |> Array.unzip + + let reduceByKey2D firstKeys secondKeys values reduceOp = + Array.zip firstKeys secondKeys + |> fun compactedKeys -> reduceByKey compactedKeys values reduceOp + ||> Array.map2 (fun (fst, snd) value -> fst, snd, value) + |> Array.unzip3 + + let generalScatter getBitmap (positions: int array) (values: 'a array) (resultValues: 'a array) = + + if positions.Length <> values.Length then + failwith "Lengths must be the same" + + let bitmap = getBitmap positions + + Array.iteri2 + (fun index bit key -> + if bit = 1 && 0 <= key && key < resultValues.Length then + resultValues.[key] <- values.[index]) + bitmap + positions + + resultValues + + let scatterLastOccurrence positions = + generalScatter getUniqueBitmapLastOccurrence positions + + let scatterFirstOccurrence positions = + generalScatter getUniqueBitmapFirstOccurrence positions + + let gather (positions: int []) (values: 'a []) (result: 'a []) = + if positions.Length <> result.Length then + failwith "Lengths must be the same" + + Array.iteri + (fun index position -> + if position >= 0 && position < values.Length then + result.[index] <- values.[position]) + positions + + result + + let array2DMultiplication zero mul add leftArray rightArray = + if Array2D.length2 leftArray + <> Array2D.length1 rightArray then + failwith "Incompatible matrices" + + let add left right = + match left, right with + | Some left, Some right -> add left right + | Some value, None + | None, Some value -> Some value + | _ -> None + + Array2D.init + <| Array2D.length1 leftArray + <| Array2D.length2 rightArray + <| fun i j -> + (leftArray.[i, *], rightArray.[*, j]) + // multiply and filter + ||> Array.map2 mul + |> Array.choose id + // add and filter + |> Array.map Some + |> Array.fold add None + |> Option.defaultValue zero + + let scanByKey scan keysAndValues = + Array.groupBy fst keysAndValues + |> Array.map (fun (_, array) -> Array.map snd array |> scan |> fst) + |> Array.concat + + let array2DKroneckerProduct leftMatrix rightMatrix op = + Array2D.init + <| (Array2D.length1 leftMatrix) + * (Array2D.length1 rightMatrix) + <| (Array2D.length2 leftMatrix) + * (Array2D.length2 rightMatrix) + <| fun i j -> + let leftElement = + leftMatrix.[i / (Array2D.length1 rightMatrix), j / (Array2D.length2 rightMatrix)] + + let rightElement = + rightMatrix.[i % (Array2D.length1 rightMatrix), j % (Array2D.length2 rightMatrix)] + + op leftElement rightElement + module Context = type TestContext = { ClContext: ClContext diff --git a/tests/GraphBLAS-sharp.Tests/Host/IO/Dataset/testMatrix.mtx b/tests/GraphBLAS-sharp.Tests/Host/IO/Dataset/testMatrix.mtx new file mode 100644 index 00000000..2af703b9 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Host/IO/Dataset/testMatrix.mtx @@ -0,0 +1,5 @@ +%%MatrixMarket matrix coordinate integer general +2 3 3 +1 2 3 +2 2 2 +2 3 1 diff --git a/tests/GraphBLAS-sharp.Tests/Host/IO/MtxReader.fs b/tests/GraphBLAS-sharp.Tests/Host/IO/MtxReader.fs new file mode 100644 index 00000000..54b91ed6 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Host/IO/MtxReader.fs @@ -0,0 +1,45 @@ +module GraphBLAS.FSharp.Tests.Host.IO.MtxReader + +open System.IO +open Expecto +open GraphBLAS.FSharp.IO + +let matrixName = "testMatrix.mtx" + +let path = + Path.Combine [| __SOURCE_DIRECTORY__ + "Dataset" + matrixName |] + +let test = + test "mtxReader test" { + let matrixReader = MtxReader(path) + + let shape = matrixReader.ReadMatrixShape() + + "Rows count must be the same" + |> Expect.equal shape.RowCount 2 + + "Columns count must be the same" + |> Expect.equal shape.ColumnCount 3 + + "NNZ count must be the same" + |> Expect.equal shape.NNZ 3 + + let matrix = matrixReader.ReadMatrix(int) + + "Matrix row count must be the same" + |> Expect.equal matrix.RowCount 2 + + "Matrix column count must be the same" + |> Expect.equal matrix.ColumnCount 3 + + "Matrix values must be the same" + |> Expect.sequenceEqual matrix.Values [| 3; 2; 1 |] + + "Matrix columns must be the same" + |> Expect.sequenceEqual matrix.Columns [| 1; 1; 2 |] + + "Matrix rows must be the same" + |> Expect.sequenceEqual matrix.Rows [| 0; 1; 1 |] + } diff --git a/tests/GraphBLAS-sharp.Tests/Host/Matrix/Convert.fs b/tests/GraphBLAS-sharp.Tests/Host/Matrix/Convert.fs new file mode 100644 index 00000000..358286a2 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Host/Matrix/Convert.fs @@ -0,0 +1,25 @@ +module GraphBLAS.FSharp.Tests.Host.Matrix.Convert + +open Expecto +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Tests + +let makeTest isEqual zero (array: 'a [,]) = + let cooMatrix = + Matrix.COO.FromArray2D(array, isEqual zero) + + let actual = cooMatrix.ToCSR + + let expected = + Matrix.CSR.FromArray2D(array, isEqual zero) + + Utils.compareCSRMatrix isEqual actual expected + +let createTest<'a when 'a: struct> isEqual (zero: 'a) = + makeTest isEqual zero + |> testPropertyWithConfig Utils.defaultConfig $"%A{typeof<'a>}" + +let tests = + [ createTest (=) 0 + createTest (=) false ] + |> testList "Convert" diff --git a/tests/GraphBLAS-sharp.Tests/Host/Matrix/FromArray2D.fs b/tests/GraphBLAS-sharp.Tests/Host/Matrix/FromArray2D.fs new file mode 100644 index 00000000..ad800dd8 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Host/Matrix/FromArray2D.fs @@ -0,0 +1,164 @@ +module GraphBLAS.FSharp.Tests.Host.Matrix.FromArray2D + +open Expecto +open GraphBLAS.FSharp.Objects +open GraphBLAS.FSharp.Tests + +let config = Utils.defaultConfig + +let checkPointers isEqual zero array slice counter pointers (matrixValues: 'a []) (matrixIndices: int []) = + for i in 0 .. counter - 1 do + let expectedIndices, expectedValues = + slice array i + |> Array.mapi (fun index value -> (index, value)) + |> Array.filter (fun (_, value) -> ((<<) not <| isEqual zero) value) + |> Array.unzip + + let startRowPosition = Array.item i pointers + let endRowPosition = pointers.[i + 1] - 1 + + let actualValues = + matrixValues.[startRowPosition..endRowPosition] + + let actualIndices = + matrixIndices.[startRowPosition..endRowPosition] + + "Values must be the same" + |> Utils.compareArrays isEqual actualValues expectedValues + + "Indices must be the same" + |> Utils.compareArrays (=) actualIndices expectedIndices + +let makeTest isEqual zero createMatrix (array: 'a [,]) = + let matrix: Matrix<_> = createMatrix (isEqual zero) array + + let arrayRowCount = Array2D.length1 array + let arrayColumnCount = Array2D.length2 array + + "Row count must be the same" + |> Expect.equal matrix.RowCount arrayRowCount + + "Column count must be the same" + |> Expect.equal matrix.ColumnCount arrayColumnCount + + let nonZeroValues = + array + |> Seq.cast<'a> + |> Seq.filter ((<<) not <| isEqual zero) + |> Seq.toArray + + let checkPointers = checkPointers isEqual zero array + + match matrix with + | Matrix.CSR matrix -> + "Values must be the same" + |> Utils.compareArrays isEqual matrix.Values nonZeroValues + + "Row count invariant" + |> Expect.isTrue (matrix.RowPointers.Length = matrix.RowCount + 1) + + checkPointers + (fun (array: 'a [,]) i -> array.[i, *]) + arrayRowCount + matrix.RowPointers + matrix.Values + matrix.ColumnIndices + | Matrix.COO matrix -> + "Values must be the same" + |> Utils.compareArrays isEqual matrix.Values nonZeroValues + + let expectedColumns, expectedRows, expectedValues = + array + |> Array2D.mapi (fun rowIndex columnIndex value -> (columnIndex, rowIndex, value)) + |> Seq.cast + |> Seq.filter (fun (_, _, value) -> ((<<) not <| isEqual zero) value) + |> Seq.toArray + |> Array.unzip3 + + "Values must be the same" + |> Utils.compareArrays isEqual matrix.Values expectedValues + + "Column indices must be the same" + |> Utils.compareArrays (=) matrix.Columns expectedColumns + + "Rows indices must be the same" + |> Utils.compareArrays (=) matrix.Rows expectedRows + | Matrix.CSC matrix -> + let expectedValues = + seq { + for i in 0 .. arrayColumnCount - 1 do + yield! array.[*, i] + } + |> Seq.filter ((<<) not <| isEqual zero) + |> Seq.toArray + + "Values must be the same" + |> Utils.compareArrays isEqual matrix.Values expectedValues + + "Row count invariant" + |> Expect.isTrue (matrix.ColumnPointers.Length = matrix.ColumnCount + 1) + + checkPointers + (fun array i -> array.[*, i]) + arrayColumnCount + matrix.ColumnPointers + matrix.Values + matrix.RowIndices + | Matrix.LIL matrix -> + "Rows count must be the same" + |> Expect.equal matrix.Rows.Length (Array2D.length1 array) + + matrix.Rows + |> Seq.iteri + (fun index -> + function + | Some actualRow -> + let expectedIndices, expectedValues = + array.[index, *] + |> Array.mapi (fun index value -> (index, value)) + |> Array.filter (fun (_, value) -> ((<<) not <| isEqual zero) value) + |> Array.unzip + + "Values must be the same" + |> Utils.compareArrays isEqual actualRow.Values expectedValues + + "Indices must be the same" + |> Utils.compareArrays (=) actualRow.Indices expectedIndices + | None -> + "No non zero items in row" + |> Expect.isFalse (Array.exists ((<<) not <| isEqual zero) array.[index, *])) + +let createTest name isEqual zero convert = + makeTest isEqual zero convert + |> testPropertyWithConfig config name + +let tests = + [ createTest + "CSR" + (=) + 0 + (fun isZero array -> + Matrix.CSR + <| Matrix.CSR.FromArray2D(array, isZero)) + createTest + "COO" + (=) + 0 + (fun isZero array -> + Matrix.COO + <| Matrix.COO.FromArray2D(array, isZero)) + createTest + "CSC" + (=) + 0 + (fun isZero array -> + Matrix.CSC + <| Matrix.CSC.FromArray2D(array, isZero)) + createTest + "LIL" + (=) + 0 + (fun isZero array -> + Matrix.LIL + <| Matrix.LIL.FromArray2D(array, isZero)) ] + |> testList "FromArray2D" diff --git a/tests/GraphBLAS-sharp.Tests/Matrix/Convert.fs b/tests/GraphBLAS-sharp.Tests/Matrix/Convert.fs deleted file mode 100644 index 150ec153..00000000 --- a/tests/GraphBLAS-sharp.Tests/Matrix/Convert.fs +++ /dev/null @@ -1,109 +0,0 @@ -module GraphBLAS.FSharp.Tests.Backend.Matrix.Convert - -open Expecto -open Expecto.Logging -open Expecto.Logging.Message -open GraphBLAS.FSharp.Tests -open GraphBLAS.FSharp.Tests.Context -open GraphBLAS.FSharp.Backend -open GraphBLAS.FSharp.Objects -open GraphBLAS.FSharp.Backend.Matrix -open GraphBLAS.FSharp.Backend.Objects -open GraphBLAS.FSharp.Objects.MatrixExtensions -open GraphBLAS.FSharp.Backend.Objects.ClContext - -let logger = Log.create "Convert.Tests" - -let config = Utils.defaultConfig - -let workGroupSize = Utils.defaultWorkGroupSize - -let makeTest context q formatFrom formatTo convertFun isZero (array: 'a [,]) = - let mtx = - Utils.createMatrixFromArray2D formatFrom array isZero - - if mtx.NNZ > 0 then - let actual = - let mBefore = mtx.ToDevice context - let mAfter: ClMatrix<'a> = convertFun q HostInterop mBefore - let res = mAfter.ToHost q - mBefore.Dispose q - mAfter.Dispose q - res - - logger.debug ( - eventX "Actual is {actual}" - >> setField "actual" (sprintf "%A" actual) - ) - - let expected = - Utils.createMatrixFromArray2D formatTo array isZero - - "Matrices should be equal" - |> Expect.equal actual expected - -let testFixtures formatTo = - let getCorrectnessTestName datatype formatFrom = - $"Correctness on %s{datatype}, %A{formatFrom} to %A{formatTo}" - - let context = defaultContext.ClContext - let q = defaultContext.Queue - q.Error.Add(fun e -> failwithf "%A" e) - - match formatTo with - | COO -> - [ let convertFun = Matrix.toCOO context workGroupSize - - Utils.listOfUnionCases - |> List.map - (fun formatFrom -> - makeTest context q formatFrom formatTo convertFun ((=) 0) - |> testPropertyWithConfig config (getCorrectnessTestName "int" formatFrom)) - - let convertFun = Matrix.toCOO context workGroupSize - - Utils.listOfUnionCases - |> List.map - (fun formatFrom -> - makeTest context q formatFrom formatTo convertFun ((=) false) - |> testPropertyWithConfig config (getCorrectnessTestName "bool" formatFrom)) ] - |> List.concat - | CSR -> - [ let convertFun = Matrix.toCSR context workGroupSize - - Utils.listOfUnionCases - |> List.map - (fun formatFrom -> - makeTest context q formatFrom formatTo convertFun ((=) 0) - |> testPropertyWithConfig config (getCorrectnessTestName "int" formatFrom)) - - let convertFun = Matrix.toCSR context workGroupSize - - Utils.listOfUnionCases - |> List.map - (fun formatFrom -> - makeTest context q formatFrom formatTo convertFun ((=) false) - |> testPropertyWithConfig config (getCorrectnessTestName "bool" formatFrom)) ] - |> List.concat - | CSC -> - [ let convertFun = Matrix.toCSC context workGroupSize - - Utils.listOfUnionCases - |> List.map - (fun formatFrom -> - makeTest context q formatFrom formatTo convertFun ((=) 0) - |> testPropertyWithConfig config (getCorrectnessTestName "int" formatFrom)) - - let convertFun = Matrix.toCSC context workGroupSize - - Utils.listOfUnionCases - |> List.map - (fun formatFrom -> - makeTest context q formatFrom formatTo convertFun ((=) false) - |> testPropertyWithConfig config (getCorrectnessTestName "bool" formatFrom)) ] - |> List.concat - -let tests = - Utils.listOfUnionCases - |> List.collect testFixtures - |> testList "Convert tests" diff --git a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/EWiseAddTests.fs b/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/EWiseAddTests.fs deleted file mode 100644 index c8559618..00000000 --- a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/EWiseAddTests.fs +++ /dev/null @@ -1,171 +0,0 @@ -module Matrix.EWiseAdd - -open Expecto -open FsCheck -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Tests -open GraphBLAS.FSharp.Predefined -open TypeShape.Core -open Expecto.Logging -open Expecto.Logging.Message -open Brahma.FSharp.OpenCL -open OpenCL.Net - -let logger = Log.create "Matrix.EWiseAdd.Tests" - -type OperationCase = - { ClContext: ClContext - MatrixCase: MatrixFromat - MaskCase: MaskType } - -let testCases = - [ Utils.avaliableContexts "" |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box - Utils.listOfUnionCases |> Seq.map box ] - |> List.map List.ofSeq - |> Utils.cartesian - |> List.map - (fun list -> - { ClContext = unbox list.[0] - MatrixCase = unbox list.[1] - MaskCase = unbox list.[2] }) - -let correctnessGenericTest<'a when 'a: struct> - (monoid: IMonoid<'a>) - (isEqual: 'a -> 'a -> bool) - (case: OperationCase) - (leftMatrix: 'a [,], rightMatrix: 'a [,]) - = - - let isZero = isEqual monoid.Zero - - let expected = - let left = leftMatrix |> Seq.cast<'a> - let right = rightMatrix |> Seq.cast<'a> - - let plus = monoid.Plus.Invoke - - (left, right) - ||> Seq.mapi2 - (fun idx x y -> - let i = idx / Array2D.length2 leftMatrix - let j = idx % Array2D.length2 leftMatrix - - if isZero x && isZero y then - None - else - Some(i, j, plus x y)) - |> Seq.choose id - |> Array.ofSeq - |> Array.unzip3 - |> fun (rows, cols, vals) -> - { RowIndices = rows - ColumnIndices = cols - Values = vals } - - let actual = - try - let left = - Utils.createMatrixFromArray2D case.MatrixCase leftMatrix isZero - - let right = - Utils.createMatrixFromArray2D case.MatrixCase rightMatrix isZero - - logger.debug ( - eventX "Left matrix is \n{matrix}" - >> setField "matrix" left - ) - - logger.debug ( - eventX "Right matrix is \n{matrix}" - >> setField "matrix" right - ) - - graphblas { - let! result = Matrix.eWiseAdd monoid left right - let! tuples = Matrix.tuples result - do! MatrixTuples.synchronize tuples - return tuples - } - |> EvalGB.withClContext case.ClContext - |> EvalGB.runSync - - finally - // TODO fix me - () - //case.ClContext.Provider.CloseAllBuffers() - - logger.debug ( - eventX "Expected result is {expected}" - >> setField "expected" (sprintf "%A" expected.Values) - ) - - logger.debug ( - eventX "Actual result is {actual}" - >> setField "actual" (sprintf "%A" actual.Values) - ) - - let actualIndices = - Seq.zip actual.RowIndices actual.ColumnIndices - - let expectedIndices = - Seq.zip expected.RowIndices expected.ColumnIndices - - "Indices of expected and result matrix must be the same" - |> Expect.sequenceEqual actualIndices expectedIndices - - let equality = - (expected.Values, actual.Values) - ||> Seq.map2 isEqual - - "Length of expected and result values should be equal" - |> Expect.hasLength actual.Values (Seq.length expected.Values) - - "There should be no difference between expected and received values" - |> Expect.allEqual equality true - -// https://docs.microsoft.com/ru-ru/dotnet/csharp/language-reference/language-specification/types#value-types -let testFixtures case = - [ let config = Utils.defaultConfig - - let getCorrectnessTestName datatype = - sprintf "Correctness on %s, %A" datatype case - - case - |> correctnessGenericTest AddMult.int (=) - |> testPropertyWithConfig config (getCorrectnessTestName "int") - - case - |> correctnessGenericTest AddMult.float (fun x y -> abs (x - y) < Accuracy.medium.absolute) - |> testPropertyWithConfig config (getCorrectnessTestName "float") - - case - |> correctnessGenericTest AddMult.int16 (=) - |> testPropertyWithConfig config (getCorrectnessTestName "int16") - - case - |> correctnessGenericTest AddMult.uint16 (=) - |> testPropertyWithConfig config (getCorrectnessTestName "uint16") - - case - |> correctnessGenericTest AnyAll.bool (=) - |> ptestPropertyWithConfig config (getCorrectnessTestName "bool") ] - -let tests = - testCases - |> List.filter - (fun case -> - let mutable e = ErrorCode.Unknown - let device = case.ClContext.Device - - let deviceType = - Cl - .GetDeviceInfo(device, DeviceInfo.Type, &e) - .CastTo() - - deviceType = DeviceType.Cpu - && case.MatrixCase = COO - && case.MaskCase = NoMask) - |> List.collect testFixtures - |> testList "Matrix.eWiseAdd tests" diff --git a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/GetTuplesTests.fs b/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/GetTuplesTests.fs deleted file mode 100644 index 67d9feb3..00000000 --- a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/GetTuplesTests.fs +++ /dev/null @@ -1,148 +0,0 @@ -module Matrix.GetTuples - -open Expecto -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Tests -open TypeShape.Core -open Expecto.Logging -open Expecto.Logging.Message -open Brahma.FSharp.OpenCL -open OpenCL.Net - -let logger = Log.create "Matrix.GetTuples.Tests" - -type OperationCase = - { ClContext: ClContext - MatrixCase: MatrixFromat } - -let testCases = - [ Utils.avaliableContexts "" |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box ] - |> List.map List.ofSeq - |> Utils.cartesian - |> List.map - (fun list -> - { ClContext = unbox list.[0] - MatrixCase = unbox list.[1] }) - -let correctnessGenericTest<'a when 'a: struct> - (isEqual: 'a -> 'a -> bool) - (zero: 'a) - (case: OperationCase) - (matrix: 'a [,]) - = - - let isZero = isEqual zero - - let expected = - matrix - |> Seq.cast<'a> - |> Seq.mapi - (fun idx v -> - let i = idx / Array2D.length2 matrix - let j = idx % Array2D.length2 matrix - - (i, j, v)) - |> Seq.filter (fun (_, _, v) -> (not << isZero) v) - |> Array.ofSeq - |> Array.unzip3 - |> fun (rows, cols, vals) -> - { RowIndices = rows - ColumnIndices = cols - Values = vals } - - let actual = - try - let matrix = - Utils.createMatrixFromArray2D case.MatrixCase matrix isZero - - logger.debug ( - eventX "Matrix is \n{matrix}" - >> setField "matrix" matrix - ) - - graphblas { - let! tuples = Matrix.tuples matrix - do! MatrixTuples.synchronize tuples - return tuples - } - |> EvalGB.withClContext case.ClContext - |> EvalGB.runSync - - finally - // TODO fix me - () - //case.ClContext.Provider.CloseAllBuffers() - - logger.debug ( - eventX "Expected result is {expected}" - >> setField "expected" (sprintf "%A" expected.Values) - ) - - logger.debug ( - eventX "Actual result is {actual}" - >> setField "actual" (sprintf "%A" actual.Values) - ) - - let actualIndices = - Seq.zip actual.RowIndices actual.ColumnIndices - - let expectedIndices = - Seq.zip expected.RowIndices expected.ColumnIndices - - "Indices of expected and result matrix must be the same" - |> Expect.sequenceEqual actualIndices expectedIndices - - let equality = - (expected.Values, actual.Values) - ||> Seq.map2 isEqual - - "Length of expected and result values should be equal" - |> Expect.hasLength actual.Values (Seq.length expected.Values) - - "There should be no difference between expected and received values" - |> Expect.allEqual equality true - -let testFixtures case = - [ let config = Utils.defaultConfig - - let getCorrectnessTestName datatype = - sprintf "Correctness on %s, %A" datatype case - - case - |> correctnessGenericTest (=) 0 - |> testPropertyWithConfig config (getCorrectnessTestName "int") - - case - |> correctnessGenericTest (fun x y -> abs (x - y) < Accuracy.medium.absolute) 0. - |> testPropertyWithConfig config (getCorrectnessTestName "float") - - case - |> correctnessGenericTest (=) 0s - |> testPropertyWithConfig config (getCorrectnessTestName "int16") - - case - |> correctnessGenericTest (=) 0us - |> testPropertyWithConfig config (getCorrectnessTestName "uint16") - - case - |> correctnessGenericTest (=) false - |> ptestPropertyWithConfig config (getCorrectnessTestName "bool") ] - -let tests = - testCases - |> List.filter - (fun case -> - let mutable e = ErrorCode.Unknown - let device = case.ClContext.Device - - let deviceType = - Cl - .GetDeviceInfo(device, DeviceInfo.Type, &e) - .CastTo() - - deviceType = DeviceType.Cpu - && case.MatrixCase = CSR) - |> List.collect testFixtures - |> testList "Matrix.tuples tests" diff --git a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/MxmTests.fs b/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/MxmTests.fs deleted file mode 100644 index ac790a37..00000000 --- a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/MxmTests.fs +++ /dev/null @@ -1,188 +0,0 @@ -module Matrix.Mxm - -open Expecto -open FsCheck -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Tests -open GraphBLAS.FSharp.Predefined -open TypeShape.Core -open Expecto.Logging -open Expecto.Logging.Message -open Brahma.FSharp.OpenCL -open OpenCL.Net - -let logger = Log.create "Matrix.Mxm.Tests" - -type OperationCase = - { ClContext: ClContext - LeftMatrixCase: MatrixFromat - RightMatrixCase: MatrixFromat - MaskCase: MaskType } - -let testCases = - [ Utils.avaliableContexts "" |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box - Utils.listOfUnionCases |> Seq.map box ] - |> List.map List.ofSeq - |> Utils.cartesian - |> List.map - (fun list -> - { ClContext = unbox list.[0] - LeftMatrixCase = unbox list.[1] - RightMatrixCase = unbox list.[2] - MaskCase = unbox list.[3] }) - -let correctnessGenericTest<'a when 'a: struct> - (semiring: ISemiring<'a>) - (isEqual: 'a -> 'a -> bool) - (case: OperationCase) - (leftMatrix: 'a [,], rightMatrix: 'a [,]) - = - - let isZero = isEqual semiring.Zero - - let expected = - let resultRowCount = Array2D.length1 leftMatrix - let resultColCount = Array2D.length2 rightMatrix - - let resultMatrix = - Array2D.zeroCreate<'a> resultRowCount resultColCount - - let plus = semiring.Plus.Invoke - let times = semiring.Times.Invoke - - for idx = 0 to resultRowCount * resultColCount - 1 do - let i = idx / resultColCount - let j = idx % resultColCount - let leftRow = leftMatrix.[i, *] - let rightCol = rightMatrix.[*, j] - - resultMatrix.[i, j] <- - leftRow - |> Array.mapi (fun i v -> times v rightCol.[i]) - |> Array.reduce (fun x y -> plus x y) - - resultMatrix - |> Seq.cast<'a> - |> Seq.mapi - (fun idx v -> - let i = idx / Array2D.length2 leftMatrix - let j = idx % Array2D.length2 leftMatrix - - (i, j, v)) - |> Seq.filter (fun (_, _, v) -> (not << isZero) v) - |> Array.ofSeq - |> Array.unzip3 - |> fun (rows, cols, vals) -> - { RowIndices = rows - ColumnIndices = cols - Values = vals } - - let actual = - try - let left = - Utils.createMatrixFromArray2D case.LeftMatrixCase leftMatrix isZero - - let right = - Utils.createMatrixFromArray2D case.RightMatrixCase rightMatrix isZero - - logger.debug ( - eventX "Left matrix is \n{matrix}" - >> setField "matrix" left - ) - - logger.debug ( - eventX "Right matrix is \n{matrix}" - >> setField "matrix" right - ) - - graphblas { - let! result = Matrix.mxm semiring left right - let! tuples = Matrix.tuples result - do! MatrixTuples.synchronize tuples - return tuples - } - |> EvalGB.withClContext case.ClContext - |> EvalGB.runSync - - finally - // TODO fix me - () - //case.ClContext.Provider.CloseAllBuffers() - - logger.debug ( - eventX "Expected result is {expected}" - >> setField "expected" (sprintf "%A" expected.Values) - ) - - logger.debug ( - eventX "Actual result is {actual}" - >> setField "actual" (sprintf "%A" actual.Values) - ) - - let actualIndices = - Seq.zip actual.RowIndices actual.ColumnIndices - - let expectedIndices = - Seq.zip expected.RowIndices expected.ColumnIndices - - "Indices of expected and result matrix must be the same" - |> Expect.sequenceEqual actualIndices expectedIndices - - let equality = - (expected.Values, actual.Values) - ||> Seq.map2 isEqual - - "Length of expected and result values should be equal" - |> Expect.hasLength actual.Values (Seq.length expected.Values) - - "There should be no difference between expected and received values" - |> Expect.allEqual equality true - -let testFixtures case = - [ let config = Utils.defaultConfig - - let getCorrectnessTestName datatype = - sprintf "Correctness on %s, %A" datatype case - - case - |> correctnessGenericTest AddMult.int (=) - |> testPropertyWithConfig config (getCorrectnessTestName "int") - - case - |> correctnessGenericTest AddMult.float (fun x y -> abs (x - y) < Accuracy.medium.absolute) - |> testPropertyWithConfig config (getCorrectnessTestName "float") - - case - |> correctnessGenericTest AddMult.int16 (=) - |> testPropertyWithConfig config (getCorrectnessTestName "int16") - - case - |> correctnessGenericTest AddMult.uint16 (=) - |> testPropertyWithConfig config (getCorrectnessTestName "uint16") - - case - |> correctnessGenericTest AnyAll.bool (=) - |> ptestPropertyWithConfig config (getCorrectnessTestName "bool") ] - -let tests = - testCases - |> List.filter - (fun case -> - let mutable e = ErrorCode.Unknown - let device = case.ClContext.Device - - let deviceType = - Cl - .GetDeviceInfo(device, DeviceInfo.Type, &e) - .CastTo() - - deviceType = DeviceType.Cpu - && case.LeftMatrixCase = CSR - && case.RightMatrixCase = CSR - && case.MaskCase = NoMask) - |> List.collect testFixtures - |> testList "Matrix.mxm tests" diff --git a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/MxvTests.fs b/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/MxvTests.fs deleted file mode 100644 index 57bb079a..00000000 --- a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/MxvTests.fs +++ /dev/null @@ -1,240 +0,0 @@ -module Matrix.Mxv - -open Expecto -open FsCheck -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Tests -open GraphBLAS.FSharp.Predefined -open TypeShape.Core -open Expecto.Logging -open Expecto.Logging.Message -open Brahma.FSharp.OpenCL -open OpenCL.Net - -let logger = Log.create "Matrix.Mxv.Tests" - -type OperationCase = - { ClContext: ClContext - MatrixCase: MatrixFromat - VectorCase: VectorFormat - MaskCase: MaskType } - -let testCases = - [ Utils.avaliableContexts "" |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box - Utils.listOfUnionCases |> Seq.map box ] - |> List.map List.ofSeq - |> Utils.cartesian - |> List.map - (fun list -> - { ClContext = unbox list.[0] - MatrixCase = unbox list.[1] - VectorCase = unbox list.[2] - MaskCase = unbox list.[3] }) - -let correctnessGenericTest<'a when 'a: struct> - (semiring: ISemiring<'a>) - (isEqual: 'a -> 'a -> bool) - (case: OperationCase) - (matrix: 'a [,], vector: 'a [], mask: bool []) - = - - let isZero = isEqual semiring.Zero - - let expected = - let resultSize = Array2D.length1 matrix - let resultVector = Array.zeroCreate<'a option> resultSize - - let times = semiring.Times.Invoke - let plus = semiring.Plus.Invoke - - let task i = - let col = matrix.[i, *] - - resultVector.[i] <- - vector - |> Array.Parallel.mapi - (fun i v -> - let res = times v col.[i] - if isZero res then None else Some res) - |> Array.fold - (fun x y -> - match x, y with - | None, None -> None - | None, Some a -> Some a - | Some a, None -> Some a - | Some a, Some b -> Some <| plus a b) - None - - System.Threading.Tasks.Parallel.For(0, resultSize, task) - |> ignore - - resultVector - |> Seq.cast<'a option> - |> Seq.mapi (fun i v -> (i, v)) - |> Seq.filter - (fun (i, v) -> - (not << Option.isNone) v - && match case.MaskCase with - | NoMask -> true - | Regular -> mask.[i] - | Complemented -> not mask.[i]) - |> Seq.map (fun (i, v) -> i, Option.get v) - |> Array.ofSeq - |> Array.unzip - |> fun (cols, vals) -> { Indices = cols; Values = vals } - - let actual = - try - let matrix = - Utils.createMatrixFromArray2D case.MatrixCase matrix isZero - - let vector = - Utils.createVectorFromArray case.VectorCase vector isZero - - let mask = - Utils.createVectorFromArray VectorFormat.COO mask not - - logger.debug ( - eventX "Matrix is \n{matrix}" - >> setField "matrix" matrix - ) - - logger.debug ( - eventX "Vector is \n{vector}" - >> setField "vector" vector - ) - - graphblas { - let! result = - match case.MaskCase with - | NoMask -> Matrix.mxv semiring matrix vector - | Regular -> failwith "fix me" - //Vector.mask mask - //>>= fun mask -> Matrix.mxvWithMask semiring mask matrix vector - | Complemented -> failwith "fix me" - //Vector.complemented mask - //>>= fun mask -> Matrix.mxvWithMask semiring mask matrix vector - - let! tuples = Vector.tuples result - do! VectorTuples.synchronize tuples - return tuples - } - |> EvalGB.withClContext case.ClContext - |> EvalGB.runSync - - finally - // TODO fix me - () - // case.ClContext.Provider.CloseAllBuffers() - - logger.debug ( - eventX "Expected result is {expected}" - >> setField "expected" (sprintf "%A" expected.Values) - ) - - logger.debug ( - eventX "Actual result is {actual}" - >> setField "actual" (sprintf "%A" actual.Values) - ) - - let actualIndices = actual.Indices - let expectedIndices = expected.Indices - - "Indices of expected and result vector must be the same" - |> Expect.sequenceEqual actualIndices expectedIndices - - let equality = - (expected.Values, actual.Values) - ||> Seq.map2 isEqual - - "Length of expected and result values should be equal" - |> Expect.hasLength actual.Values (Seq.length expected.Values) - - "There should be no difference between expected and received values" - |> Expect.allEqual equality true - -let testFixtures case = - [ let config = Utils.defaultConfig - - let getCorrectnessTestName datatype = - sprintf "Correctness on %s, %A" datatype case - - case - |> correctnessGenericTest AddMult.int (=) - |> testPropertyWithConfig config (getCorrectnessTestName "int") - - case - |> correctnessGenericTest AddMult.float (fun x y -> abs (x - y) < Accuracy.low.relative) - |> ptestPropertyWithConfig config (getCorrectnessTestName "float") - - case - |> correctnessGenericTest AddMult.int16 (=) - |> testPropertyWithConfig config (getCorrectnessTestName "int16") - - case - |> correctnessGenericTest AddMult.uint16 (=) - |> testPropertyWithConfig config (getCorrectnessTestName "uint16") - - case - |> correctnessGenericTest AnyAll.bool (=) - |> ptestPropertyWithConfig config (getCorrectnessTestName "bool") - - testCase (sprintf "Explicit zero test on %A" case) - <| fun () -> - let matrix = array2D [ [ 1; 0 ]; [ 0; 0 ]; [ 1; 1 ] ] - - let vector = [| 4; -4 |] - - let expected = - { Indices = [| 0; 2 |] - Values = [| 4; 0 |] } - - let actual = - try - let matrix = - Utils.createMatrixFromArray2D case.MatrixCase matrix ((=) 0) - - let vector = - Utils.createVectorFromArray case.VectorCase vector ((=) 0) - - graphblas { failwith "fix me" } - |> EvalGB.withClContext case.ClContext - |> EvalGB.runSync - - finally - // TODO fix me - failwith "fix me" - // case.ClContext.Provider.CloseAllBuffers() - failwith "fix me" - //"Indices of actual and expected vectors should be the same" - // |> Expect.sequenceEqual actual.Indices expected.Indices - - failwith "fix me" - //"Values of actual and expected vectors should be the same" - // |> Expect.sequenceEqual actual.Values expected.Values - - case - |> correctnessGenericTest CustomDatatypes.addMultSemiringOnWrappedInt (=) - |> ptestPropertyWithConfig config (getCorrectnessTestName "WrappedInt") ] - -let tests = - testCases - |> List.filter - (fun case -> - let mutable e = ErrorCode.Unknown - let device = case.ClContext.Device - - let deviceType = - Cl - .GetDeviceInfo(device, DeviceInfo.Type, &e) - .CastTo() - - deviceType = DeviceType.Cpu - && case.MatrixCase = CSR - && case.VectorCase = VectorFormat.COO) - |> List.collect testFixtures - |> testList "Matrix.mxv tests" diff --git a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/TransposeTests.fs b/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/TransposeTests.fs deleted file mode 100644 index bbdb7715..00000000 --- a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/TransposeTests.fs +++ /dev/null @@ -1,154 +0,0 @@ -module Matrix.Transpose - -open Expecto -open FsCheck -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Tests -open GraphBLAS.FSharp.Predefined -open TypeShape.Core -open Expecto.Logging -open Expecto.Logging.Message -open Brahma.FSharp.OpenCL -open OpenCL.Net - -let logger = Log.create "Matrix.Transpose.Tests" - -type OperationCase = - { ClContext: ClContext - MatrixCase: MatrixFromat } - -let testCases = - [ Utils.avaliableContexts "" |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box ] - |> List.map List.ofSeq - |> Utils.cartesian - |> List.map - (fun list -> - { ClContext = unbox list.[0] - MatrixCase = unbox list.[1] }) - -let correctnessGenericTest<'a when 'a: struct> - (isEqual: 'a -> 'a -> bool) - (zero: 'a) - (case: OperationCase) - (matrix: 'a [,]) - = - - let isZero = isEqual zero - - let expected = - let transposed = - Array2D.init (Array2D.length2 matrix) (Array2D.length1 matrix) (fun r c -> matrix.[c, r]) - - transposed - |> Seq.cast<'a> - |> Seq.mapi - (fun idx v -> - let i = idx / Array2D.length1 matrix - let j = idx % Array2D.length1 matrix - - (i, j, v)) - |> Seq.filter (fun (_, _, v) -> (not << isZero) v) - |> Array.ofSeq - |> Array.unzip3 - |> fun (rows, cols, vals) -> - { RowIndices = rows - ColumnIndices = cols - Values = vals } - - let actual = - try - let matrix = - Utils.createMatrixFromArray2D case.MatrixCase matrix isZero - - logger.debug ( - eventX "Matrix is \n{matrix}" - >> setField "matrix" matrix - ) - - graphblas { - let! result = Matrix.transpose matrix - let! tuples = Matrix.tuples result - do! MatrixTuples.synchronize tuples - return tuples - } - |> EvalGB.withClContext case.ClContext - |> EvalGB.runSync - - finally - // TODO fix me - failwith "fix me" - //case.ClContext.Provider.CloseAllBuffers() - - logger.debug ( - eventX "Expected result is {expected}" - >> setField "expected" (sprintf "%A" expected.Values) - ) - - logger.debug ( - eventX "Actual result is {actual}" - >> setField "actual" (sprintf "%A" actual.Values) - ) - - let actualIndices = - Seq.zip actual.RowIndices actual.ColumnIndices - - let expectedIndices = - Seq.zip expected.RowIndices expected.ColumnIndices - - "Indices of expected and result vector must be the same" - |> Expect.sequenceEqual actualIndices expectedIndices - - let equality = - (expected.Values, actual.Values) - ||> Seq.map2 isEqual - - "Length of expected and result values should be equal" - |> Expect.hasLength actual.Values (Seq.length expected.Values) - - "There should be no difference between expected and received values" - |> Expect.allEqual equality true - -let testFixtures case = - [ let config = Utils.defaultConfig - - let getCorrectnessTestName datatype = - sprintf "Correctness on %s, %A" datatype case - - case - |> correctnessGenericTest (=) 0 - |> testPropertyWithConfig config (getCorrectnessTestName "int") - - case - |> correctnessGenericTest (fun x y -> abs (x - y) < Accuracy.medium.absolute) 0. - |> testPropertyWithConfig config (getCorrectnessTestName "float") - - case - |> correctnessGenericTest (=) 0s - |> testPropertyWithConfig config (getCorrectnessTestName "int16") - - case - |> correctnessGenericTest (=) 0us - |> testPropertyWithConfig config (getCorrectnessTestName "uint16") - - case - |> correctnessGenericTest (=) false - |> ptestPropertyWithConfig config (getCorrectnessTestName "bool") ] - -let tests = - testCases - |> List.filter - (fun case -> - let mutable e = ErrorCode.Unknown - let device = case.ClContext.Device - - let deviceType = - Cl - .GetDeviceInfo(device, DeviceInfo.Type, &e) - .CastTo() - - deviceType = DeviceType.Cpu - && case.MatrixCase = CSR) - |> List.collect testFixtures - |> testList "Matrix.transpose tests" diff --git a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/VxmTests.fs b/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/VxmTests.fs deleted file mode 100644 index 396e42d3..00000000 --- a/tests/GraphBLAS-sharp.Tests/MatrixOperationsTests/VxmTests.fs +++ /dev/null @@ -1,188 +0,0 @@ -module Matrix.Vxm - -open Expecto -open FsCheck -open GraphBLAS.FSharp -open GraphBLAS.FSharp.Tests -open GraphBLAS.FSharp.Predefined -open TypeShape.Core -open Expecto.Logging -open Expecto.Logging.Message -open Brahma.FSharp.OpenCL -open OpenCL.Net - -let logger = Log.create "Matrix.Vxm.Tests" - -type OperationCase = - { ClContext: ClContext - VectorCase: VectorFormat - MatrixCase: MatrixFromat - MaskCase: MaskType } - -let testCases = - [ Utils.avaliableContexts "" |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box - Utils.listOfUnionCases |> Seq.map box ] - |> List.map List.ofSeq - |> Utils.cartesian - |> List.map - (fun list -> - { ClContext = unbox list.[0] - VectorCase = unbox list.[1] - MatrixCase = unbox list.[2] - MaskCase = unbox list.[3] }) - -let correctnessGenericTest<'a when 'a: struct> - (semiring: ISemiring<'a>) - (isEqual: 'a -> 'a -> bool) - (case: OperationCase) - (vector: 'a [], matrix: 'a [,], mask: bool []) - = - - let isZero = isEqual semiring.Zero - - let expected = - let resultSize = Array2D.length2 matrix - let resultVector = Array.zeroCreate<'a> resultSize - - let plus = semiring.Plus.Invoke - let times = semiring.Times.Invoke - - for i = 0 to resultSize - 1 do - let col = matrix.[*, i] - - resultVector.[i] <- - vector - |> Array.mapi (fun i v -> times v col.[i]) - |> Array.reduce (fun x y -> plus x y) - - resultVector - |> Seq.cast<'a> - |> Seq.mapi (fun i v -> (i, v)) - |> Seq.filter - (fun (i, v) -> - (not << isZero) v - && match case.MaskCase with - | NoMask -> true - | Regular -> mask.[i] - | Complemented -> not mask.[i]) - |> Array.ofSeq - |> Array.unzip - |> fun (cols, vals) -> { Indices = cols; Values = vals } - - let actual = - try - let vector = - Utils.createVectorFromArray case.VectorCase vector isZero - - let matrix = - Utils.createMatrixFromArray2D case.MatrixCase matrix isZero - - let mask = - Utils.createVectorFromArray VectorFormat.COO mask not - - logger.debug ( - eventX "Vector is \n{vector}" - >> setField "vector" vector - ) - - logger.debug ( - eventX "Matrix is \n{matrix}" - >> setField "matrix" matrix - ) - - graphblas { - let! result = - match case.MaskCase with - | NoMask -> Matrix.vxm semiring vector matrix - | Regular -> failwith "fix me" - //Vector.mask mask - //>>= fun mask -> Matrix.vxmWithMask semiring mask vector matrix - | Complemented -> failwith "fix me" - //Vector.complemented mask - //>>= fun mask -> Matrix.vxmWithMask semiring mask vector matrix - - let! tuples = Vector.tuples result - do! VectorTuples.synchronize tuples - return tuples - } - |> EvalGB.withClContext case.ClContext - |> EvalGB.runSync - - finally - failwith "fix me" - //case.ClContext.Provider.CloseAllBuffers() - - logger.debug ( - eventX "Expected result is {expected}" - >> setField "expected" (sprintf "%A" expected.Values) - ) - - logger.debug ( - eventX "Actual result is {actual}" - >> setField "actual" (sprintf "%A" actual.Values) - ) - - let actualIndices = actual.Indices - let expectedIndices = expected.Indices - - "Indices of expected and result vector must be the same" - |> Expect.sequenceEqual actualIndices expectedIndices - - let equality = - (expected.Values, actual.Values) - ||> Seq.map2 isEqual - - "Length of expected and result values should be equal" - |> Expect.hasLength actual.Values (Seq.length expected.Values) - - "There should be no difference between expected and received values" - |> Expect.allEqual equality true - -let testFixtures case = - [ let config = Utils.defaultConfig - - let getCorrectnessTestName datatype = - sprintf "Correctness on %s, %A" datatype case - - case - |> correctnessGenericTest AddMult.int (=) - |> testPropertyWithConfig config (getCorrectnessTestName "int") - - case - |> correctnessGenericTest AddMult.float (fun x y -> abs (x - y) < Accuracy.medium.absolute) - |> testPropertyWithConfig config (getCorrectnessTestName "float") - - case - |> correctnessGenericTest AddMult.int16 (=) - |> testPropertyWithConfig config (getCorrectnessTestName "int16") - - case - |> correctnessGenericTest AddMult.uint16 (=) - |> testPropertyWithConfig config (getCorrectnessTestName "uint16") - - case - |> correctnessGenericTest AnyAll.bool (=) - |> ptestPropertyWithConfig config (getCorrectnessTestName "bool") ] - -let tests = - testCases - |> List.filter - (fun case -> - let mutable e = ErrorCode.Unknown - let device = case.ClContext.Device - - let deviceType = - Cl - .GetDeviceInfo(device, DeviceInfo.Type, &e) - .CastTo() - - deviceType = DeviceType.Cpu - && case.VectorCase = VectorFormat.COO - && case.MatrixCase = CSR - && case.MaskCase = NoMask) - |> List.collect testFixtures - |> testList "Matrix.vxm tests" diff --git a/tests/GraphBLAS-sharp.Tests/Program.fs b/tests/GraphBLAS-sharp.Tests/Program.fs index 719aad6f..9049b03e 100644 --- a/tests/GraphBLAS-sharp.Tests/Program.fs +++ b/tests/GraphBLAS-sharp.Tests/Program.fs @@ -1,74 +1,116 @@ open Expecto open GraphBLAS.FSharp.Tests.Backend +open GraphBLAS.FSharp.Tests let matrixTests = testList - "Matrix tests" + "Matrix" [ Matrix.Convert.tests - Matrix.Map2.addTests - Matrix.Map2.addAtLeastOneTests - Matrix.Map2.mulAtLeastOneTests - Matrix.Map2.addAtLeastOneToCOOTests - Matrix.Mxm.tests - Matrix.Transpose.tests ] + Matrix.Map2.allTests + Matrix.Map.allTests + Matrix.Merge.allTests + Matrix.Transpose.tests + Matrix.RowsLengths.tests + Matrix.ByRows.tests + Matrix.ExpandRows.tests + Matrix.SubRows.tests + Matrix.Kronecker.tests + + Matrix.SpGeMM.Expand.generalTests + Matrix.SpGeMM.Masked.tests ] |> testSequenced let commonTests = + let scanTests = + testList + "Scan" + [ Common.Scan.ByKey.sequentialSegmentsTests + Common.Scan.PrefixSum.tests ] + + let reduceTests = + testList + "Reduce" + [ Common.Reduce.ByKey.allTests + Common.Reduce.Reduce.tests + Common.Reduce.Sum.tests ] + let clArrayTests = testList "ClArray" - [ Common.ClArray.PrefixSum.tests - Common.ClArray.RemoveDuplicates.tests + [ Common.ClArray.RemoveDuplicates.tests Common.ClArray.Copy.tests Common.ClArray.Replicate.tests Common.ClArray.Exists.tests Common.ClArray.Map.tests Common.ClArray.Map2.addTests Common.ClArray.Map2.mulTests - Common.ClArray.Choose.tests ] + Common.ClArray.Choose.allTests + Common.ClArray.ChunkBySize.allTests + Common.ClArray.Blit.tests + Common.ClArray.Concat.tests + Common.ClArray.Fill.tests + Common.ClArray.Pairwise.tests + Common.ClArray.UpperBound.tests + Common.ClArray.Set.tests + Common.ClArray.Item.tests ] + + let sortTests = + testList + "Sort" + [ Common.Sort.Bitonic.tests + Common.Sort.Radix.allTests ] testList - "Common tests" - [ clArrayTests - Common.BitonicSort.tests - Common.Scatter.tests - Common.Reduce.tests - Common.Sum.tests ] + "Common" + [ Common.Scatter.allTests + Common.Gather.allTests + Common.Merge.tests + clArrayTests + sortTests + reduceTests + scanTests ] |> testSequenced let vectorTests = testList - "Vector tests" + "Vector" [ Vector.SpMV.tests Vector.ZeroCreate.tests Vector.OfList.tests Vector.Copy.tests Vector.Convert.tests - Vector.Map2.addTests - Vector.Map2.mulTests - Vector.Map2.addAtLeastOneTests - Vector.Map2.mulAtLeastOneTests - Vector.Map2.addGeneralTests - Vector.Map2.mulGeneralTests - Vector.Map2.complementedGeneralTests + Vector.Map2.allTests Vector.AssignByMask.tests Vector.AssignByMask.complementedTests - Vector.Reduce.tests ] + Vector.Reduce.tests + Vector.Merge.tests ] |> testSequenced let algorithmsTests = testList "Algorithms tests" [ Algorithms.BFS.tests ] |> testSequenced -[] -let allTests = +let deviceTests = testList - "All tests" - [ commonTests - matrixTests + "Device" + [ matrixTests + commonTests vectorTests algorithmsTests ] |> testSequenced +let hostTests = + testList + "Host" + [ Host.Matrix.FromArray2D.tests + Host.Matrix.Convert.tests + Host.IO.MtxReader.test ] + |> testSequenced + +[] +let allTests = + testList "All" [ deviceTests; hostTests ] + |> testSequenced + [] let main argv = allTests |> runTestsWithCLIArgs [] argv