source: project/release/4/mpi/trunk/group.scm @ 14411

Last change on this file since 14411 was 14411, checked in by Ivan Raikov, 11 years ago

mpi ported to Chicken 4

File size: 8.8 KB
Line 
1
2;;
3;; Chicken MPI interface. Based on the Caml/MPI interface by Xavier
4;; Leroy.
5;;
6;; Copyright 2007-2009 Ivan Raikov and the Okinawa Institute of Science and Technology
7;;
8;; This program is free software: you can redistribute it and/or
9;; modify it under the terms of the GNU General Public License as
10;; published by the Free Software Foundation, either version 3 of the
11;; License, or (at your option) any later version.
12;;
13;; This program is distributed in the hope that it will be useful, but
14;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;; General Public License for more details.
17;;
18;; A full copy of the GPL license can be found at
19;; <http://www.gnu.org/licenses/>.
20;;
21
22;; Handling of communication groups
23
24; Include into generated code, but don't parse:
25#>
26
27static C_word MPI_group_p(C_word obj) 
28{
29  if (C_immediatep(obj)) {
30    return C_SCHEME_FALSE;
31  } else if (C_block_header(obj) == MPI_GROUP_TAG) 
32  {
33    return C_SCHEME_TRUE;
34  } else {
35    return C_SCHEME_FALSE;
36  }
37}
38
39static C_word MPI_check_group (C_word obj) 
40{
41  if (C_immediatep(obj)) 
42  {
43    chicken_MPI_exception (MPI_ERR_COMM, 32, "invalid MPI group object");
44  } else if (C_block_header(obj) == MPI_GROUP_TAG) 
45  {
46    return C_SCHEME_UNDEFINED;
47  } else {
48    chicken_MPI_exception (MPI_ERR_COMM, 32, "invalid MPI group object");
49  }
50}
51
52<#
53
54(define MPI:group? (foreign-lambda scheme-object "MPI_group_p" scheme-object))
55
56(define MPI_alloc_group 
57    (foreign-primitive scheme-object ((nonnull-c-pointer group))
58#<<END
59
60   C_word result;
61   chicken_MPI_group_t newg;
62
63   newg.tag = MPI_GROUP_TAG;
64   newg.group_data = group;
65   result = (C_word)&newg;
66   
67   C_return (result);
68END
69))
70
71(define MPI:group-size
72    (foreign-primitive scheme-object ((scheme-object x))
73#<<END
74   C_word *ptr;
75   C_word result;
76   int size;
77
78   if (MPI_group_p (x))
79     {
80       MPI_Group_size (Group_val(x), &size);
81       ptr = C_alloc (C_SIZEOF_FLONUM);
82       result = C_int_to_num (&ptr, size);
83     }
84   else
85     {
86       result = C_SCHEME_FALSE;
87     }
88
89   C_return (result);
90END
91))
92
93
94(define MPI:group-rank
95    (foreign-primitive scheme-object ((scheme-object x))
96#<<END
97   C_word result;
98   C_word *ptr;
99   int rank;
100
101   if (MPI_group_p (x))
102     {
103       MPI_Group_rank (Group_val(x), &rank);
104       ptr = C_alloc (C_SIZEOF_FLONUM);
105       result = C_int_to_num (&ptr, rank);
106     }
107   else
108     {
109       result = C_SCHEME_FALSE;
110     }
111
112   C_return (result);
113END
114))
115
116(define MPI_group_translate_ranks
117    (foreign-primitive scheme-object ((scheme-object group1)
118                                      (scheme-object group2)
119                                      (integer nranks)
120                                      (scheme-object ranks)
121                                      (scheme-object ranks1)
122                                      (scheme-object ranks2))
123#<<END
124  int i; int *vranks, *vranks1, *vranks2;
125  C_word result;
126
127   C_i_check_vector (ranks);
128   C_i_check_vector (ranks1);
129   C_i_check_vector (ranks2);
130
131   if ((MPI_group_p (group1)) && (MPI_group_p (group2)))
132     {
133        vranks  = C_c_s32vector (ranks);
134        vranks1 = C_c_s32vector (ranks1);
135        vranks2 = C_c_s32vector (ranks2);
136        for (i = 0; i < nranks; i++)
137            vranks1[i] = vranks[i];
138        MPI_Group_translate_ranks(Group_val(group1), nranks, vranks1,
139                                  Group_val(group2), vranks2);
140        result = ranks2;
141     }
142     else
143     {
144       result = C_SCHEME_FALSE;
145     };
146
147  C_return(result);
148END
149))
150
151
152(define (MPI:group-translate-ranks group1 ranks group2)
153  (let ((nranks (s32vector-length ranks)))
154    (MPI_group_translate_ranks group1 group2 nranks 
155                               ranks (make-s32vector nranks)
156                               (make-s32vector nranks))))
157
158(define MPI_comm_group
159    (foreign-primitive nonnull-c-pointer ((scheme-object comm))
160#<<END
161  C_word result;
162  MPI_Group group;
163
164  MPI_check_comm (comm);
165  if ((MPI_comm_p (comm)))
166  {
167     MPI_Comm_group(Comm_val(comm), &group);
168     result = (C_word)group;
169  }
170  else
171  { 
172     result = (C_word)NULL;
173  }
174
175  C_return (result);
176END
177))
178
179(define (MPI:comm-group comm)
180  (MPI_alloc_group (MPI_comm_group comm)))
181
182
183(define MPI_group_union
184    (foreign-primitive nonnull-c-pointer ((scheme-object group1)
185                                          (scheme-object group2))
186#<<END
187  C_word result;
188  MPI_Group group;
189
190  MPI_check_group(group1);
191  MPI_check_group(group2);
192  if ((MPI_group_p (group1)) && (MPI_group_p (group2)))
193  {
194     MPI_Group_union(Group_val(group1), Group_val(group2), &group);
195     result = (C_word)group;
196  }
197  else
198  { 
199     result = (C_word)NULL;
200  }
201
202  C_return (result);
203END
204))
205
206(define (MPI:group-union group1 group2)
207  (MPI_alloc_group (MPI_group_union group1 group2)))
208
209
210(define MPI_group_difference
211    (foreign-primitive nonnull-c-pointer ((scheme-object group1)
212                                          (scheme-object group2))
213#<<END
214  C_word result;
215  MPI_Group group;
216
217  MPI_check_group(group1);
218  MPI_check_group(group2);
219  if ((MPI_group_p (group1)) && (MPI_group_p (group2)))
220  {
221     MPI_Group_difference(Group_val(group1), Group_val(group2), &group);
222     result = (C_word)group;
223  }
224  else
225  { 
226     result = (C_word)NULL;
227  }
228
229  C_return (result);
230END
231))
232
233(define (MPI:group-difference group1 group2)
234  (MPI_alloc_group (MPI_group_difference group1 group2)))
235
236
237(define MPI_group_intersection
238    (foreign-primitive nonnull-c-pointer ((scheme-object group1)
239                                          (scheme-object group2))
240#<<END
241  C_word result;
242  MPI_Group group;
243
244  MPI_check_group(group1);
245  MPI_check_group(group2);
246  if ((MPI_group_p (group1)) && (MPI_group_p (group2)))
247  {
248     MPI_Group_intersection(Group_val(group1), Group_val(group2), &group);
249     result = (C_word)group;
250  }
251  else
252  { 
253     result = (C_word)NULL;
254  }
255
256  C_return (result);
257END
258))
259
260(define (MPI:group-intersection group1 group2)
261  (MPI_alloc_group (MPI_group_intersection group1 group2)))
262
263
264(define MPI_group_incl
265    (foreign-primitive nonnull-c-pointer ((scheme-object group)
266                                          (integer nranks)
267                                          (scheme-object ranks))
268#<<END
269  C_word result;
270  int * vranks;
271  MPI_Group newg;
272
273  C_i_check_vector (ranks);
274  MPI_check_group(group);
275
276  if ((MPI_group_p (group)))
277  {
278     vranks  = C_c_s32vector (ranks);
279     MPI_Group_incl(Group_val(group), nranks, vranks, &newg);
280     result = (C_word)newg;
281  }
282  else
283  { 
284     result = (C_word)NULL;
285  }
286
287  C_return (result);
288END
289))
290
291(define (MPI:group-incl group ranks)
292  (MPI_alloc_group (MPI_group_incl group (s32vector-length ranks) ranks)))
293
294
295(define MPI_group_excl
296    (foreign-primitive nonnull-c-pointer ((scheme-object group)
297                                          (integer nranks)
298                                          (scheme-object ranks))
299#<<END
300  C_word result;
301  int * vranks;
302  MPI_Group newg;
303
304  C_i_check_vector (ranks);
305  MPI_check_group(group);
306
307  if ((MPI_group_p (group)))
308  {
309     vranks  = C_c_s32vector (ranks);
310     MPI_Group_incl(Group_val(group), nranks, vranks, &newg);
311     result = (C_word)newg;
312  }
313  else
314  { 
315     result = (C_word)NULL;
316  }
317
318  C_return (result);
319END
320))
321
322(define (MPI:group-excl group ranks)
323  (MPI_alloc_group (MPI_group_excl group (s32vector-length ranks) ranks)))
324
325
326; Include into generated code, but don't parse:
327#>
328static void MPI_extract_ranges (C_word ranges,
329                                  /*out*/ int * num,
330                                  /*out*/ int * exranges)
331{
332   int i, nranges; C_word range;
333   C_i_check_vector (ranges);   
334
335   nranges = C_unfix(C_i_vector_length (ranges));
336
337   for (i = 0; i < nranges; i++)
338   {
339     range = C_i_vector_ref (ranges, C_fix(i));
340     exranges[(3*i)+0] = C_num_to_int(C_u_i_s32vector_ref(range, C_fix(0)));
341     exranges[(3*i)+1] = C_num_to_int(C_u_i_s32vector_ref(range, C_fix(1)));
342     exranges[(3*i)+2] = C_num_to_int(C_u_i_s32vector_ref(range, C_fix(2)));
343   }
344   
345}
346<#
347
348
349(define MPI_group_range_incl
350    (foreign-primitive nonnull-c-pointer ((scheme-object group)
351                                          (scheme-object ranges)
352                                          (s32vector exranges))
353#<<END
354  C_word result;
355  MPI_Group newg;
356  int num;
357
358  C_i_check_vector (ranges);
359  MPI_check_group (group);
360
361  if ((MPI_group_p (group)))
362  {
363     MPI_extract_ranges (ranges, &num, exranges);
364     MPI_Group_range_incl(Group_val(group), num, exranges, &newg);
365     result = (C_word)newg;
366  }
367  else
368  { 
369     result = (C_word)NULL;
370  }
371
372  C_return (result);
373END
374))
375
376
377(define (MPI:group-range-incl group ranges)
378  (let ((len (vector-length ranges)))
379    (MPI_alloc_group (MPI_group_range_incl group ranges (make-s32vector (* 3 len))))))
380
381
382
383
384(define MPI_group_range_excl
385    (foreign-primitive nonnull-c-pointer ((scheme-object group)
386                                          (scheme-object ranges)
387                                          (s32vector exranges))
388#<<END
389  C_word result;
390  MPI_Group newg;
391  int num;
392
393  C_i_check_vector (ranges);
394  MPI_check_group (group);
395
396  if ((MPI_group_p (group)))
397  {
398     MPI_extract_ranges (ranges, &num, exranges);
399     MPI_Group_range_excl(Group_val(group), num, exranges, &newg);
400     result = (C_word)newg;
401  }
402  else
403  { 
404     result = (C_word)NULL;
405  }
406
407  C_return (result);
408END
409))
410
411
412(define (MPI:group-range-excl group ranges)
413  (let ((len (vector-length ranges)))
414    (MPI_alloc_group (MPI_group_range_excl group ranges (make-s32vector (* 3 len))))))
415
Note: See TracBrowser for help on using the repository browser.