@@ -71,3 +71,170 @@ module BFS =
7171
7272 levels
7373 | _ -> failwith " Not implemented"
74+
75+ let singleSourceSparse
76+ ( add : Expr < bool option -> bool option -> bool option >)
77+ ( mul : Expr < bool option -> bool option -> bool option >)
78+ ( clContext : ClContext )
79+ workGroupSize
80+ =
81+
82+ let spMSpV =
83+ SpMSpV.run add mul clContext workGroupSize
84+
85+ let zeroCreate =
86+ ClArray.zeroCreate clContext workGroupSize
87+
88+ let ofList = Vector.ofList clContext workGroupSize
89+
90+ let maskComplemented =
91+ Vector.Sparse.Vector.map2SparseDense Mask.complementedOp clContext workGroupSize
92+
93+ let fillSubVectorTo =
94+ Vector.assignBySparseMaskInPlace ( Convert.assignToOption Mask.assign) clContext workGroupSize
95+
96+ fun ( queue : MailboxProcessor < Msg >) ( matrix : ClMatrix.CSR < bool >) ( source : int ) ->
97+ let vertexCount = matrix.RowCount
98+
99+ let levels = zeroCreate queue HostInterop vertexCount
100+
101+ let mutable frontier =
102+ ofList queue DeviceOnly Sparse vertexCount [ source, true ]
103+
104+ let mutable level = 0
105+ let mutable stop = false
106+
107+ while not stop do
108+ match frontier with
109+ | ClVector.Sparse front ->
110+ level <- level + 1
111+
112+ //Assigning new level values
113+ fillSubVectorTo queue levels front ( clContext.CreateClCell level) levels
114+
115+ //Getting new frontier
116+ match spMSpV queue matrix front with
117+ | None ->
118+ frontier.Dispose queue
119+ stop <- true
120+ | Some newFrontier ->
121+ frontier.Dispose queue
122+ //Filtering visited vertices
123+ match maskComplemented queue DeviceOnly newFrontier levels with
124+ | None ->
125+ stop <- true
126+ newFrontier.Dispose queue
127+ | Some f ->
128+ frontier <- ClVector.Sparse f
129+ newFrontier.Dispose queue
130+
131+ | _ -> failwith " Not implemented"
132+
133+ levels
134+
135+
136+ let singleSourcePushPull
137+ ( add : Expr < bool option -> bool option -> bool option >)
138+ ( mul : Expr < bool option -> bool option -> bool option >)
139+ ( clContext : ClContext )
140+ workGroupSize
141+ =
142+
143+ let SPARSITY = 0.001 f
144+
145+ let push nnz size =
146+ ( float32 nnz) / ( float32 size) <= SPARSITY
147+
148+ let spMVTo =
149+ SpMV.runTo add mul clContext workGroupSize
150+
151+ let spMSpV =
152+ SpMSpV.runBoolStandard add mul clContext workGroupSize
153+
154+ let zeroCreate =
155+ ClArray.zeroCreate clContext workGroupSize
156+
157+ let ofList = Vector.ofList clContext workGroupSize
158+
159+ let maskComplementedTo =
160+ Vector.map2InPlace Mask.complementedOp clContext workGroupSize
161+
162+ let maskComplemented =
163+ Vector.Sparse.Vector.map2SparseDense Mask.complementedOp clContext workGroupSize
164+
165+ let fillSubVectorDenseTo =
166+ Vector.assignByMaskInPlace ( Convert.assignToOption Mask.assign) clContext workGroupSize
167+
168+ let fillSubVectorSparseTo =
169+ Vector.assignBySparseMaskInPlace ( Convert.assignToOption Mask.assign) clContext workGroupSize
170+
171+ let toSparse = Vector.toSparse clContext workGroupSize
172+
173+ let toDense = Vector.toDense clContext workGroupSize
174+
175+ let countNNZ =
176+ ClArray.count Predicates.isSome clContext workGroupSize
177+
178+ fun ( queue : MailboxProcessor < Msg >) ( matrix : ClMatrix.CSR < bool >) ( source : int ) ->
179+ let vertexCount = matrix.RowCount
180+
181+ let levels = zeroCreate queue HostInterop vertexCount
182+
183+ let mutable frontier =
184+ ofList queue DeviceOnly Sparse vertexCount [ source, true ]
185+
186+ let mutable level = 0
187+ let mutable stop = false
188+
189+ while not stop do
190+ level <- level + 1
191+
192+ match frontier with
193+ | ClVector.Sparse front ->
194+ //Assigning new level values
195+ fillSubVectorSparseTo queue levels front ( clContext.CreateClCell level) levels
196+
197+ //Getting new frontier
198+ match spMSpV queue matrix front with
199+ | None ->
200+ frontier.Dispose queue
201+ stop <- true
202+ | Some newFrontier ->
203+ frontier.Dispose queue
204+ //Filtering visited vertices
205+ match maskComplemented queue DeviceOnly newFrontier levels with
206+ | None ->
207+ stop <- true
208+ newFrontier.Dispose queue
209+ | Some f ->
210+ newFrontier.Dispose queue
211+
212+ //Push/pull
213+ if ( push f.NNZ f.Size) then
214+ frontier <- ClVector.Sparse f
215+ else
216+ frontier <- toDense queue DeviceOnly ( ClVector.Sparse f)
217+ f.Dispose queue
218+ | ClVector.Dense front ->
219+ //Assigning new level values
220+ fillSubVectorDenseTo queue levels front ( clContext.CreateClCell level) levels
221+
222+ //Getting new frontier
223+ spMVTo queue matrix front front
224+
225+ maskComplementedTo queue front levels front
226+
227+ //Emptiness check
228+ let NNZ = countNNZ queue front
229+
230+ stop <- NNZ = 0
231+
232+ //Push/pull
233+ if not stop then
234+ if ( push NNZ front.Length) then
235+ frontier <- ClVector.Sparse( toSparse queue DeviceOnly front)
236+ front.Free queue
237+ else
238+ frontier.Dispose queue
239+
240+ levels
0 commit comments