source: CIVL/src/include/civl/civl-mpi.cvl@ c395996

1.23 2.0 acw/focus-triggers main test-branch
Last change on this file since c395996 was 4e534fd, checked in by Manchun Zheng <zmanchun@…>, 10 years ago

fixed the naming of collator

git-svn-id: ​svn://vsl.cis.udel.edu/civl/trunk@3351 fb995dde-84ed-4084-dfe6-e5aef3e2452c
  • Property mode set to 100644
File size: 23.5 KB
Line 
1#ifndef __CIVL_CIVLMPI__
2#define __CIVL_CIVLMPI__
3
4#include <civlc.cvh>
5#include <concurrency.cvh>
6#include <comm.cvh>
7#include <bundle.cvh>
8#include <mpi.h>
9#include <civl-mpi.cvh>
10#include <string.h>
11#include <pointer.cvh>
12#include <seq.cvh>
13
14/* Library private helper function declaration */
15char * getCoroutineName(int tag);
16
17/**************************** Duplicated Part *************************************/
18/* Duplicated definition with the same struct in mpi.h.
19 The reason of this duplication is to make civlmpi.cvl
20 independent with mpi.cvl. */
21typedef struct MPI_Comm {
22 $comm p2p; // point-to-point communication
23 $comm col; // collective communication
24 $collator collator;
25 $barrier barrier;
26 int gcommIndex; //the index of the corresponding global communicator.
27}MPI_Comm;
28
29/* Definition of CMPI_Gcomm (CMPI_Gcomm has a type of __CMPI_Gcomm)
30 and MPI_Comm */
31struct $mpi_gcomm {
32 $gcomm p2p; // point-to-point communication
33 $gcomm col; // collective communication
34 $gcollator gcollator;
35 $gbarrier gbarrier;
36};
37
38/****************************** Helper Functions **********************************/
39int sizeofDatatype(MPI_Datatype datatype) {
40 switch (datatype) {
41 case MPI_INT:
42 return sizeof(int);
43 case MPI_2INT:
44 return (sizeof(int)*2);
45 case MPI_FLOAT:
46 return sizeof(float);
47 case MPI_DOUBLE:
48 return sizeof(double);
49 case MPI_CHAR:
50 return sizeof(char);
51 case MPI_BYTE:
52 return sizeof(char); // char is always one byte ?
53 case MPI_SHORT:
54 return sizeof(short);
55 case MPI_LONG:
56 return sizeof(long);
57 case MPI_LONG_DOUBLE:
58 return sizeof(long double);
59 case MPI_LONG_LONG_INT:
60 return sizeof(long long int);
61 case MPI_LONG_LONG:
62 return sizeof(long long);
63 case MPI_UNSIGNED_LONG_LONG:
64 return sizeof(unsigned long long);
65 default:
66 $assert(0, "Unreachable");
67 }
68}
69
70/************************** MPI LIB Implementations *******************************/
71$mpi_gcomm $mpi_gcomm_create($scope scope, int size) {
72 $mpi_gcomm result;
73
74 result.p2p = $gcomm_create(scope, size);
75 result.col = $gcomm_create(scope, size);
76 result.gcollator = $gcollator_create(scope);
77 result.gbarrier = $gbarrier_create(scope, size);
78 return result;
79}
80
81void $mpi_gcomm_destroy($mpi_gcomm gc) {
82 /* This function will report errors for any messages remaining the
83 $mpi_gcomm. Those messages are junk messages. */
84 int numJunkRecord;
85 int numJunkMsg;
86 $message junkMsgs[]; // A CIVL-C sequence for junk messages.
87
88 $seq_init(&junkMsgs, 0, NULL);
89 numJunkMsg = $gcomm_destroy(gc.p2p, &junkMsgs);
90 /* Informations of reporting junk messages in p2p communicator and
91 collective communicator are different: */
92 for(int i = 0; i < numJunkMsg; i++) {
93 int src, dest, tag;
94
95 src = $message_source(junkMsgs[i]);
96 dest = $message_dest(junkMsgs[i]);
97 tag = $message_tag(junkMsgs[i]);
98 $assert($false, "MPI message leak: There is a message from rank %d to rank %d with tag %d "
99 "has been sent but is never received in point-to-point communication.",
100 src, dest, tag);
101 }
102 numJunkMsg = $gcomm_destroy(gc.col, &junkMsgs);
103 for(int i = 0; i < numJunkMsg; i++) {
104 int src, tag;
105 char * routine;
106
107 src = $message_source(junkMsgs[i]);
108 tag = $message_tag(junkMsgs[i]);
109 routine = getCoroutineName(tag);
110 $assert($false, "MPI message leak: There is a message sent by rank %d for collective routine %s"
111 " that is never received.",
112 src, routine);
113 }
114 numJunkRecord = $gcollator_destroy(gc.gcollator);
115 $gbarrier_destroy(gc.gbarrier);
116 $assert(numJunkRecord == 0, "MPI collective routines are called "
117 "inappropriately because there are %d collective records"
118 " still remaining the collective routine checker.",
119 numJunkRecord);
120}
121
122MPI_Comm $mpi_comm_create($scope scope, $mpi_gcomm gc, int rank) {
123 MPI_Comm result;
124
125 result.p2p = $comm_create(scope, gc.p2p, rank);
126 result.col = $comm_create(scope, gc.col, rank);
127 result.collator = $collator_create(scope, gc.gcollator);
128 result.barrier = $barrier_create(scope, gc.gbarrier, rank);
129 result.gcommIndex = 0;
130 return result;
131}
132
133void $mpi_comm_destroy(MPI_Comm comm, $mpi_state mpi_state) {
134#ifndef _MPI_CONTRACT
135 if(comm.gcommIndex == 0)
136 $assert(mpi_state == _MPI_FINALIZED, "Process terminates without "
137 "calling MPI_Finalize() first.");
138#endif
139 $comm_destroy(comm.p2p);
140 $comm_destroy(comm.col);
141 $collator_destroy(comm.collator);
142 $barrier_destroy(comm.barrier);
143}
144
145void * $mpi_pointer_add(const void * ptr, int offset, MPI_Datatype datatype) {
146 int type_size = sizeofDatatype(datatype);
147
148#ifdef _MPI_CONTRACT
149 $elaborate(offset);
150#endif
151 return $pointer_add(ptr, offset, type_size);
152}
153
154/********************* Lower level MPI routines *********************/
155/* CMPI_Send and CMPI_Recv are a pair of send receives functions that
156 help implementing MPI routines. They should never be block which
157 means no potential deadlocks related to these functions */
158int $mpi_send(void *buf, int count, MPI_Datatype datatype, int dest,
159 int tag, MPI_Comm comm) {
160 if (dest >= 0) {
161 int size = count*sizeofDatatype(datatype);
162 int place = $comm_place(comm.p2p);
163 $message out = $message_pack(place, dest, tag, buf, size);
164
165#ifdef _MPI_CONTRACT
166 $atomic{
167 $comm_enqueue(comm.p2p, out);
168 $mpi_p2pSendShot(comm.gcommIndex, out, place);
169 }
170#else
171 $comm_enqueue(comm.p2p, out);
172#endif
173 }
174 return 0;
175}
176
177int $mpi_recv(void *buf, int count, MPI_Datatype datatype, int source,
178 int tag, MPI_Comm comm, MPI_Status *status) {
179 if (source >= 0 || source == MPI_ANY_SOURCE) {
180 $message in;
181 int place = $comm_place(comm.p2p);
182 int deterministicTag;
183
184 /* A deterministic tag is a sugar for CIVL implementaion. The CIVL
185 implementation only needs to care about two cases: tag == -2
186 which is a wild-card tag or any other tags which can either be
187 concrete or not:.*/
188 $assert(tag == -2 || tag >= 0, "Illegal MPI message receive tag %d.\n", tag);
189 deterministicTag = tag < 0 ? -2 : tag;
190 $elaborate(source);
191#ifdef _MPI_CONTRACT
192 $atomic{
193 in = $comm_dequeue(comm.p2p, source, deterministicTag);
194 int nonWildsrc = $message_source(in);
195
196 $mpi_p2pRecvShot(comm.gcommIndex, nonWildsrc, place, deterministicTag);
197 }
198#else
199 in = $comm_dequeue(comm.p2p, source, deterministicTag);
200#endif
201 int size = count*sizeofDatatype(datatype);
202
203 $message_unpack(in, buf, size);
204 if (status != MPI_STATUS_IGNORE) {
205 status->size = $message_size(in);
206 status->MPI_SOURCE = $message_source(in);
207 status->MPI_TAG = $message_tag(in);
208 status->MPI_ERROR = 0;
209 }
210 }
211 return 0;
212}
213
214int $mpi_sendrecv(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
215 int dest, int sendtag, void *recvbuf, int recvcount,
216 MPI_Datatype recvtype, int source, int recvtag,
217 MPI_Comm comm, MPI_Status *status) {
218 int deterministicRecvTag;
219
220 $assert(sendtag >= 0, "MPI sendtag should be greater than or equal to zero");
221 $assert(recvtag == -2 || recvtag >= 0, "Illegal MPI message receive tag %d.\n", recvtag);
222 deterministicRecvTag = recvtag < 0 ? -2 : recvtag;
223 //send and receive triggering flags
224 if((dest >= 0) && ((source >= 0 || source == MPI_ANY_SOURCE))) {
225 $message out, in;
226 int size = sendcount*sizeofDatatype(sendtype);
227 int place = $comm_place(comm.p2p);
228
229 out = $message_pack(place, dest, sendtag, sendbuf, size);
230 $elaborate(source);
231
232 $choose {
233 $when($true){
234 $atomic{
235 $comm_enqueue(comm.p2p, out);
236#ifdef _MPI_CONTRACT
237 $mpi_p2pSendShot(comm.gcommIndex, out, place);
238#endif
239 }
240 $atomic{
241 in = $comm_dequeue(comm.p2p, source, deterministicRecvTag);
242#ifdef _MPI_CONTRACT
243 int nonWildSrc = $message_source(in);
244
245 $mpi_p2pRecvShot(comm.gcommIndex, nonWildSrc, place, deterministicRecvTag);
246#endif
247 }
248 }
249 $when($false){
250 /* This $choose branch plays a trick which correctly
251 implements the sendrecv() semantically. Such a branch
252 ensures that there is no chance of potential deadlocks when
253 all processes do send then recv collectively. However,
254 effectively, this branch is no need and never will be
255 executed.*/
256 in = $comm_dequeue(comm.p2p, source, deterministicRecvTag);
257 $comm_enqueue(comm.p2p, out);
258 }
259 }
260 size = recvcount*sizeofDatatype(recvtype);
261 $message_unpack(in, recvbuf, size);
262 if (status != MPI_STATUS_IGNORE) {
263 status->size = $message_size(in);
264 status->MPI_SOURCE = $message_source(in);
265 status->MPI_TAG = $message_tag(in);
266 status->MPI_ERROR = 0;
267 }
268 }
269 else if (dest >= 0) {
270 $mpi_send(sendbuf, sendcount, sendtype, dest, sendtag, comm);
271 }
272 else if (source >= 0 || source == MPI_ANY_SOURCE) {
273 $mpi_recv(recvbuf, recvcount, recvtype, source, deterministicRecvTag, comm, status);
274 }
275 return 0;
276}
277
278/********************* Collective helper functions ********************/
279/* Note: collective helpers functions are functions have same
280 behaviors as MPI collective functions, it can be re-used as a part
281 of implementation by different MPI routines. For example,
282 MPI_Allreduce will call CMPI_Reduce and CMPI_Bcast, both of them
283 should throw errors (if encounters any) as if errors are thrown
284 from MPI_Allreduce.
285*/
286int $mpi_collective_send(void *buf, int count, MPI_Datatype datatype, int dest,
287 int tag, MPI_Comm comm) {
288 if (dest >= 0) {
289 int size = count*sizeofDatatype(datatype);
290 int place = $comm_place(comm.col);
291 $message out = $message_pack(place, dest, tag, buf, size);
292
293#ifdef _MPI_CONTRACT
294 $atomic{
295 $comm_enqueue(comm.col, out);
296 $mpi_colSendShot(comm.gcommIndex, out, place);
297 }
298#else
299 $comm_enqueue(comm.col, out);
300#endif
301 }
302 return 0;
303}
304
305int $mpi_collective_recv(void *buf, int count, MPI_Datatype datatype,
306 int source, int tag, MPI_Comm comm,
307 MPI_Status * status, char * routName) {
308 if(source >= 0 || source == MPI_ANY_SOURCE) {
309 $elaborate(source);
310 $message in = $comm_dequeue(comm.col, source, MPI_ANY_TAG);
311 int size = count*sizeofDatatype(datatype);
312 int recvTag;
313
314 /* This routine should only be used by collective routines, there
315 is no non-deterministic tags for collective routines.*/
316 recvTag = $message_tag(in);
317 $assert (recvTag == tag, "Collective routine %s receives a "
318 "message with a mismatched tag\n", routName);
319 $message_unpack(in, buf, size);
320 if (status != MPI_STATUS_IGNORE) {
321 status->size = $message_size(in);
322 status->MPI_SOURCE = $message_source(in);
323 status->MPI_TAG = recvTag;
324 status->MPI_ERROR = 0;
325 }
326 }
327 return 0;
328}
329
330/* Broadcast helper function that uses any specified message tag */
331int $mpi_bcast(void *buf, int count, MPI_Datatype datatype, int root, int tag,
332 MPI_Comm comm, char * routName) {
333 if ($comm_place(comm.col) == root) {
334 int nprocs = $comm_size(comm.col);
335
336 for (int i=0; i<nprocs; i++)
337 if (i != root)
338 $mpi_collective_send(buf, count, datatype, i, tag, comm);
339 } else
340 $mpi_collective_recv(buf, count, datatype, root, tag, comm,
341 MPI_STATUS_IGNORE, routName);
342 return 0;
343}
344
345/* Reduction helper function that uses any specified message tag */
346int $mpi_reduce(const void* sendbuf, void* recvbuf, int count,
347 MPI_Datatype datatype, MPI_Op op, int root, int tag,
348 MPI_Comm comm, char * routName) {
349 int rank;
350
351 rank = $comm_place(comm.col);
352 if (rank != root)
353 $mpi_collective_send(sendbuf, count, datatype, root, tag, comm);
354 else {
355 int nprocs = $comm_size(comm.col);
356 int size;
357
358 size = count * sizeofDatatype(datatype);
359 memcpy(recvbuf, sendbuf, size);
360 for (int i = 0; i<nprocs; i++) {
361 if(i != root){
362 int colTag;
363 $message in = $comm_dequeue(comm.col, i, MPI_ANY_TAG);
364
365 /* Collective routines have no non-deterministic tags.*/
366 colTag = $message_tag(in);
367 $assert (colTag == tag , "Collective routine %s receives a "
368 "message with a mismatched tag\n", routName);
369 /* the third argument "count" indicates the number of cells needs doing the
370 operation. */
371 $bundle_unpack_apply(in.data, recvbuf, count, op);
372 $assert (in.size <= size ,
373 "Message of size %d exceeds the specified size %d.", in.size, size);
374 }
375 }
376 }
377 return 0;
378}
379
380/* Gathering helper function that uses any specified message tag */
381int $mpi_gather(const void* sendbuf, int sendcount, MPI_Datatype sendtype,
382 void* recvbuf, int recvcount, MPI_Datatype recvtype,
383 int root, int tag, MPI_Comm comm, char * routName){
384 int rank, nprocs;
385 MPI_Status status;
386
387 rank = $comm_place(comm.col);
388 nprocs = $comm_size(comm.col);
389 /* MPI standard requirement:
390 * For root process, sendtype must be equal to
391 * recvtype. */
392 if(rank == root)
393 $assert (sendtype == recvtype,
394 "%s asks for equality "
395 "between 'sendtype' and 'recvtype'.", routName);
396 /* MPI_standard requirement:
397 * Only root process can use MPI_IN_PLACE*/
398 if(sendbuf == MPI_IN_PLACE){
399 $assert (root == rank,
400 "Only root can replace 'sendbuf' with 'MPI_IN_PLACE'.");
401 } else if(root == rank) {
402 void * ptr;
403
404 $assert(sendcount == recvcount, "Root process of routine %d without using"
405 " MPI_IN_PLACE should give the same value for recvcount and sendcount",
406 routName);
407 ptr = $mpi_pointer_add(recvbuf, root * recvcount, recvtype);
408 memcpy(ptr, sendbuf, recvcount * sizeofDatatype(recvtype));
409 } else
410 $mpi_collective_send(sendbuf, sendcount, sendtype, root, tag, comm);
411 /* Root process receives messages and put them in right places */
412 if(rank == root){
413 int real_recvcount;
414 int offset;
415
416 for(int i=0; i<nprocs; i++){
417 if(i != root) {
418 void * ptr;
419
420 offset = i * recvcount;
421 ptr = $mpi_pointer_add(recvbuf, offset, recvtype);
422 $mpi_collective_recv(ptr, recvcount, recvtype,
423 i, tag, comm, &status, routName);
424 real_recvcount = status.size/sizeofDatatype(recvtype);
425 $assert(real_recvcount == recvcount,
426 "%s asks for equality between"
427 " the amount of data sent and the "
428 "amount of data received.", routName);
429 }
430 }
431 }
432 return 0;
433}
434
435int $mpi_gatherv(const void* sendbuf, int sendcount, MPI_Datatype sendtype,
436 void* recvbuf, const int recvcounts[], const int displs[],
437 MPI_Datatype recvtype, int root, int tag,
438 MPI_Comm comm, char * routName){
439 int rank, nprocs;
440
441 rank = $comm_place(comm.col);
442 nprocs = $comm_size(comm.col);
443 /* MPI standard requirement:
444 * For root process, sendtype must be equal to
445 * recvtype. */
446 if(rank == root)
447 $assert(sendtype == recvtype, "%s asks for equality "
448 "between 'sendtype' and 'recvtype'.", routName);
449 /* MPI_standard requirement:
450 * Only root process can use MPI_IN_PLACE*/
451 if(sendbuf == MPI_IN_PLACE){
452 $assert(root == rank, "Only root can replace 'sendbuf' with 'MPI_IN_PLACE'.");
453 }else if(root == rank) {
454 void * ptr;
455
456 $assert(sendcount == recvcounts[root], "For routine %s, recvcounts[%d] "
457 "should be same as the sendcount of the process with rank %d.\n",
458 routName, root, root);
459 ptr = $mpi_pointer_add(recvbuf, displs[rank], recvtype);
460 memcpy(ptr, sendbuf, sendcount * sizeofDatatype(recvtype));
461 }else{
462 $mpi_collective_send(sendbuf, sendcount, sendtype, root, tag, comm);
463 }
464 /* Root process receives messages and put them in right places */
465 if(rank == root){
466 int real_recvcount;
467 MPI_Status status;
468
469 for(int i=0; i<nprocs; i++){
470 if(i != root){
471 void * ptr = $mpi_pointer_add(recvbuf, displs[i], recvtype);
472
473 $mpi_collective_recv(ptr, recvcounts[i],
474 recvtype, i, tag, comm, &status, routName);
475 real_recvcount = status.size/sizeofDatatype(recvtype);
476 $assert(real_recvcount == recvcounts[i], "%s asks for equality between"
477 " the amount of data sent and the "
478 "amount of data received.", routName);
479 }
480 }
481 }
482 return 0;
483}
484
485/* Scatter helper function that uses any specified message tag */
486int $mpi_scatter(const void* sendbuf, int sendcount, MPI_Datatype sendtype,
487 void* recvbuf, int recvcount, MPI_Datatype recvtype, int root,
488 int tag, MPI_Comm comm, char * routName){
489 int rank, nprocs;
490
491 rank = $comm_place(comm.col);
492 nprocs = $comm_size(comm.col);
493 /* MPI standard requirement:
494 * For root process, sendtype must be equal to
495 * recvtype. */
496 if(rank == root)
497 $assert(sendtype == recvtype, "MPI_Scatter() asks for equality "
498 "between 'sendtype' and 'recvtype'.");
499 /* MPI_standard requirement:
500 * Only root process can use MPI_IN_PLACE */
501 if(recvbuf == MPI_IN_PLACE){
502 $assert(root == rank, "Only root can replace 'recvbuf' with 'MPI_IN_PLACE'.");
503 }else if(rank == root) {
504 void * ptr;
505
506 $assert(sendcount == recvcount, "Root process of routine %d without using"
507 " MPI_IN_PLACE should give the same value for recvcount and sendcount",
508 routName);
509 ptr = $mpi_pointer_add(sendbuf, root*recvcount, sendtype);
510 memcpy(recvbuf, ptr, sizeofDatatype(recvtype)*recvcount);
511 }
512 /* Root process scatters data to other processes */
513 if(rank == root){
514 int offset;
515
516 for(int i=0; i<nprocs; i++){
517 if(i != root) {
518 void * ptr;
519
520 offset = i * sendcount;
521 ptr = $mpi_pointer_add(sendbuf, offset, sendtype);
522 $mpi_collective_send(ptr, sendcount, sendtype, i, tag, comm);
523 }
524 }
525 }
526 /* Non-root processes receive data */
527 if(!(root == rank)){
528 int real_recvcount;
529 MPI_Status status;
530
531 $mpi_collective_recv(recvbuf, recvcount, recvtype,
532 root, tag, comm, &status, routName);
533 real_recvcount = status.size/sizeofDatatype(recvtype);
534 $assert(real_recvcount == recvcount,
535 "%s asks for equality between"
536 " the amount of data sent and the "
537 "amount of data received.", routName);
538 }
539 return 0;
540}
541
542/* Scatterv helper function that uses any specified message tag */
543int $mpi_scatterv(const void* sendbuf, const int sendcounts[], const
544 int displs[], MPI_Datatype sendtype, void* recvbuf,
545 int recvcount, MPI_Datatype recvtype, int root, int tag,
546 MPI_Comm comm, char * routName){
547 int rank, nprocs;
548
549 rank = $comm_place(comm.col);
550 nprocs = $comm_size(comm.col);
551 /* MPI standard requirement:
552 * For root process, sendtype must be equal to
553 * recvtype. */
554 if(rank == root)
555 $assert(sendtype == recvtype, "%s asks for equality "
556 "between 'sendtype' and 'recvtype'.", routName);
557 /* MPI_standard requirement:
558 * Only root process can use MPI_IN_PLACE */
559 if(recvbuf == MPI_IN_PLACE){
560 $assert(root == rank, "Only root can replace 'recvbuf' with 'MPI_IN_PLACE'.");
561 } else if(rank == root) {
562 void * ptr;
563
564 $assert(sendcounts[root] == recvcount, "For routine %s, sendcounts[%d] "
565 "should be same as the recvcount of the process with rank %d.\n",
566 routName, root, root);
567 ptr = $mpi_pointer_add(sendbuf, displs[root], sendtype);
568 memcpy(recvbuf, ptr, recvcount*sizeofDatatype(recvtype));
569 }
570 /* Root process scatters data to other processes */
571 if(rank == root){
572 for(int i=0; i<nprocs; i++){
573 if(i != root) {
574 void * ptr = $mpi_pointer_add(sendbuf, displs[i], sendtype);
575
576 $mpi_collective_send(ptr, sendcounts[i], sendtype, i,
577 tag, comm);
578 }
579 }
580 }
581 if(!(root == rank)){
582 MPI_Status status;
583 int real_recvcount;
584
585 $mpi_collective_recv(recvbuf, recvcount, recvtype,
586 root, tag, comm, &status, routName);
587 real_recvcount = status.size/sizeofDatatype(recvtype);
588 $assert(real_recvcount == recvcount, "Process rank:%d\n%s asks for equality between"
589 " the amount of data sent (%d) and the "
590 "amount of data received (%d).", rank, routName, real_recvcount, recvcount);
591 }
592 return 0;
593}
594
595int $mpi_comm_dup($scope scope, MPI_Comm comm, MPI_Comm * newcomm, char * routName) {
596 int place = $comm_place(comm.col);
597 $mpi_gcomm newgcomm;
598 int idx;
599 $scope CMPI_ROOT_SCOPE = $mpi_root_scope(comm.col);
600
601 if(place == 0) {
602 int size = $comm_size(comm.col);
603
604 newgcomm = $mpi_gcomm_create(CMPI_ROOT_SCOPE, size);
605 idx = $mpi_new_gcomm(CMPI_ROOT_SCOPE, newgcomm);
606 }
607 $mpi_bcast(&idx, 1, MPI_INT, 0, COMMDUP_TAG,
608 comm, routName);
609 newgcomm = $mpi_get_gcomm(CMPI_ROOT_SCOPE, idx);
610 (*newcomm) = $mpi_comm_create(scope, newgcomm, place);
611 newcomm->gcommIndex = idx;
612 $barrier_call(comm.barrier);
613 $gcomm_dup(comm.p2p, newcomm->p2p);
614 $gcomm_dup(comm.col, newcomm->col);
615 $barrier_call(comm.barrier);
616 return 0;
617}
618
619int $mpi_comm_free(MPI_Comm *comm, $mpi_state mpi_state) {
620 int place = $comm_place(comm->col);
621 int size = $comm_size(comm->col);
622 int buf[size];
623 int gcommIndex = comm->gcommIndex;
624 $scope CMPI_ROOT_SCOPE = $mpi_root_scope(comm->col);
625
626 //TODO: $mpi_gather here is just a ugly synchronization
627 $mpi_gather(&place, 1, MPI_INT, buf, 1, MPI_INT, 0,
628 COMMFREE_TAG, (*comm), "MPI_Comm_free synchronization.");
629 $mpi_comm_destroy(*comm, mpi_state);
630 if(place == 0) {
631 $mpi_gcomm temp = $mpi_get_gcomm(CMPI_ROOT_SCOPE, gcommIndex);
632
633 $mpi_gcomm_destroy(temp);
634 }
635 return 0;
636}
637
638$bundle $mpi_create_coroutine_entry(int routineTag, int root,
639 int op, int numDatatypes, int * datatypes) {
640 int zero = 0;
641 $bundle bundledEntry;
642 struct Entry {
643 int routine_tag;
644 int root;
645 int op;
646 int numTypes;
647 int datatypes[];
648 }entry;
649
650 entry.routine_tag = routineTag;
651 entry.root = root;
652 entry.op = op;
653 entry.numTypes = numDatatypes;
654 $seq_init(&entry.datatypes, numDatatypes, &zero);
655 for(int i = 0; i < numDatatypes; i++)
656 entry.datatypes[i] = datatypes[i];
657 bundledEntry = $bundle_pack(&entry, sizeof(struct Entry));
658 return bundledEntry;
659}
660
661void $mpi_diff_coroutine_entries($bundle specEntry, $bundle mineEntry, int rank) {
662 struct Entry {
663 int routine_tag;
664 int root;
665 int op;
666 int numTypes;
667 int datatypes[];
668 }spec, mine;
669 char * routine;
670 int numTypes;
671
672 $bundle_unpack(specEntry, &spec);
673 $bundle_unpack(mineEntry, &mine);
674 routine = getCoroutineName(spec.routine_tag);
675 if(spec.routine_tag != mine.routine_tag) {
676 char * mineRoutine = getCoroutineName(mine.routine_tag);
677
678 $assert($false, "Process with rank %d reaches an MPI collective routine "
679 "%s while at least one of others are collectively reaching %s.",
680 rank, mineRoutine, routine);
681 }
682 else if(spec.root != mine.root) {
683 $assert($false, "Process with rank %d reaches an MPI collective routine "
684 "%s which has a different root with at least one of others.", rank, routine);
685 } else if(spec.op != mine.op) {
686 $assert($false, "Process with rank %d reaches an MPI collective routine "
687 "%s which has a different MPI_Op with at least one of others", rank, routine);
688 } else if(spec.numTypes != mine.numTypes) {
689 $assert($false, "Process with rank %d reaches an MPI collective routine "
690 "%s which has an inconsistent datatype specification with at least"
691 " one of others",
692 rank, routine);
693 }
694 numTypes = spec.numTypes;
695 for(int i = 0; i < numTypes; i++)
696 if(spec.datatypes[i] != mine.datatypes[i]) {
697 $assert($false, "Process with rank %d reaches an MPI collective routine "
698 "%s which has an inconsistent datatype specification with at "
699 "least one of others",
700 rank, routine);
701 break;
702 }
703}
704
705/********************* Private helper functions *********************/
706/* Returns the string literal of MPI collective routine names by
707 * giving the unique message tag. */
708char * getCoroutineName(int tag) {
709 switch(tag) {
710 case 9999: return "MPI_Bcast";
711 case 9998: return "MPI_Reduce";
712 case 9997: return "MPI_Allreduce";
713 case 9996: return "MPI_Gather";
714 case 9995: return "MPI_Scatter";
715 case 9994: return "MPI_Gatherv";
716 case 9993: return "MPI_Scatterv";
717 case 9992: return "MPI_Allgather";
718 case 9991: return "MPI_Reduce_scatter";
719 case 9990: return "MPI_Alltoall";
720 case 9989: return "MPI_Alltoallv";
721 case 9988: return "MPI_Alltoallw";
722 case 9987: return "MPI_Barrier";
723 case 9986: return "MPI_Commdup";
724 case 9985: return "MPI_Commfree";
725 default: $assert($false, "Internal Error: Unexpected MPI routine tag:%d.\n", tag);
726 }
727}
728#endif
729
Note: See TracBrowser for help on using the repository browser.