diff --git a/src/GraphBLAS-sharp.Backend/Common/ClArray.fs b/src/GraphBLAS-sharp.Backend/Common/ClArray.fs index 33a378a3..d048c650 100644 --- a/src/GraphBLAS-sharp.Backend/Common/ClArray.fs +++ b/src/GraphBLAS-sharp.Backend/Common/ClArray.fs @@ -160,6 +160,38 @@ module ClArray = result + let mapWithValue<'a, 'b, 'c> (clContext: ClContext) workGroupSize (op: Expr<'a -> 'b -> 'c>) = + + let map = + <@ fun (ndRange: Range1D) lenght (value: ClCell<'a>) (inputArray: ClArray<'b>) (result: ClArray<'c>) -> + + let gid = ndRange.GlobalID0 + + if gid < lenght then + result.[gid] <- (%op) value.Value inputArray.[gid] @> + + let kernel = clContext.Compile map + + fun (processor: MailboxProcessor<_>) allocationMode (value: 'a) (inputArray: ClArray<'b>) -> + + let result = + clContext.CreateClArrayWithSpecificAllocationMode(allocationMode, inputArray.Length) + + let valueClCell = value |> clContext.CreateClCell + + let ndRange = + Range1D.CreateValid(inputArray.Length, workGroupSize) + + let kernel = kernel.GetKernel() + + processor.Post( + Msg.MsgSetArguments(fun () -> kernel.KernelFunc ndRange inputArray.Length valueClCell inputArray result) + ) + + processor.Post(Msg.CreateRunMsg<_, _>(kernel)) + + result + let map2InPlace<'a, 'b, 'c> (map: Expr<'a -> 'b -> 'c>) (clContext: ClContext) workGroupSize = let kernel = diff --git a/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj b/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj index 82e534fc..4709660f 100644 --- a/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj +++ b/src/GraphBLAS-sharp.Backend/GraphBLAS-sharp.Backend.fsproj @@ -43,6 +43,7 @@ + @@ -54,6 +55,7 @@ + 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 index 0ca4148f..a6c2b077 100644 --- a/src/GraphBLAS-sharp.Backend/Matrix/CSR/Map.fs +++ b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Map.fs @@ -5,10 +5,11 @@ open FSharp.Quotations open GraphBLAS.FSharp.Backend open GraphBLAS.FSharp.Backend.Quotes open GraphBLAS.FSharp.Backend.Matrix -open GraphBLAS.FSharp.Backend.Matrix.COO 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 = @@ -101,10 +102,10 @@ module internal Map = 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)) + bitmap.Free queue + values.Free queue + rows.Free queue + columns.Free queue { Context = clContext RowCount = matrix.RowCount @@ -112,3 +113,112 @@ module internal Map = 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/Matrix.fs b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Matrix.fs index 3078bdbb..22171912 100644 --- a/src/GraphBLAS-sharp.Backend/Matrix/CSR/Matrix.fs +++ b/src/GraphBLAS-sharp.Backend/Matrix/CSR/Matrix.fs @@ -53,6 +53,45 @@ module Matrix = 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 = @@ -295,3 +334,5 @@ module Matrix = pointerPairs.Free processor rowsLength + + let kronecker = Kronecker.run diff --git a/src/GraphBLAS-sharp.Backend/Matrix/Common.fs b/src/GraphBLAS-sharp.Backend/Matrix/Common.fs index 2f59ad03..5588b203 100644 --- a/src/GraphBLAS-sharp.Backend/Matrix/Common.fs +++ b/src/GraphBLAS-sharp.Backend/Matrix/Common.fs @@ -4,8 +4,6 @@ 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 -open GraphBLAS.FSharp.Backend.Quotes module internal Common = ///. @@ -42,3 +40,41 @@ module internal 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/Matrix.fs b/src/GraphBLAS-sharp.Backend/Matrix/Matrix.fs index 4c23531e..cd754379 100644 --- a/src/GraphBLAS-sharp.Backend/Matrix/Matrix.fs +++ b/src/GraphBLAS-sharp.Backend/Matrix/Matrix.fs @@ -390,6 +390,17 @@ module Matrix = |> ClMatrix.CSR | ClMatrix.LIL _ -> failwith "Not yet implemented" + let kronecker (op: Expr<'a option -> 'b option -> 'c option>) (clContext: ClContext) workGroupSize = + let run = + CSR.Matrix.kronecker clContext workGroupSize op + + 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>) diff --git a/src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs b/src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs index 737f196e..f7d51a89 100644 --- a/src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs +++ b/src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs @@ -56,6 +56,34 @@ module ArithmeticOperations = if res = zero then None else Some res @> + 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 @@ -73,7 +101,6 @@ module ArithmeticOperations = mkUnaryOp zero <@ fun x -> x + constant @> let intSumOption = mkNumericSum 0 - let byteSumOption = mkNumericSum 0uy let floatSumOption = mkNumericSum 0.0 let float32SumOption = mkNumericSum 0f @@ -85,6 +112,32 @@ module ArithmeticOperations = let floatSumAtLeastOne = mkNumericSumAtLeastOne 0.0 let float32SumAtLeastOne = mkNumericSumAtLeastOne 0f + 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 @@ -102,7 +155,6 @@ module ArithmeticOperations = mkUnaryOp zero <@ fun x -> x * constant @> let intMulOption = mkNumericMul 0 - let byteMulOption = mkNumericMul 0uy let floatMulOption = mkNumericMul 0.0 let float32MulOption = mkNumericMul 0f diff --git a/src/GraphBLAS-sharp.Backend/Vector/Sparse/Common.fs b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Common.fs index 93b809c1..cb6a8971 100644 --- a/src/GraphBLAS-sharp.Backend/Vector/Sparse/Common.fs +++ b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Common.fs @@ -2,6 +2,7 @@ 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 @@ -34,3 +35,66 @@ module internal Common = 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/Vector.fs b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Vector.fs index deaab095..5b3594ae 100644 --- a/src/GraphBLAS-sharp.Backend/Vector/Sparse/Vector.fs +++ b/src/GraphBLAS-sharp.Backend/Vector/Sparse/Vector.fs @@ -1,12 +1,13 @@ 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.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 = @@ -20,6 +21,8 @@ module Vector = 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 = 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/GraphBLAS-sharp.Tests.fsproj b/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj index c3f81416..75a4f492 100644 --- a/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj +++ b/tests/GraphBLAS-sharp.Tests/GraphBLAS-sharp.Tests.fsproj @@ -53,6 +53,7 @@ + diff --git a/tests/GraphBLAS-sharp.Tests/Helpers.fs b/tests/GraphBLAS-sharp.Tests/Helpers.fs index e0e55b97..1811c40b 100644 --- a/tests/GraphBLAS-sharp.Tests/Helpers.fs +++ b/tests/GraphBLAS-sharp.Tests/Helpers.fs @@ -324,6 +324,21 @@ module HostPrimitives = |> 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/Program.fs b/tests/GraphBLAS-sharp.Tests/Program.fs index f6359ee4..9049b03e 100644 --- a/tests/GraphBLAS-sharp.Tests/Program.fs +++ b/tests/GraphBLAS-sharp.Tests/Program.fs @@ -14,6 +14,7 @@ let matrixTests = Matrix.ByRows.tests Matrix.ExpandRows.tests Matrix.SubRows.tests + Matrix.Kronecker.tests Matrix.SpGeMM.Expand.generalTests Matrix.SpGeMM.Masked.tests ]