diff --git a/src/GraphBLAS-sharp.Backend/Common/CommonQuotes.fs b/src/GraphBLAS-sharp.Backend/Common/CommonQuotes.fs index 3c29b316..00c865b9 100644 --- a/src/GraphBLAS-sharp.Backend/Common/CommonQuotes.fs +++ b/src/GraphBLAS-sharp.Backend/Common/CommonQuotes.fs @@ -36,6 +36,23 @@ module SubSum = let treeSum<'a> opAdd = sumGeneral<'a> <| treeAccess<'a> opAdd +module SubReduce = + let run opAdd = + <@ fun length wgSize gid lid (localValues: 'a []) -> + let mutable step = 2 + + while step <= wgSize do + if (gid + wgSize / step) < length + && lid < wgSize / step then + let firstValue = localValues.[lid] + let secondValue = localValues.[lid + wgSize / step] + + localValues.[lid] <- (%opAdd) firstValue secondValue + + step <- step <<< 1 + + barrierLocal () @> + module PreparePositions = let both<'c> = <@ fun index (result: 'c option) (rawPositionsBuffer: ClArray) (allValuesBuffer: ClArray<'c>) -> diff --git a/src/GraphBLAS-sharp.Backend/Common/Reduce.fs b/src/GraphBLAS-sharp.Backend/Common/Reduce.fs new file mode 100644 index 00000000..0468a10a --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Common/Reduce.fs @@ -0,0 +1,144 @@ +namespace GraphBLAS.FSharp.Backend.Common + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend +open Microsoft.FSharp.Control +open Microsoft.FSharp.Quotations + +module Reduce = + let private scan<'a when 'a: struct> (clContext: ClContext) (workGroupSize: int) (opAdd: Expr<'a -> 'a -> 'a>) = + + let scan = + <@ fun (ndRange: Range1D) length (inputArray: ClArray<'a>) (resultArray: ClArray<'a>) -> + + let gid = ndRange.GlobalID0 + let lid = ndRange.LocalID0 + + let localValues = localArray<'a> workGroupSize + + if gid < length then + localValues.[lid] <- inputArray.[gid] + + barrierLocal () + + if gid < length then + + (%SubReduce.run opAdd) length workGroupSize gid lid localValues + + if lid = 0 then + resultArray.[gid / workGroupSize] <- localValues.[0] @> + + let kernel = clContext.Compile(scan) + + fun (processor: MailboxProcessor<_>) (valuesArray: ClArray<'a>) valuesLength (resultArray: ClArray<'a>) -> + + let ndRange = + Range1D.CreateValid(valuesArray.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange valuesLength valuesArray resultArray) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let private scanToCell<'a when 'a: struct> + (clContext: ClContext) + (workGroupSize: int) + (opAdd: Expr<'a -> 'a -> 'a>) + = + + let scan = + <@ fun (ndRange: Range1D) length (inputArray: ClArray<'a>) (resultValue: ClCell<'a>) -> + + let gid = ndRange.GlobalID0 + let lid = ndRange.LocalID0 + + let localValues = localArray<'a> workGroupSize + + if gid < length then + localValues.[lid] <- inputArray.[gid] + + barrierLocal () + + if gid < length then + + (%SubReduce.run opAdd) length workGroupSize gid lid localValues + + if lid = 0 then + resultValue.Value <- localValues.[0] @> + + let kernel = clContext.Compile(scan) + + fun (processor: MailboxProcessor<_>) (valuesArray: ClArray<'a>) valuesLength (resultValue: ClCell<'a>) -> + + let ndRange = + Range1D.CreateValid(valuesArray.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange valuesLength valuesArray resultValue) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + let run<'a when 'a: struct> (clContext: ClContext) (workGroupSize: int) (opAdd: Expr<'a -> 'a -> 'a>) = + + let scan = scan clContext workGroupSize opAdd + + let scanToCell = scanToCell clContext workGroupSize opAdd + + fun (processor: MailboxProcessor<_>) (inputArray: ClArray<'a>) -> + + let scan = scan processor + + let firstLength = + (inputArray.Length - 1) / workGroupSize + 1 + + let firstVerticesArray = + clContext.CreateClArray( + firstLength, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let secondLength = (firstLength - 1) / workGroupSize + 1 + + let secondVerticesArray = + clContext.CreateClArray( + secondLength, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let mutable verticesArrays = firstVerticesArray, secondVerticesArray + let swap (a, b) = (b, a) + + scan inputArray inputArray.Length (fst verticesArrays) + + let mutable verticesLength = firstLength + + while verticesLength > workGroupSize do + let fstVertices = fst verticesArrays + let sndVertices = snd verticesArrays + + scan fstVertices verticesLength sndVertices + + verticesArrays <- swap verticesArrays + verticesLength <- (verticesLength - 1) / workGroupSize + 1 + + let fstVertices = fst verticesArrays + + let result = + clContext.CreateClCell Unchecked.defaultof<'a> + + scanToCell processor fstVertices verticesLength result + + processor.Post(Msg.CreateFreeMsg(firstVerticesArray)) + processor.Post(Msg.CreateFreeMsg(secondVerticesArray)) + + result diff --git a/src/GraphBLAS-sharp.Backend/Common/StandardOperations.fs b/src/GraphBLAS-sharp.Backend/Common/StandardOperations.fs index 8717aacd..96a1008f 100644 --- a/src/GraphBLAS-sharp.Backend/Common/StandardOperations.fs +++ b/src/GraphBLAS-sharp.Backend/Common/StandardOperations.fs @@ -1,5 +1,7 @@ namespace GraphBLAS.FSharp.Backend.Common +open FSharp.Quotations + type AtLeastOne<'a, 'b when 'a: struct and 'b: struct> = | Both of 'a * 'b | Left of 'a @@ -109,3 +111,33 @@ module StandardOperations = | None, Some right -> (%op) (Right right) | Some left, None -> (%op) (Left left) | None, None -> None @> + + let fillSubToOption (op: Expr<'a option -> 'a option -> 'a option>) = + <@ fun (leftItem: 'a option) (rightItem: 'b option) (value: 'a) -> + match rightItem with + | Some _ -> (%op) leftItem (Some value) + | None -> (%op) leftItem None @> + + let fillSubComplementedToOption (op: Expr<'a option -> 'a option -> 'a option>) = + <@ fun (leftItem: 'a option) (rightItem: 'b option) (value: 'a) -> + match rightItem with + | Some _ -> (%op) leftItem None + | None -> (%op) leftItem (Some value) @> + + let fillSubOp<'a when 'a: struct> = + <@ fun (left: 'a option) (right: 'a option) -> + match left, right with + | _, None -> left + | _ -> right @> + + let maskOp<'a, 'b when 'a: struct and 'b: struct> = + <@ fun (left: 'a option) (right: 'b option) -> + match right with + | Some _ -> left + | _ -> None @> + + let complementedMaskOp<'a, 'b when 'a: struct and 'b: struct> = + <@ fun (left: 'a option) (right: 'b option) -> + match right with + | None -> left + | _ -> None @> diff --git a/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj b/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj index 5a6a9d25..bb0c9265 100644 --- a/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj +++ b/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj @@ -19,6 +19,7 @@ + @@ -32,6 +33,10 @@ + + + + diff --git a/src/GraphBLAS-sharp.Backend/Vector/DenseVector/DenseVector.fs b/src/GraphBLAS-sharp.Backend/Vector/DenseVector/DenseVector.fs new file mode 100644 index 00000000..b66c00aa --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/DenseVector/DenseVector.fs @@ -0,0 +1,231 @@ +namespace GraphBLAS.FSharp.Backend.DenseVector + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Common +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend.Predefined + +module DenseVector = + let elementWise<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> + (clContext: ClContext) + (opAdd: Expr<'a option -> 'b option -> 'c option>) + (workGroupSize: int) + = + + let elementWise = + <@ fun (ndRange: Range1D) resultLength (leftVector: ClArray<'a option>) (rightVector: ClArray<'b option>) (resultVector: ClArray<'c option>) -> + + let gid = ndRange.GlobalID0 + + if gid < resultLength then + resultVector.[gid] <- (%opAdd) leftVector.[gid] rightVector.[gid] @> + + let kernel = clContext.Compile(elementWise) + + fun (processor: MailboxProcessor<_>) (leftVector: ClArray<'a option>) (rightVector: ClArray<'b option>) -> + let resultVector = + clContext.CreateClArray( + leftVector.Length, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let ndRange = + Range1D.CreateValid(leftVector.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange leftVector.Length leftVector rightVector resultVector) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + resultVector + + let elementWiseAtLeastOne clContext op workGroupSize = + elementWise clContext (StandardOperations.atLeastOneToOption op) workGroupSize + + let fillSubVector<'a, 'b when 'a: struct and 'b: struct> + (clContext: ClContext) + (maskOp: Expr<'a option -> 'b option -> 'a -> 'a option>) + (workGroupSize: int) + = + + let fillSubVectorKernel = + <@ fun (ndRange: Range1D) resultLength (leftVector: ClArray<'a option>) (maskVector: ClArray<'b option>) (value: ClCell<'a>) (resultVector: ClArray<'a option>) -> + + let gid = ndRange.GlobalID0 + + if gid < resultLength then + resultVector.[gid] <- (%maskOp) leftVector.[gid] maskVector.[gid] value.Value @> + + let kernel = clContext.Compile(fillSubVectorKernel) + + fun (processor: MailboxProcessor<_>) (leftVector: ClArray<'a option>) (maskVector: ClArray<'b option>) (value: ClCell<'a>) -> + let resultVector = + clContext.CreateClArray<'a option>( + leftVector.Length, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let ndRange = + Range1D.CreateValid(leftVector.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange leftVector.Length leftVector maskVector value resultVector) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + resultVector + + let private getBitmap<'a when 'a: struct> (clContext: ClContext) (workGroupSize: int) = + + let getPositions = + <@ fun (ndRange: Range1D) length (vector: ClArray<'a option>) (positions: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid < length then + match vector.[gid] with + | Some _ -> positions.[gid] <- 1 + | None -> positions.[gid] <- 0 @> + + let kernel = clContext.Compile(getPositions) + + fun (processor: MailboxProcessor<_>) (vector: ClArray<'a option>) -> + let positions = + clContext.CreateClArray( + vector.Length, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let ndRange = + Range1D.CreateValid(vector.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post(Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange vector.Length vector positions)) + + processor.Post(Msg.CreateRunMsg(kernel)) + + positions + + let private getValuesAndIndices<'a when 'a: struct> (clContext: ClContext) (workGroupSize: int) = + + let getValuesAndIndices = + <@ fun (ndRange: Range1D) length (denseVector: ClArray<'a option>) (positions: ClArray) (resultValues: ClArray<'a>) (resultIndices: ClArray) -> + + let gid = ndRange.GlobalID0 + + if gid = length - 1 + || gid < length + && positions.[gid] <> positions.[gid + 1] then + let index = positions.[gid] + + match denseVector.[gid] with + | Some value -> + resultValues.[index] <- value + resultIndices.[index] <- gid + | None -> () @> + + let kernel = clContext.Compile(getValuesAndIndices) + + let getPositions = getBitmap clContext workGroupSize + + let prefixSum = + PrefixSum.standardExcludeInplace clContext workGroupSize + + let resultLength = Array.zeroCreate 1 + + fun (processor: MailboxProcessor<_>) (vector: ClArray<'a option>) -> + + let positions = getPositions processor vector + + let resultLengthGpu = clContext.CreateClCell 0 + + let _, r = + prefixSum processor positions resultLengthGpu + + let resultLength = + let res = + processor.PostAndReply(fun ch -> Msg.CreateToHostMsg<_>(r, resultLength, ch)) + + processor.Post(Msg.CreateFreeMsg<_>(r)) + + res.[0] + + let resultValues = + clContext.CreateClArray<'a>( + resultLength, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let resultIndices = + clContext.CreateClArray( + resultLength, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let ndRange = + Range1D.CreateValid(vector.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> kernel.KernelFunc ndRange vector.Length vector positions resultValues resultIndices) + ) + + processor.Post(Msg.CreateRunMsg(kernel)) + + processor.Post(Msg.CreateFreeMsg<_>(positions)) + + resultValues, resultIndices + + let toSparse<'a when 'a: struct> (clContext: ClContext) (workGroupSize: int) = + + let getValuesAndIndices = + getValuesAndIndices clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (vector: ClArray<'a option>) -> + + let values, indices = getValuesAndIndices processor vector + + { Context = clContext + Indices = indices + Values = values + Size = vector.Length } + + let reduce<'a when 'a: struct> (clContext: ClContext) (workGroupSize: int) (opAdd: Expr<'a -> 'a -> 'a>) = + + let getValuesAndIndices = + getValuesAndIndices clContext workGroupSize + + let reduce = Reduce.run clContext workGroupSize opAdd + + fun (processor: MailboxProcessor<_>) (vector: ClArray<'a option>) -> + + let values, indices = getValuesAndIndices processor vector + + let result = reduce processor values + + processor.Post(Msg.CreateFreeMsg<_>(indices)) + processor.Post(Msg.CreateFreeMsg<_>(values)) + + result diff --git a/src/GraphBLAS-sharp.Backend/Vector/SpMV.fs b/src/GraphBLAS-sharp.Backend/Vector/SpMV.fs index 6c151461..bc1969e5 100644 --- a/src/GraphBLAS-sharp.Backend/Vector/SpMV.fs +++ b/src/GraphBLAS-sharp.Backend/Vector/SpMV.fs @@ -6,8 +6,8 @@ open GraphBLAS.FSharp.Backend.ArraysExtensions open GraphBLAS.FSharp.Backend.Common open Microsoft.FSharp.Quotations -module Vector = - let spMV +module SpMV = + let run (clContext: ClContext) (add: Expr<'c option -> 'c option -> 'c option>) (mul: Expr<'a option -> 'b option -> 'c option>) diff --git a/src/GraphBLAS-sharp.Backend/Vector/SparseVector/SparseElementwise.fs b/src/GraphBLAS-sharp.Backend/Vector/SparseVector/SparseElementwise.fs new file mode 100644 index 00000000..9fed462e --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/SparseVector/SparseElementwise.fs @@ -0,0 +1,190 @@ +namespace GraphBLAS.FSharp.Backend.SparseVector + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open Microsoft.FSharp.Quotations + +module SparseElementwise = + 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 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 + + 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 + + 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 + secondResultValues.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] + isLeftBitMap.[i] <- 0 + else + allIndicesBuffer.[i] <- fstIdx + firstResultValues.[i] <- firstValuesBuffer.[beginIdx + boundaryX] + isLeftBitMap.[i] <- 1 @> + + let private both<'c> = + <@ fun index (result: 'c option) (rawPositionsBuffer: ClArray) (allValuesBuffer: ClArray<'c>) -> + rawPositionsBuffer.[index] <- 0 + + match result with + | Some v -> + allValuesBuffer.[index + 1] <- v + rawPositionsBuffer.[index + 1] <- 1 + | None -> rawPositionsBuffer.[index + 1] <- 0 @> + + let private leftRight<'c> = + <@ fun index (leftResult: 'c option) (rightResult: 'c option) (isLeftBitmap: ClArray) (allValuesBuffer: ClArray<'c>) (rawPositionsBuffer: ClArray) -> + if isLeftBitmap.[index] = 1 then + match leftResult with + | Some v -> + allValuesBuffer.[index] <- v + rawPositionsBuffer.[index] <- 1 + | None -> rawPositionsBuffer.[index] <- 0 + else + match rightResult with + | Some v -> + allValuesBuffer.[index] <- v + rawPositionsBuffer.[index] <- 1 + | None -> rawPositionsBuffer.[index] <- 0 @> + + let prepareFillVector opAdd = + <@ fun (ndRange: Range1D) length (allIndices: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (value: ClCell<'a>) (isLeft: ClArray) (allValues: ClArray<'a>) (positions: ClArray) -> + + let gid = ndRange.GlobalID0 + + let value = value.Value + + if gid < length - 1 + && allIndices.[gid] = allIndices.[gid + 1] then + let result = + (%opAdd) (Some leftValues.[gid]) (Some rightValues.[gid + 1]) value + + (%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 value + + let rightResult = + (%opAdd) None (Some rightValues.[gid]) value + + (%leftRight) gid leftResult rightResult isLeft allValues positions @> + + 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]) + + (%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]) + + (%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 new file mode 100644 index 00000000..0a02d5fc --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/SparseVector/SparseVector.fs @@ -0,0 +1,351 @@ +namespace GraphBLAS.FSharp.Backend.SparseVector + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Common +open Microsoft.FSharp.Control +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend.Predefined + +module SparseVector = + let private merge<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) (workGroupSize: int) = + + let kernel = + clContext.Compile(SparseElementwise.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.CreateClArray( + sumOfSides, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let firstResultValues = + clContext.CreateClArray<'a>( + sumOfSides, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let secondResultValues = + clContext.CreateClArray<'b>( + sumOfSides, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let isLeftBitmap = + clContext.CreateClArray( + sumOfSides, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + 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: int) + = + + let kernel = + clContext.Compile(SparseElementwise.preparePositions op) + + fun (processor: MailboxProcessor<_>) (allIndices: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (isLeft: ClArray) -> + + let length = allIndices.Length + + let allValues = + clContext.CreateClArray<'c>( + length, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let positions = + clContext.CreateClArray( + length, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + 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 + + let private setPositions<'a when 'a: struct> (clContext: ClContext) (workGroupSize: int) = + + let sum = + PrefixSum.standardExcludeInplace clContext workGroupSize + + let valuesScatter = + Scatter.runInplace clContext workGroupSize + + let indicesScatter = + Scatter.runInplace clContext workGroupSize + + let resultLength = Array.zeroCreate 1 + + fun (processor: MailboxProcessor<_>) (allValues: ClArray<'a>) (allIndices: ClArray) (positions: ClArray) -> + + let resultLengthGpu = clContext.CreateClCell 0 + + let _, r = sum processor positions resultLengthGpu + + let resultLength = + let res = + processor.PostAndReply(fun ch -> Msg.CreateToHostMsg<_>(r, resultLength, ch)) + + processor.Post(Msg.CreateFreeMsg<_>(r)) + + res.[0] + + let resultValues = + clContext.CreateClArray<'a>( + resultLength, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let resultIndices = + clContext.CreateClArray( + resultLength, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + valuesScatter processor positions allValues resultValues + + indicesScatter processor positions allIndices resultIndices + + resultValues, resultIndices + + ///. + ///. + ///Should be a power of 2 and greater than 1. + let elementWise<'a, 'b, 'c when 'a: struct and 'b: struct and 'c: struct> + (clContext: ClContext) + op + (workGroupSize: int) + = + + let merge = merge clContext workGroupSize + + let prepare = + preparePositions<'a, 'b, 'c> clContext op workGroupSize + + let setPositions = setPositions clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (leftVector: ClSparseVector<'a>) (rightVector: ClSparseVector<'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 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 elementWiseAtLeastOne + (clContext: ClContext) + (opAdd: Expr -> 'c option>) + (workGroupSize: int) + = + elementWise clContext (StandardOperations.atLeastOneToOption opAdd) workGroupSize + + let private preparePositionsFillSubVector<'a, 'b when 'a: struct and 'b: struct> + (clContext: ClContext) + op + (workGroupSize: int) + = + + let kernel = + clContext.Compile(SparseElementwise.prepareFillVector op) + + fun (processor: MailboxProcessor<_>) (allIndices: ClArray) (leftValues: ClArray<'a>) (rightValues: ClArray<'b>) (value: ClCell<'a>) (isLeft: ClArray) -> + + let length = allIndices.Length + + let allValues = + clContext.CreateClArray<'a>( + length, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let positions = + clContext.CreateClArray( + length, + hostAccessMode = HostAccessMode.NotAccessible, + deviceAccessMode = DeviceAccessMode.ReadWrite, + allocationMode = AllocationMode.Default + ) + + let ndRange = + Range1D.CreateValid(length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments + (fun () -> + kernel.KernelFunc + ndRange + length + allIndices + leftValues + rightValues + value + isLeft + allValues + positions) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + allValues, positions + + ///. + ///. + ///Should be a power of 2 and greater than 1. + let fillSubVector<'a, 'b when 'a: struct and 'b: struct> (clContext: ClContext) op (workGroupSize: int) = + + let merge = merge clContext workGroupSize + + let prepare = + preparePositionsFillSubVector clContext op workGroupSize + + let setPositions = setPositions clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (leftVector: ClSparseVector<'a>) (rightVector: ClSparseVector<'b>) (value: ClCell<'a>) -> + + let allIndices, leftValues, rightValues, isLeft = + merge processor leftVector.Indices leftVector.Values rightVector.Indices rightVector.Values + + let allValues, positions = + prepare processor allIndices leftValues rightValues value isLeft + + processor.Post(Msg.CreateFreeMsg<_>(leftValues)) + processor.Post(Msg.CreateFreeMsg<_>(rightValues)) + processor.Post(Msg.CreateFreeMsg<_>(isLeft)) + + let resultValues, resultIndices = + setPositions processor 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 toDense (clContext: ClContext) (workGroupSize: int) = + + 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<_>) (vector: ClSparseVector<'a>) -> + let resultVector = create processor 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: int) (opAdd: Expr<'a -> 'a -> 'a>) = + + let reduce = Reduce.run clContext workGroupSize opAdd + + fun (processor: MailboxProcessor<_>) (vector: ClSparseVector<'a>) -> reduce processor vector.Values diff --git a/src/GraphBLAS-sharp.Backend/Vector/Vector.fs b/src/GraphBLAS-sharp.Backend/Vector/Vector.fs new file mode 100644 index 00000000..f09fb5a6 --- /dev/null +++ b/src/GraphBLAS-sharp.Backend/Vector/Vector.fs @@ -0,0 +1,206 @@ +namespace GraphBLAS.FSharp.Backend + +open Brahma.FSharp +open GraphBLAS.FSharp.Backend +open Microsoft.FSharp.Control +open Microsoft.FSharp.Quotations +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Backend.DenseVector +open GraphBLAS.FSharp.Backend.SparseVector + +module Vector = + let zeroCreate (clContext: ClContext) (workGroupSize: int) = + let zeroCreate = + ClArray.zeroCreate clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (size: int) (format: VectorFormat) -> + match format with + | Sparse -> + let vector = + { Context = clContext + Indices = clContext.CreateClArray [| 0 |] + Values = clContext.CreateClArray [| Unchecked.defaultof<'a> |] + Size = size } + + ClVectorSparse vector + | Dense -> ClVectorDense <| zeroCreate processor size + + let ofList (clContext: ClContext) = + fun (format: VectorFormat) size (elements: (int * 'a) list) -> + let indices, values = + elements + |> Array.ofList + |> Array.sortBy fst + |> Array.unzip + + match format with + | Sparse -> + SparseVector + .FromTuples(indices, values, size) + .ToDevice clContext + |> ClVectorSparse + | Dense -> + let res = Array.zeroCreate size + + for i in 0 .. indices.Length - 1 do + res.[indices.[i]] <- Some(values.[i]) + + ClVectorDense <| clContext.CreateClArray res + + let copy (clContext: ClContext) (workGroupSize: int) = + let copy = ClArray.copy clContext workGroupSize + + let copyData = ClArray.copy clContext workGroupSize + + let copyOptionData = ClArray.copy clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (vector: ClVector<'a>) -> + match vector with + | ClVectorSparse vector -> + let vector = + { Context = clContext + Indices = copy processor vector.Indices + Values = copyData processor vector.Values + Size = vector.Size } + + ClVectorSparse vector + | ClVectorDense vector -> ClVectorDense <| copyOptionData processor vector + + let mask = copy + + let toSparse (clContext: ClContext) (workGroupSize: int) = + let toSparse = + DenseVector.toSparse clContext workGroupSize + + let copy = copy clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (vector: ClVector<'a>) -> + match vector with + | ClVectorDense vector -> ClVectorSparse <| toSparse processor vector + | ClVectorSparse _ -> copy processor vector + + let toDense (clContext: ClContext) (workGroupSize: int) = + let toDense = + SparseVector.toDense clContext workGroupSize + + let copy = ClArray.copy clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (vector: ClVector<'a>) -> + match vector with + | ClVectorDense vector -> ClVectorDense <| copy processor vector + | ClVectorSparse vector -> ClVectorDense <| toDense processor vector + + let elementWiseAtLeastOne (clContext: ClContext) (opAdd: Expr -> 'c option>) workGroupSize = + let addSparse = + SparseVector.elementWiseAtLeastOne clContext opAdd workGroupSize + + let addDense = + DenseVector.elementWiseAtLeastOne clContext opAdd workGroupSize + + fun (processor: MailboxProcessor<_>) (leftVector: ClVector<'a>) (rightVector: ClVector<'b>) -> + match leftVector, rightVector with + | ClVectorSparse left, ClVectorSparse right -> ClVectorSparse <| addSparse processor left right + | ClVectorDense left, ClVectorDense right -> ClVectorDense <| addDense processor left right + | _ -> failwith "Vector formats are not matching." + + let elementWise (clContext: ClContext) (opAdd: Expr<'a option -> 'b option -> 'c option>) (workGroupSize: int) = + let addDense = + DenseVector.elementWise clContext opAdd workGroupSize + + let addSparse = + SparseVector.elementWise clContext opAdd workGroupSize + + fun (processor: MailboxProcessor<_>) (leftVector: ClVector<'a>) (rightVector: ClVector<'b>) -> + match leftVector, rightVector with + | ClVectorDense leftVector, ClVectorDense rightVector -> + ClVectorDense + <| addDense processor leftVector rightVector + | ClVectorSparse left, ClVectorSparse right -> ClVectorSparse <| addSparse processor left right + | _ -> failwith "Vector formats are not matching." + + let fillSubVector<'a, 'b when 'a: struct and 'b: struct> maskOp (clContext: ClContext) (workGroupSize: int) = + let sparseFillVector = + SparseVector.fillSubVector clContext (StandardOperations.fillSubToOption maskOp) workGroupSize + + let denseFillVector = + DenseVector.fillSubVector clContext (StandardOperations.fillSubToOption maskOp) workGroupSize + + let toSparseVector = + DenseVector.toSparse clContext workGroupSize + + let toSparseMask = + DenseVector.toSparse clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (vector: ClVector<'a>) (maskVector: ClVector<'b>) (value: ClCell<'a>) -> + match vector, maskVector with + | ClVectorSparse vector, ClVectorSparse mask -> + ClVectorSparse + <| sparseFillVector processor vector mask value + | ClVectorSparse vector, ClVectorDense mask -> + let mask = toSparseMask processor mask + + ClVectorSparse + <| sparseFillVector processor vector mask value + | ClVectorDense vector, ClVectorSparse mask -> + let vector = toSparseVector processor vector + + ClVectorSparse + <| sparseFillVector processor vector mask value + | ClVectorDense vector, ClVectorDense mask -> + ClVectorDense + <| denseFillVector processor vector mask value + + let fillSubVectorComplemented<'a, 'b when 'a: struct and 'b: struct> + maskOp + (clContext: ClContext) + (workGroupSize: int) + = + + let denseFillVector = + DenseVector.fillSubVector clContext (StandardOperations.fillSubComplementedToOption maskOp) workGroupSize + + let vectorToDense = + SparseVector.toDense clContext workGroupSize + + let maskToDense = + SparseVector.toDense clContext workGroupSize + + fun (processor: MailboxProcessor<_>) (leftVector: ClVector<'a>) (maskVector: ClVector<'b>) (value: ClCell<'a>) -> + match leftVector, maskVector with + | ClVectorSparse vector, ClVectorSparse mask -> + let denseVector = vectorToDense processor vector + let denseMask = maskToDense processor mask + + ClVectorDense + <| denseFillVector processor denseVector denseMask value + | ClVectorDense vector, ClVectorSparse mask -> + let denseMask = maskToDense processor mask + + ClVectorDense + <| denseFillVector processor vector denseMask value + | ClVectorSparse vector, ClVectorDense mask -> + let denseVector = vectorToDense processor vector + + ClVectorDense + <| denseFillVector processor denseVector mask value + | ClVectorDense vector, ClVectorDense mask -> + ClVectorDense + <| denseFillVector processor vector mask value + + let standardFillSubVector<'a, 'b when 'a: struct and 'b: struct> = + fillSubVector<'a, 'b> StandardOperations.fillSubOp<'a> + + let standardFillSubVectorComplemented<'a, 'b when 'a: struct and 'b: struct> = + fillSubVectorComplemented<'a, 'b> StandardOperations.fillSubOp<'a> + + let reduce (clContext: ClContext) (workGroupSize: int) (opAdd: Expr<'a -> 'a -> 'a>) = + let sparseReduce = + SparseVector.reduce clContext workGroupSize opAdd + + let denseReduce = + DenseVector.reduce clContext workGroupSize opAdd + + fun (processor: MailboxProcessor<_>) (vector: ClVector<'a>) -> + match vector with + | ClVectorSparse vector -> sparseReduce processor vector + | ClVectorDense vector -> denseReduce processor vector diff --git a/tests/GraphBLAS-sharp.Tests/BackendCommonTests/MatrixElementwiseTests.fs b/tests/GraphBLAS-sharp.Tests/BackendCommonTests/MatrixElementwiseTests.fs index 5614fa2f..5e5000ea 100644 --- a/tests/GraphBLAS-sharp.Tests/BackendCommonTests/MatrixElementwiseTests.fs +++ b/tests/GraphBLAS-sharp.Tests/BackendCommonTests/MatrixElementwiseTests.fs @@ -1,18 +1,18 @@ module Backend.Elementwise -open System -open Brahma.FSharp.OpenCL.Shared + open Expecto open Expecto.Logging open Expecto.Logging.Message -open Brahma.FSharp open GraphBLAS.FSharp.Backend open GraphBLAS.FSharp +open GraphBLAS.FSharp.Tests open GraphBLAS.FSharp.Tests.TestCases -open GraphBLAS.FSharp.Tests.Utils open Microsoft.FSharp.Collections -open OpenCL.Net open Backend.Common.StandardOperations +open Context +open TestCases +open Utils let logger = Log.create "Elementwise.Tests" @@ -52,15 +52,15 @@ let correctnessGenericTest toCOOFun (isEqual: 'a -> 'a -> bool) q - (case: MatrixOperationCase) + (case: OperationCase) (leftMatrix: 'a [,], rightMatrix: 'a [,]) = let mtx1 = - createMatrixFromArray2D case.MatrixCase leftMatrix (isEqual zero) + createMatrixFromArray2D case.Format leftMatrix (isEqual zero) let mtx2 = - createMatrixFromArray2D case.MatrixCase rightMatrix (isEqual zero) + createMatrixFromArray2D case.Format rightMatrix (isEqual zero) if mtx1.NNZCount > 0 && mtx2.NNZCount > 0 then try @@ -135,7 +135,7 @@ let testFixturesEWiseAdd case = |> testPropertyWithConfig config (getCorrectnessTestName "byte") ] let elementwiseAddTests = - matrixOperationGPUTests "Backend.Matrix.EWiseAdd tests" testFixturesEWiseAdd + operationGPUTests "Backend.Matrix.EWiseAdd tests" testFixturesEWiseAdd let testFixturesEWiseAddAtLeastOne case = [ let config = defaultConfig @@ -185,7 +185,7 @@ let testFixturesEWiseAddAtLeastOne case = |> testPropertyWithConfig config (getCorrectnessTestName "byte") ] let elementwiseAddAtLeastOneTests = - matrixOperationGPUTests "Backend.Matrix.EWiseAddAtLeastOne tests" testFixturesEWiseAddAtLeastOne + operationGPUTests "Backend.Matrix.EWiseAddAtLeastOne tests" testFixturesEWiseAddAtLeastOne let testFixturesEWiseAddAtLeastOneToCOO case = [ let config = defaultConfig @@ -235,9 +235,9 @@ let testFixturesEWiseAddAtLeastOneToCOO case = |> testPropertyWithConfig config (getCorrectnessTestName "byte") ] let elementwiseAddAtLeastOneToCOOTests = - matrixOperationGPUTests "Backend.Matrix.EWiseAddAtLeastOneToCOO tests" testFixturesEWiseAddAtLeastOneToCOO + operationGPUTests "Backend.Matrix.EWiseAddAtLeastOneToCOO tests" testFixturesEWiseAddAtLeastOneToCOO -let testFixturesEWiseMulAtLeastOne case = +let testFixturesEWiseMulAtLeastOne (case: OperationCase) = [ let config = defaultConfig let wgSize = 32 @@ -285,4 +285,4 @@ let testFixturesEWiseMulAtLeastOne case = |> testPropertyWithConfig config (getCorrectnessTestName "byte") ] let elementwiseMulAtLeastOneTests = - matrixOperationGPUTests "Backend.Matrix.eWiseMulAtLeastOne tests" testFixturesEWiseMulAtLeastOne + operationGPUTests "Backend.Matrix.eWiseMulAtLeastOne tests" testFixturesEWiseMulAtLeastOne diff --git a/tests/GraphBLAS-sharp.Tests/BackendCommonTests/ReduceTests.fs b/tests/GraphBLAS-sharp.Tests/BackendCommonTests/ReduceTests.fs new file mode 100644 index 00000000..4715fd75 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/BackendCommonTests/ReduceTests.fs @@ -0,0 +1,86 @@ +module Backend.Reduce + +open Expecto +open Expecto.Logging +open Expecto.Logging.Message +open Brahma.FSharp +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils + +let logger = Log.create "Reduce.Tests" + +let context = Context.defaultContext.ClContext + +let makeTest + (q: MailboxProcessor<_>) + (reduce: MailboxProcessor<_> -> ClArray<'a> -> ClCell<'a>) + plus + zero + (filter: 'a [] -> 'a []) + (array: 'a []) + = + + let array = filter array + + if array.Length > 0 then + let reduce = reduce q + + logger.debug ( + eventX "Filtered array is {array}\n" + >> setField "array" (sprintf "%A" array) + ) + + let actualSum = + use clArray = context.CreateClArray array + let total = reduce clArray + + let actualSum = [| zero |] + + let sum = + q.PostAndReply(fun ch -> Msg.CreateToHostMsg(total, actualSum, ch)) + + sum.[0] + + logger.debug ( + eventX "Actual is {actual}\n" + >> setField "actual" (sprintf "%A" actualSum) + ) + + let expectedSum = Array.fold plus zero array + + logger.debug ( + eventX "Expected is {expected}\n" + >> setField "expected" (sprintf "%A" expectedSum) + ) + + "Total sums should be equal" + |> Expect.equal actualSum expectedSum + + +let testFixtures config wgSize q plus plusQ zero filter name = + let reduce = Reduce.run context wgSize plusQ + + makeTest q reduce plus zero filter + |> testPropertyWithConfig config (sprintf "Correctness on %s" name) + +let tests = + let config = defaultConfig + + let wgSize = 32 + let q = Context.defaultContext.Queue + q.Error.Add(fun e -> failwithf "%A" e) + + let filterFloats = Array.filter System.Double.IsNormal + + [ testFixtures config wgSize q (+) <@ (+) @> 0 id "int add" + testFixtures config wgSize q (+) <@ (+) @> 0uy id "byte add" + testFixtures config wgSize q max <@ max @> System.Int32.MinValue id "int max" + testFixtures config wgSize q max <@ max @> System.Double.MinValue filterFloats "float max" + testFixtures config wgSize q max <@ max @> System.Byte.MinValue id "byte max" + testFixtures config wgSize q min <@ min @> System.Int32.MaxValue id "int min" + testFixtures config wgSize q min <@ min @> System.Double.MaxValue filterFloats "float min" + testFixtures config wgSize q min <@ min @> System.Byte.MaxValue id "byte min" + testFixtures config wgSize q (||) <@ (||) @> false id "bool logic-or" + testFixtures config wgSize q (&&) <@ (&&) @> true id "bool logic-and" ] + |> testList "Backend.Common.Reduce tests" diff --git a/tests/GraphBLAS-sharp.Tests/BackendCommonTests/SpMVTests.fs b/tests/GraphBLAS-sharp.Tests/BackendCommonTests/SpMVTests.fs index 25b7031e..22f1bf69 100644 --- a/tests/GraphBLAS-sharp.Tests/BackendCommonTests/SpMVTests.fs +++ b/tests/GraphBLAS-sharp.Tests/BackendCommonTests/SpMVTests.fs @@ -1,17 +1,16 @@ module Backend.SpMV -open Expecto -open Brahma.FSharp open GraphBLAS.FSharp.Backend open GraphBLAS.FSharp.Backend.ArraysExtensions +open Expecto +open Brahma.FSharp open GraphBLAS.FSharp open GraphBLAS.FSharp.Tests.Utils open GraphBLAS.FSharp.Tests.Context open GraphBLAS.FSharp.Tests.TestCases open Microsoft.FSharp.Collections open Microsoft.FSharp.Core -open OpenCL.Net -open Backend.Common.StandardOperations +open GraphBLAS.FSharp.Backend.Common.StandardOperations let checkResult isEqual sumOp mulOp zero (baseMtx: 'a [,]) (baseVtr: 'b []) (actual: 'c array) = let rows = Array2D.length1 baseMtx @@ -92,28 +91,26 @@ let testFixturesSpMV (testContext: TestContext) = let q = testContext.Queue q.Error.Add(fun e -> failwithf "%A" e) - let boolSpMV = - Vector.spMV context boolSum boolMul wgSize + let boolSpMV = SpMV.run context boolSum boolMul wgSize testContext |> correctnessGenericTest false (||) (&&) boolSpMV (=) q |> testPropertyWithConfig config (getCorrectnessTestName "bool") - let intSpMV = Vector.spMV context intSum intMul wgSize + let intSpMV = SpMV.run context intSum intMul wgSize testContext |> correctnessGenericTest 0 (+) (*) intSpMV (=) q |> testPropertyWithConfig config (getCorrectnessTestName "int") let floatSpMV = - Vector.spMV context floatSum floatMul wgSize + SpMV.run context floatSum floatMul wgSize testContext |> correctnessGenericTest 0.0 (+) (*) floatSpMV (fun x y -> abs (x - y) < Accuracy.medium.absolute) q |> testPropertyWithConfig config (getCorrectnessTestName "float") - let byteAdd = - Vector.spMV context byteSum byteMul wgSize + let byteAdd = SpMV.run context byteSum byteMul wgSize testContext |> correctnessGenericTest 0uy (+) (*) byteAdd (=) q diff --git a/tests/GraphBLAS-sharp.Tests/BackendCommonTests/TransposeTests.fs b/tests/GraphBLAS-sharp.Tests/BackendCommonTests/TransposeTests.fs index 1ad3f929..09e4b11f 100644 --- a/tests/GraphBLAS-sharp.Tests/BackendCommonTests/TransposeTests.fs +++ b/tests/GraphBLAS-sharp.Tests/BackendCommonTests/TransposeTests.fs @@ -73,7 +73,7 @@ let checkResult areEqual zero actual (expected2D: 'a [,]) = let makeTestRegular context q transposeFun areEqual zero case (array: 'a [,]) = let mtx = - createMatrixFromArray2D case.MatrixCase array (areEqual zero) + createMatrixFromArray2D case.Format array (areEqual zero) if mtx.NNZCount > 0 then let actual = @@ -100,7 +100,7 @@ let makeTestRegular context q transposeFun areEqual zero case (array: 'a [,]) = let makeTestTwiceTranspose context q transposeFun areEqual zero case (array: 'a [,]) = let mtx = - createMatrixFromArray2D case.MatrixCase array (areEqual zero) + createMatrixFromArray2D case.Format array (areEqual zero) if mtx.NNZCount > 0 then let actual = @@ -122,7 +122,7 @@ let makeTestTwiceTranspose context q transposeFun areEqual zero case (array: 'a let testFixtures case = let getCorrectnessTestName datatype = - sprintf "Correctness on %s, %A, %A" datatype case.MatrixCase case.ClContext + sprintf "Correctness on %s, %A, %A" datatype case.Format case.ClContext let areEqualFloat x y = System.Double.IsNaN x && System.Double.IsNaN y @@ -174,4 +174,4 @@ let testFixtures case = |> testPropertyWithConfig config (getCorrectnessTestName "bool (twice transpose)") ] let tests = - matrixOperationGPUTests "Transpose tests" testFixtures + operationGPUTests "Transpose tests" testFixtures diff --git a/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj b/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj index 6fe967ad..3e5dca50 100644 --- a/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj +++ b/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj @@ -1,34 +1,43 @@  - - Exe - net5.0 - false - - - - - - - - - - - - - - - - - - - - - - - - - - - + + Exe + net5.0 + false + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/GraphBLAS-sharp.Tests/Helpers.fs b/tests/GraphBLAS-sharp.Tests/Helpers.fs index 13a09a52..60cbf8f4 100644 --- a/tests/GraphBLAS-sharp.Tests/Helpers.fs +++ b/tests/GraphBLAS-sharp.Tests/Helpers.fs @@ -3,6 +3,7 @@ namespace GraphBLAS.FSharp.Tests open Brahma.FSharp.OpenCL.Shared open Brahma.FSharp.OpenCL.Translator open FsCheck +open GraphBLAS.FSharp.Backend open GraphBLAS.FSharp open Microsoft.FSharp.Reflection open Brahma.FSharp @@ -533,6 +534,57 @@ module Generators = <| Arb.generate |> Arb.fromGen + type PairOfVectorsOfEqualSize() = + static let pairOfVectorsOfEqualSize (valuesGenerator: Gen<'a>) = + gen { + let! length = Gen.sized <| fun size -> Gen.choose (1, size) + + let! leftArray = Gen.arrayOfLength length valuesGenerator + + let! rightArray = Gen.arrayOfLength length valuesGenerator + + return (leftArray, rightArray) + } + + static member IntType() = + pairOfVectorsOfEqualSize <| Arb.generate + |> Arb.fromGen + + static member FloatType() = + pairOfVectorsOfEqualSize + <| (Arb.Default.NormalFloat() + |> Arb.toGen + |> Gen.map float) + |> 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 + module Utils = let defaultConfig = @@ -547,7 +599,8 @@ module Utils = typeof typeof typeof - typeof ] } + typeof + typeof ] } let createMatrixFromArray2D matrixCase array isZero = match matrixCase with @@ -691,9 +744,9 @@ module Context = module TestCases = - type MatrixOperationCase = + type OperationCase<'a> = { ClContext: Context.TestContext - MatrixCase: MatrixFormat } + Format: 'a } let defaultPlatformRegex = "" @@ -702,22 +755,23 @@ module TestCases = |> contextFilter |> List.ofSeq - let matrixTestCases contextFilter = - [ Context.availableContexts defaultPlatformRegex - |> contextFilter - |> Seq.map box - Utils.listOfUnionCases - |> Seq.map box ] - |> List.map List.ofSeq - |> Utils.cartesian + let getTestCases<'a> contextFilter = + Context.availableContexts defaultPlatformRegex + |> contextFilter + |> List.ofSeq + |> List.collect + (fun x -> + Utils.listOfUnionCases<'a> + |> List.ofSeq + |> List.map (fun y -> x, y)) |> List.map - (fun list -> - { ClContext = unbox list.[0] - MatrixCase = unbox list.[1] }) + (fun pair -> + { ClContext = fst pair + Format = snd pair }) - let matrixOperationGPUTests name testFixtures = - matrixTestCases Context.gpuOnlyContextFilter - |> List.distinctBy (fun case -> case.ClContext.ClContext, case.MatrixCase) + let operationGPUTests name (testFixtures: OperationCase<'a> -> Test list) = + getTestCases<'a> Context.gpuOnlyContextFilter + |> List.distinctBy (fun case -> case.ClContext.ClContext, case.Format) |> List.collect testFixtures |> testList name diff --git a/tests/GraphBLAS-sharp.Tests/Program.fs b/tests/GraphBLAS-sharp.Tests/Program.fs index 6c735228..429360b5 100644 --- a/tests/GraphBLAS-sharp.Tests/Program.fs +++ b/tests/GraphBLAS-sharp.Tests/Program.fs @@ -28,7 +28,19 @@ let allTests = //Matrix.GetTuples.tests //Matrix.Mxv.tests //Algo.Bfs.tests - Backend.Sum.tests ] + Backend.Reduce.tests + Backend.Sum.tests + Backend.Vector.ZeroCreate.tests + Backend.Vector.OfList.tests + Backend.Vector.Copy.tests + Backend.Vector.Convert.tests + Backend.Vector.ElementWiseAtLeastOne.addTests + Backend.Vector.ElementWiseAtLeastOne.mulTests + Backend.Vector.ElementWise.addTests + Backend.Vector.ElementWise.mulTests + Backend.Vector.FillSubVector.tests + Backend.Vector.FillSubVector.complementedTests + Backend.Vector.Reduce.tests ] |> testSequenced [] diff --git a/tests/GraphBLAS-sharp.Tests/Vector/Convert.fs b/tests/GraphBLAS-sharp.Tests/Vector/Convert.fs new file mode 100644 index 00000000..3b2a678d --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Vector/Convert.fs @@ -0,0 +1,96 @@ +module Backend.Vector.Convert + +open Expecto +open Expecto.Logging +open Expecto.Logging.Message +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils +open GraphBLAS.FSharp.Backend +open TestCases + +let logger = + Log.create "Backend.Vector.Convert.Tests" + +let config = defaultConfig +let wgSize = 32 + +let NNZCount array isZero = + Array.filter (fun item -> not <| isZero item) array + |> Array.length + +let makeTest formatFrom (convertFun: MailboxProcessor<_> -> ClVector<'a> -> ClVector<'a>) isZero case (array: 'a []) = + if array.Length > 0 && NNZCount array isZero > 0 then + let context = case.ClContext.ClContext + let q = case.ClContext.Queue + + let vector = + createVectorFromArray formatFrom array isZero + + let actual = + let clVector = vector.ToDevice context + let convertedVector = convertFun q clVector + + let res = convertedVector.ToHost q + + clVector.Dispose q + convertedVector.Dispose q + + res + + logger.debug ( + eventX "Actual is {actual}" + >> setField "actual" (sprintf "%A" actual) + ) + + let expected = + createVectorFromArray case.Format array isZero + + Expect.equal actual expected "Vectors must be the same" + +let testFixtures case = + let getCorrectnessTestName datatype formatFrom = + sprintf "Correctness on %s, %A -> %A" datatype formatFrom case.Format + + let context = case.ClContext.ClContext + let q = case.ClContext.Queue + + q.Error.Add(fun e -> failwithf "%A" e) + + match case.Format with + | Sparse -> + [ let convertFun = Vector.toSparse context wgSize + + listOfUnionCases + |> List.map + (fun formatFrom -> + makeTest formatFrom convertFun ((=) 0) case + |> testPropertyWithConfig config (getCorrectnessTestName "int" formatFrom)) + + let convertFun = Vector.toSparse context wgSize + + listOfUnionCases + |> List.map + (fun formatFrom -> + makeTest formatFrom convertFun ((=) false) case + |> testPropertyWithConfig config (getCorrectnessTestName "bool" formatFrom)) ] + |> List.concat + | Dense -> + [ let convertFun = Vector.toDense context wgSize + + listOfUnionCases + |> List.map + (fun formatFrom -> + makeTest formatFrom convertFun ((=) 0) case + |> testPropertyWithConfig config (getCorrectnessTestName "int" formatFrom)) + + let convertFun = Vector.toDense context wgSize + + listOfUnionCases + |> List.map + (fun formatFrom -> + makeTest formatFrom convertFun ((=) false) case + |> testPropertyWithConfig config (getCorrectnessTestName "bool" formatFrom)) ] + |> List.concat + +let tests = + operationGPUTests "Backend.Vector.Convert tests" testFixtures diff --git a/tests/GraphBLAS-sharp.Tests/Vector/Copy.fs b/tests/GraphBLAS-sharp.Tests/Vector/Copy.fs new file mode 100644 index 00000000..a81f3958 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Vector/Copy.fs @@ -0,0 +1,99 @@ +module Backend.Vector.Copy + +open Expecto +open Expecto.Logging +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils +open TestCases + +let logger = Log.create "Vector.copy.Tests" + +let clContext = Context.defaultContext.ClContext + +let checkResult (isEqual: 'a -> 'a -> bool) (actual: Vector<'a>) (expected: Vector<'a>) = + + Expect.equal actual.Size expected.Size "The size should be the same" + + match actual, expected with + | VectorDense actual, VectorDense expected -> + let isEqual left right = + match left, right with + | Some left, Some right -> isEqual left right + | None, None -> true + | _, _ -> false + + compareArrays isEqual actual expected "The values array must contain the default value" + | VectorSparse actual, VectorSparse expected -> + compareArrays isEqual actual.Values expected.Values "The values array must contain the default value" + compareArrays (=) actual.Indices expected.Indices "The index array must contain the 0" + | _, _ -> failwith "Copy format must be the same" + +let correctnessGenericTest<'a when 'a: struct> + filter + isEqual + (isZero: 'a -> bool) + (copy: MailboxProcessor -> ClVector<'a> -> ClVector<'a>) + (case: OperationCase) + (array: 'a []) + = + if array.Length > 0 then + let array = filter array + + let q = case.ClContext.Queue + let context = case.ClContext.ClContext + + let expected = + createVectorFromArray case.Format array isZero + + let clVector = expected.ToDevice context + let clVectorCopy = copy q clVector + let actual = clVectorCopy.ToHost q + + clVector.Dispose q + clVectorCopy.Dispose q + + checkResult isEqual actual expected + +let testFixtures (case: OperationCase) = + let filterFloats = + Array.filter (System.Double.IsNaN >> not) + + let config = defaultConfig + + let getCorrectnessTestName datatype = + sprintf "Correctness on %s, %A" datatype case.Format + + let wgSize = 32 + let context = case.ClContext.ClContext + + [ let intCopy = Vector.copy context wgSize + let isZero item = item = 0 + + case + |> correctnessGenericTest id (=) isZero intCopy + |> testPropertyWithConfig config (getCorrectnessTestName "int") + + let floatCopy = Vector.copy context wgSize + let isZero item = item = 0.0 + + case + |> correctnessGenericTest filterFloats (=) isZero floatCopy + |> testPropertyWithConfig config (getCorrectnessTestName "float") + + let boolCopy = Vector.copy context wgSize + let isZero item = item = true + + case + |> correctnessGenericTest id (=) isZero boolCopy + |> testPropertyWithConfig config (getCorrectnessTestName "bool") + + let floatCopy = Vector.copy context wgSize + let isZero item = item = 0uy + + case + |> correctnessGenericTest id (=) isZero floatCopy + |> testPropertyWithConfig config (getCorrectnessTestName "byte") ] + +let tests = + operationGPUTests "Backend.Vector.copy tests" testFixtures diff --git a/tests/GraphBLAS-sharp.Tests/Vector/ElementWise.fs b/tests/GraphBLAS-sharp.Tests/Vector/ElementWise.fs new file mode 100644 index 00000000..ce8417c2 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Vector/ElementWise.fs @@ -0,0 +1,188 @@ +module Backend.Vector.ElementWise + +open Expecto +open Expecto.Logging +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils +open GraphBLAS.FSharp.Backend.Common +open StandardOperations +open TestCases + +let logger = Log.create "Vector.ElementWise.Tests" + +let config = defaultConfig + +let NNZCountCount array isZero = + Array.filter (fun item -> not <| isZero item) array + |> Array.length + +let checkResult isEqual resultZero (op: 'a -> 'b -> 'c) (actual: Vector<'c>) (leftArray: 'a []) (rightArray: 'b []) = + + let expectedArrayLength = leftArray.Length + + let expectedArray = + Array.create expectedArrayLength resultZero + + for i in 0 .. expectedArrayLength - 1 do + expectedArray.[i] <- op leftArray.[i] rightArray.[i] + + let (VectorDense expected) = + createVectorFromArray Dense expectedArray (isEqual resultZero) + + match actual with + | VectorDense actual -> + "arrays must have the same values" + |> Expect.equal actual expected + | _ -> failwith "Vector format must be Sparse." + +let correctnessGenericTest + leftIsEqual + rightIsEqual + resultIsEqual + leftZero + rightZero + resultZero + op + (addFun: MailboxProcessor<_> -> ClVector<'a> -> ClVector<'b> -> ClVector<'c>) + (toDense: MailboxProcessor<_> -> ClVector<'c> -> ClVector<'c>) + case + (leftArray: 'a [], rightArray: 'b []) + = + + let leftNNZCount = + NNZCountCount leftArray (leftIsEqual leftZero) + + let rightNNZCount = + NNZCountCount rightArray (rightIsEqual rightZero) + + if leftNNZCount > 0 && rightNNZCount > 0 then + + let context = case.ClContext.ClContext + let q = case.ClContext.Queue + + let firstVector = + createVectorFromArray case.Format leftArray (leftIsEqual leftZero) + + let secondVector = + createVectorFromArray case.Format rightArray (rightIsEqual rightZero) + + let v1 = firstVector.ToDevice context + let v2 = secondVector.ToDevice context + + try + let res = addFun q v1 v2 + + v1.Dispose q + v2.Dispose q + + let denseActual = toDense q res + + let actual = denseActual.ToHost q + + res.Dispose q + denseActual.Dispose q + + checkResult resultIsEqual resultZero op actual leftArray rightArray + with + | ex when ex.Message = "InvalidBufferSize" -> () + | ex -> raise ex + +let addTestFixtures case = + + let getCorrectnessTestName fstType sndType thrType = + $"Correctness on '{fstType} option -> '{sndType} option -> '{thrType} option, {case.Format}" + + let wgSize = 32 + + let context = case.ClContext.ClContext + + [ let intAddFun = Vector.elementWise context intSum wgSize + + let intToDense = Vector.toDense context wgSize + + case + |> correctnessGenericTest (=) (=) (=) 0 0 0 (+) intAddFun intToDense + |> testPropertyWithConfig config (getCorrectnessTestName "int" "int" "int") + + let floatAddFun = + Vector.elementWise context floatSum wgSize + + let fIsEqual = + fun x y -> abs (x - y) < Accuracy.medium.absolute || x = y + + let floatToDense = Vector.toDense context wgSize + + case + |> correctnessGenericTest fIsEqual fIsEqual fIsEqual 0.0 0.0 0.0 (+) floatAddFun floatToDense + |> testPropertyWithConfig config (getCorrectnessTestName "float" "float" "float") + + let boolAddFun = + Vector.elementWise context boolSum wgSize + + let boolToDense = Vector.toDense context wgSize + + case + |> correctnessGenericTest (=) (=) (=) false false false (||) boolAddFun boolToDense + |> testPropertyWithConfig config (getCorrectnessTestName "bool" "bool" "bool") + + let byteAddFun = + Vector.elementWise context byteSum wgSize + + let byteToDense = Vector.toDense context wgSize + + case + |> correctnessGenericTest (=) (=) (=) 0uy 0uy 0uy (+) byteAddFun byteToDense + |> testPropertyWithConfig config (getCorrectnessTestName "byte" "byte" "byte") ] + +let addTests = + operationGPUTests "Backend.Vector.ElementWiseAdd tests" addTestFixtures + +let mulTestFixtures case = + let getCorrectnessTestName fstType sndType thrType = + $"Correctness on '{fstType} option -> '{sndType} option -> '{thrType} option, {case.Format}" + + let wgSize = 32 + + let context = case.ClContext.ClContext + + [ let intMulFun = Vector.elementWise context intMul wgSize + + let intToDense = Vector.toDense context wgSize + + case + |> correctnessGenericTest (=) (=) (=) 0 0 0 (*) intMulFun intToDense + |> testPropertyWithConfig config (getCorrectnessTestName "int" "int" "int") + + let floatMulFun = + Vector.elementWise context floatMul wgSize + + let fIsEqual = + fun x y -> abs (x - y) < Accuracy.medium.absolute || x = y + + let floatToDense = Vector.toDense context wgSize + + case + |> correctnessGenericTest fIsEqual fIsEqual fIsEqual 0.0 0.0 0.0 (*) floatMulFun floatToDense + |> testPropertyWithConfig config (getCorrectnessTestName "float" "float" "float") + + let boolMulFun = + Vector.elementWise context boolMul wgSize + + let boolToDense = Vector.toDense context wgSize + + case + |> correctnessGenericTest (=) (=) (=) false false false (&&) boolMulFun boolToDense + |> testPropertyWithConfig config (getCorrectnessTestName "bool" "bool" "bool") + + let byteMulFun = + Vector.elementWise context byteMul wgSize + + let byteToDense = Vector.toDense context wgSize + + case + |> correctnessGenericTest (=) (=) (=) 0uy 0uy 0uy (*) byteMulFun byteToDense + |> testPropertyWithConfig config (getCorrectnessTestName "byte" "byte" "byte") ] + +let mulTests = + operationGPUTests "Backend.Vector.ElementWiseMul tests" addTestFixtures diff --git a/tests/GraphBLAS-sharp.Tests/Vector/ElementWiseAtLeasOne.fs b/tests/GraphBLAS-sharp.Tests/Vector/ElementWiseAtLeasOne.fs new file mode 100644 index 00000000..9df1992b --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Vector/ElementWiseAtLeasOne.fs @@ -0,0 +1,203 @@ +module Backend.Vector.ElementWiseAtLeastOne + +open Expecto +open Expecto.Logging +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils +open GraphBLAS.FSharp.Backend.Common +open StandardOperations +open TestCases + +let logger = + Log.create "Vector.ElementWiseAtLeasOneMul.Tests" + +let NNZCountCount array isZero = + Array.filter (fun item -> not <| isZero item) array + |> Array.length + +let checkResult + (isEqual: 'c -> 'c -> bool) + resultZero + (op: 'a -> 'b -> 'c) + (actual: Vector<'c>) + (leftArray: 'a []) + (rightArray: 'b []) + = + + let expectedArrayLength = leftArray.Length + + let expectedArray = + Array.create expectedArrayLength resultZero + + for i in 0 .. expectedArrayLength - 1 do + expectedArray.[i] <- op leftArray.[i] rightArray.[i] + + match actual with + | VectorSparse actual -> + let actualArray = + Array.create expectedArrayLength resultZero + + for i in 0 .. actual.Indices.Length - 1 do + if isEqual actual.Values.[i] resultZero then + failwith "Resulting zeroes should be filtered." + + actualArray.[actual.Indices.[i]] <- actual.Values.[i] + + $"arrays must have the same values actual = %A{actualArray}, expected = %A{expectedArray}" + |> compareArrays isEqual actualArray expectedArray + | _ -> failwith "Vector format must be Sparse." + +let correctnessGenericTest + leftIsEqual + rightIsEqual + resultIsEqual + leftZero + rightZero + resultZero + op + (addFun: MailboxProcessor<_> -> ClVector<'a> -> ClVector<'b> -> ClVector<'c>) + (toCoo: MailboxProcessor<_> -> ClVector<'c> -> ClVector<'c>) + case + (leftArray: 'a [], rightArray: 'b []) + = + + let leftNNZCount = + NNZCountCount leftArray (leftIsEqual leftZero) + + let rightNNZCount = + NNZCountCount rightArray (rightIsEqual rightZero) + + if leftNNZCount > 0 && rightNNZCount > 0 then + + let q = case.ClContext.Queue + let context = case.ClContext.ClContext + + let firstVector = + createVectorFromArray case.Format leftArray (leftIsEqual leftZero) + + let secondVector = + createVectorFromArray case.Format rightArray (rightIsEqual rightZero) + + let v1 = firstVector.ToDevice context + let v2 = secondVector.ToDevice context + + try + let res = addFun q v1 v2 + + v1.Dispose q + v2.Dispose q + + let cooRes = toCoo q res + res.Dispose q + + let actual = cooRes.ToHost q + + checkResult resultIsEqual resultZero op actual leftArray rightArray + with + | ex when ex.Message = "InvalidBufferSize" -> () + | ex -> raise ex + +let addTestFixtures case = + let config = defaultConfig + + let getCorrectnessTestName fstType sndType thrType = + $"Correctness on AtLeastOne<{fstType}, {sndType}> -> {thrType} option, {case.Format}" + + let wgSize = 32 + let context = case.ClContext.ClContext + + [ let toCoo = Vector.toSparse context wgSize + + let intAddFun = + Vector.elementWiseAtLeastOne context intSumAtLeastOne wgSize + + case + |> correctnessGenericTest (=) (=) (=) 0 0 0 (+) intAddFun toCoo + |> testPropertyWithConfig config (getCorrectnessTestName "int" "int" "int") + + let floatToCoo = Vector.toSparse context wgSize + + let floatAddFun = + Vector.elementWiseAtLeastOne context floatSumAtLeastOne wgSize + + let fIsEqual = + fun x y -> abs (x - y) < Accuracy.medium.absolute || x = y + + case + |> correctnessGenericTest fIsEqual fIsEqual fIsEqual 0.0 0.0 0.0 (+) floatAddFun floatToCoo + |> testPropertyWithConfig config (getCorrectnessTestName "float" "float" "float") + + let boolToCoo = Vector.toSparse context wgSize + + let boolAddFun = + Vector.elementWiseAtLeastOne context boolSumAtLeastOne wgSize + + case + |> correctnessGenericTest (=) (=) (=) false false false (||) boolAddFun boolToCoo + |> testPropertyWithConfig config (getCorrectnessTestName "bool" "bool" "bool") + + let byteToCoo = Vector.toSparse context wgSize + + let byteAddFun = + Vector.elementWiseAtLeastOne context byteSumAtLeastOne wgSize + + case + |> correctnessGenericTest (=) (=) (=) 0uy 0uy 0uy (+) byteAddFun byteToCoo + |> testPropertyWithConfig config (getCorrectnessTestName "byte" "byte" "byte") ] + +let addTests = + operationGPUTests "Backend.Vector.ElementWiseAtLeasOneAdd tests" addTestFixtures + +let mulTestFixtures case = + let config = defaultConfig + + let getCorrectnessTestName fstType sndType thrType = + $"Correctness on AtLeastOne<{fstType}, {sndType}> -> {thrType} option, {case.Format}" + + let wgSize = 32 + let context = case.ClContext.ClContext + + + [ let toCoo = Vector.toSparse context wgSize + + let intMulFun = + Vector.elementWiseAtLeastOne context intMulAtLeastOne wgSize + + case + |> correctnessGenericTest (=) (=) (=) 0 0 0 (*) intMulFun toCoo + |> testPropertyWithConfig config (getCorrectnessTestName "int" "int" "int") + + let floatToCoo = Vector.toSparse context wgSize + + let floatMulFun = + Vector.elementWiseAtLeastOne context floatMulAtLeastOne wgSize + + let fIsEqual = + fun x y -> abs (x - y) < Accuracy.medium.absolute || x = y + + case + |> correctnessGenericTest fIsEqual fIsEqual fIsEqual 0.0 0.0 0.0 (*) floatMulFun floatToCoo + |> testPropertyWithConfig config (getCorrectnessTestName "float" "float" "float") + + let boolToCoo = Vector.toSparse context wgSize + + let boolMulFun = + Vector.elementWiseAtLeastOne context boolMulAtLeastOne wgSize + + case + |> correctnessGenericTest (=) (=) (=) false false false (&&) boolMulFun boolToCoo + |> testPropertyWithConfig config (getCorrectnessTestName "bool" "bool" "bool") + + let byteToCoo = Vector.toSparse context wgSize + + let byteMulFun = + Vector.elementWiseAtLeastOne context byteMulAtLeastOne wgSize + + case + |> correctnessGenericTest (=) (=) (=) 0uy 0uy 0uy (*) byteMulFun byteToCoo + |> testPropertyWithConfig config (getCorrectnessTestName "byte" "byte" "byte") ] + +let mulTests = + operationGPUTests "Backend.Vector.ElementWiseAtLeasOneMul tests" mulTestFixtures + diff --git a/tests/GraphBLAS-sharp.Tests/Vector/FillSubVector.fs b/tests/GraphBLAS-sharp.Tests/Vector/FillSubVector.fs new file mode 100644 index 00000000..e28d892e --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Vector/FillSubVector.fs @@ -0,0 +1,216 @@ +module Backend.Vector.FillSubVector + +open Expecto +open Expecto.Logging +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Backend.Common +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils +open Brahma.FSharp +open TestCases + +let logger = Log.create "Vector.fillSubVector.Tests" + +let clContext = Context.defaultContext.ClContext + +let NNZCount array isZero = + Array.filter (fun item -> not <| isZero item) array + |> Array.length + +let complemented isComplemented value = + if isComplemented then + not value + else + value + +let checkResult + (resultIsEqual: 'a -> 'a -> bool) + (maskIsEqual: 'b -> 'b -> bool) + vectorZero + maskZero + isComplemented + (actual: Vector<'a>) + (vector: 'a []) + (mask: 'b []) + (value: 'a) + = + + let expectedArray = Array.create vector.Length vectorZero + + let complemented = complemented isComplemented + + for i in 0 .. vector.Length - 1 do + if complemented (not <| maskIsEqual mask.[i] maskZero) then + expectedArray.[i] <- value + else + expectedArray.[i] <- vector.[i] + + match actual with + | VectorSparse actual -> + let actualArray = Array.create vector.Length vectorZero + + for i in 0 .. actual.Indices.Length - 1 do + actualArray.[actual.Indices.[i]] <- actual.Values.[i] + + "arrays must have the same values and length" + |> compareArrays resultIsEqual actualArray expectedArray + | _ -> failwith "Vector format must be Sparse." + +let makeTest<'a, 'b when 'a: struct and 'b: struct> + vectorIsEqual + maskIsEqual + vectorZero + maskZero + (toCoo: MailboxProcessor<_> -> ClVector<'a> -> ClVector<'a>) + (fillVector: MailboxProcessor -> ClVector<'a> -> ClVector<'b> -> ClCell<'a> -> ClVector<'a>) + (isValueValid: 'a -> bool) + isComplemented + case + (vector: 'a [], mask: 'b []) + (value: 'a) + = + + let vectorNNZ = + NNZCount vector (vectorIsEqual vectorZero) + + let maskNNZ = NNZCount mask (maskIsEqual maskZero) + + if vectorNNZ > 0 && maskNNZ > 0 && isValueValid value then + let q = case.ClContext.Queue + let context = case.ClContext.ClContext + + let leftVector = + createVectorFromArray case.Format vector (vectorIsEqual vectorZero) + + let maskVector = + createVectorFromArray case.Format mask (maskIsEqual maskZero) + + let clLeftVector = leftVector.ToDevice context + + let clMaskVector = maskVector.ToDevice context + + try + let clValue = context.CreateClCell<'a> value + + let clActual = + fillVector q clLeftVector clMaskVector clValue + + let cooClActual = toCoo q clActual + + let actual = cooClActual.ToHost q + + clLeftVector.Dispose q + clMaskVector.Dispose q + clActual.Dispose q + cooClActual.Dispose q + + checkResult vectorIsEqual maskIsEqual vectorZero maskZero isComplemented actual vector mask value + with + | ex when ex.Message = "InvalidBufferSize" -> () + | ex -> raise ex + +let testFixtures case = + let config = defaultConfig + + let getCorrectnessTestName datatype = + $"Correctness on %s{datatype}, vector: %A{case.Format}" + + let wgSize = 32 + let context = case.ClContext.ClContext + + let floatIsEqual x y = + abs (x - y) < Accuracy.medium.absolute || x = y + + let isComplemented = false + + [ let intFill = + Vector.standardFillSubVector context wgSize + + let intToCoo = Vector.toSparse context wgSize + + case + |> makeTest (=) (=) 0 0 intToCoo intFill (fun _ -> true) isComplemented + |> testPropertyWithConfig config (getCorrectnessTestName "int") + + let floatFill = + Vector.standardFillSubVector context wgSize + + let floatToCoo = Vector.toSparse context wgSize + + case + |> makeTest floatIsEqual floatIsEqual 0.0 0.0 floatToCoo floatFill System.Double.IsNormal isComplemented + |> testPropertyWithConfig config (getCorrectnessTestName "float") + + let byteFill = + Vector.standardFillSubVector context wgSize + + let byteToCoo = Vector.toSparse context wgSize + + case + |> makeTest (=) (=) 0uy 0uy byteToCoo byteFill (fun _ -> true) isComplemented + |> testPropertyWithConfig config (getCorrectnessTestName "byte") + + let boolFill = + Vector.standardFillSubVector context wgSize + + let boolToCoo = Vector.toSparse context wgSize + + case + |> makeTest (=) (=) false false boolToCoo boolFill (fun _ -> true) isComplemented + |> testPropertyWithConfig config (getCorrectnessTestName "bool") ] + +let tests = + operationGPUTests "Backend.Vector.fillSubVector tests" testFixtures + +let testFixturesComplemented case = + let config = defaultConfig + + let getCorrectnessTestName datatype = + $"Correctness on %s{datatype}, vector: %A{case.Format}" + + let wgSize = 32 + let context = case.ClContext.ClContext + + let floatIsEqual x y = + abs (x - y) < Accuracy.medium.absolute || x = y + + let isComplemented = true + + [ let intFill = + Vector.standardFillSubVectorComplemented context wgSize + + let intToCoo = Vector.toSparse context wgSize + + case + |> makeTest (=) (=) 0 0 intToCoo intFill (fun _ -> true) isComplemented + |> testPropertyWithConfig config (getCorrectnessTestName "int") + + let floatFill = + Vector.standardFillSubVectorComplemented context wgSize + + let floatToCoo = Vector.toSparse context wgSize + + case + |> makeTest floatIsEqual floatIsEqual 0.0 0.0 floatToCoo floatFill System.Double.IsNormal isComplemented + |> testPropertyWithConfig config (getCorrectnessTestName "float") + + let byteFill = + Vector.standardFillSubVectorComplemented context wgSize + + let byteToCoo = Vector.toSparse context wgSize + + case + |> makeTest (=) (=) 0uy 0uy byteToCoo byteFill (fun _ -> true) isComplemented + |> testPropertyWithConfig config (getCorrectnessTestName "byte") + + let boolFill = + Vector.standardFillSubVectorComplemented context wgSize + + let boolToCoo = Vector.toSparse context wgSize + + case + |> makeTest (=) (=) false false boolToCoo boolFill (fun _ -> true) isComplemented + |> testPropertyWithConfig config (getCorrectnessTestName "bool") ] + +let complementedTests = + operationGPUTests "Backend.Vector.fillSubVectorComplemented tests" testFixturesComplemented diff --git a/tests/GraphBLAS-sharp.Tests/Vector/OfList.fs b/tests/GraphBLAS-sharp.Tests/Vector/OfList.fs new file mode 100644 index 00000000..45f1c15f --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Vector/OfList.fs @@ -0,0 +1,110 @@ +module Backend.Vector.OfList + +open Expecto +open Expecto.Logging +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils +open GraphBLAS.FSharp.Backend +open Context +open TestCases +let logger = Log.create "Vector.ofList.Tests" + +let checkResult + (isEqual: 'a -> 'a -> bool) + (expectedIndices: int []) + (expectedValues: 'a []) + (actual: Vector<'a>) + actualSize + = + + Expect.equal actual.Size actualSize "lengths must be the same" + + match actual with + | VectorSparse actual -> + compareArrays (=) actual.Indices expectedIndices "indices must be the same" + compareArrays isEqual actual.Values expectedValues "values must be the same" + | _ -> failwith "Vector format must be Sparse." + +let correctnessGenericTest<'a when 'a: struct> + (isEqual: 'a -> 'a -> bool) + (ofList: VectorFormat -> int -> (int * 'a) list -> ClVector<'a>) + (toCoo: MailboxProcessor<_> -> ClVector<'a> -> ClVector<'a>) + (case: OperationCase) + (elements: (int * 'a) []) + (sizeDelta: int) + = + + let elements = + elements |> Array.distinctBy fst |> List.ofArray + + if elements.Length > 0 then + + let q = case.ClContext.Queue + + let indices, values = + elements + |> Array.ofList + |> Array.sortBy fst + |> Array.unzip + + let actualSize = (Array.max indices) + abs sizeDelta + 1 + + let clActual = ofList case.Format actualSize elements + + let clCooActual = toCoo q clActual + + let actual = clCooActual.ToHost q + + clActual.Dispose q + clCooActual.Dispose q + + checkResult isEqual indices values actual actualSize + +let testFixtures (case: OperationCase) = + [ let config = defaultConfig + + let wgSize = 32 + + let context = case.ClContext.ClContext + let q = case.ClContext.Queue + + q.Error.Add(fun e -> failwithf $"%A{e}") + + let getCorrectnessTestName datatype = + sprintf "Correctness on %s, %A" datatype case.Format + + let boolOfList = Vector.ofList context + + let toCoo = Vector.toSparse context wgSize + + case + |> correctnessGenericTest (=) boolOfList toCoo + |> testPropertyWithConfig config (getCorrectnessTestName "bool") + + let intOfList = Vector.ofList context + + let toCoo = Vector.toSparse context wgSize + + case + |> correctnessGenericTest (=) intOfList toCoo + |> testPropertyWithConfig config (getCorrectnessTestName "int") + + + let byteOfList = Vector.ofList context + + let toCoo = Vector.toSparse context wgSize + + case + |> correctnessGenericTest (=) byteOfList toCoo + |> testPropertyWithConfig config (getCorrectnessTestName "byte") + + let floatOfList = Vector.ofList context + + let toCoo = Vector.toSparse context wgSize + + case + |> correctnessGenericTest (=) floatOfList toCoo + |> testPropertyWithConfig config (getCorrectnessTestName "float") ] + +let tests = + operationGPUTests "Backend.Vector.ofList tests" testFixtures diff --git a/tests/GraphBLAS-sharp.Tests/Vector/Reduce.fs b/tests/GraphBLAS-sharp.Tests/Vector/Reduce.fs new file mode 100644 index 00000000..eafd6d5d --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Vector/Reduce.fs @@ -0,0 +1,138 @@ +module Backend.Vector.Reduce + +open Expecto +open Expecto.Logging +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils +open Brahma.FSharp +open FSharp.Quotations +open TestCases + +let logger = Log.create "Vector.reduce.Tests" + +let zeroFilter array isZero = + Array.filter + <| (fun item -> not <| isZero item) + <| array + +let checkResult zero op (actual: 'a) (vector: 'a []) = + let expected = Array.fold op zero vector + + "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>) + filter + case + (array: 'a []) + = + + let array = filter array + + let arrayWithoutZeros = zeroFilter array (isEqual zero) + + if arrayWithoutZeros.Length > 0 then + let q = case.ClContext.Queue + let context = case.ClContext.ClContext + + let vector = + createVectorFromArray case.Format array (isEqual zero) + + 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] + + checkResult zero op result array + +let testFixtures (case: OperationCase) = + let config = defaultConfig + + let getCorrectnessTestName dataType = + $"Correctness on %A{dataType}, %A{case.Format}" + + let wgSize = 32 + let context = case.ClContext.ClContext + let q = case.ClContext.Queue + + q.Error.Add(fun e -> failwithf "%A" e) + + let filterFloats = Array.filter System.Double.IsNormal + + [ let intReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) 0 (+) <@ (+) @> intReduce id + |> testPropertyWithConfig config (getCorrectnessTestName "int") + + let byteReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) 0uy (+) <@ (+) @> byteReduce id + |> testPropertyWithConfig config (getCorrectnessTestName "byte") + + let intMaxReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) System.Int32.MinValue max <@ max @> intMaxReduce id + |> testPropertyWithConfig config (getCorrectnessTestName "int max") + + let floatMaxReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) System.Double.MinValue max <@ max @> floatMaxReduce filterFloats + |> testPropertyWithConfig config (getCorrectnessTestName "float max") + + let byteMaxReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) System.Byte.MinValue max <@ max @> byteMaxReduce id + |> testPropertyWithConfig config (getCorrectnessTestName "byte max") + + let intMinReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) System.Int32.MaxValue min <@ min @> intMinReduce id + |> testPropertyWithConfig config (getCorrectnessTestName "int min") + + let floatMinReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) System.Double.MaxValue min <@ min @> floatMinReduce filterFloats + |> testPropertyWithConfig config (getCorrectnessTestName "float min") + + let byteMinReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) System.Byte.MaxValue min <@ min @> byteMinReduce id + |> testPropertyWithConfig config (getCorrectnessTestName "byte min") + + let boolOrReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) false (||) <@ (||) @> boolOrReduce id + |> testPropertyWithConfig config (getCorrectnessTestName "bool or") + + let boolAndReduce = Vector.reduce context wgSize + + case + |> correctnessGenericTest (=) true (&&) <@ (&&) @> boolAndReduce id + |> testPropertyWithConfig config (getCorrectnessTestName "bool and") ] + +let tests = + operationGPUTests "Backend.Vector.reduce tests" testFixtures diff --git a/tests/GraphBLAS-sharp.Tests/Vector/ZeroCreate.fs b/tests/GraphBLAS-sharp.Tests/Vector/ZeroCreate.fs new file mode 100644 index 00000000..2e2551e4 --- /dev/null +++ b/tests/GraphBLAS-sharp.Tests/Vector/ZeroCreate.fs @@ -0,0 +1,81 @@ +module Backend.Vector.ZeroCreate + +open Expecto +open Expecto.Logging +open GraphBLAS.FSharp.Backend +open GraphBLAS.FSharp.Tests +open GraphBLAS.FSharp.Tests.Utils +open Context +open TestCases + +let logger = Log.create "Vector.zeroCreate.Tests" + +let checkResult size (actual: Vector<'a>) = + Expect.equal actual.Size size "The size should be the same" + + match actual with + | VectorDense vector -> + Array.iter + <| (fun item -> Expect.equal item None "values must be None") + <| vector + | VectorSparse vector -> + Expect.equal vector.Values [| Unchecked.defaultof<'a> |] "The values array must contain the default value" + Expect.equal vector.Indices [| 0 |] "The index array must contain the 0" + +let correctnessGenericTest<'a when 'a: struct and 'a: equality> + (zeroCreate: MailboxProcessor<_> -> int -> VectorFormat -> ClVector<'a>) + (case: OperationCase) + (vectorSize: int) + = + + if vectorSize > 0 then + let q = case.ClContext.Queue + + let (clVector: ClVector<'a>) = zeroCreate q vectorSize case.Format + + let hostVector = clVector.ToHost q + + clVector.Dispose q + + checkResult vectorSize hostVector + +let testFixtures (case: OperationCase) = + let config = defaultConfig + + let getCorrectnessTestName dataType = + $"Correctness on %A{dataType}, %A{case.Format}" + + let wgSize = 32 + let context = case.ClContext.ClContext + + let q = case.ClContext.Queue + + q.Error.Add(fun e -> failwithf "%A" e) + + [ let intZeroCreate = Vector.zeroCreate context wgSize + + case + |> correctnessGenericTest intZeroCreate + |> testPropertyWithConfig config (getCorrectnessTestName "int") + + let byteZeroCreat = Vector.zeroCreate context wgSize + + case + |> correctnessGenericTest byteZeroCreat + |> testPropertyWithConfig config (getCorrectnessTestName "byte") + + + let floatZeroCreate = Vector.zeroCreate context wgSize + + case + |> correctnessGenericTest floatZeroCreate + |> testPropertyWithConfig config (getCorrectnessTestName "float") + + let boolZeroCreate = Vector.zeroCreate context wgSize + + case + |> correctnessGenericTest boolZeroCreate + |> testPropertyWithConfig config (getCorrectnessTestName "bool") ] + +let tests = + operationGPUTests "Backend.Vector.zeroCreate tests" testFixtures