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

1.23 2.0 acw/focus-triggers main test-branch
Last change on this file since fffb3b88 was 537f004, checked in by Ziqing Luo <ziqing@…>, 10 years ago

temporarily add ContractConditionGenerator into CommonEnabler

now broad and gather all works

git-svn-id: ​svn://vsl.cis.udel.edu/civl/trunk@3185 fb995dde-84ed-4084-dfe6-e5aef3e2452c
  • Property mode set to 100644
File size: 22.7 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 $collect_checker collect_checker;
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 $gcollect_checker collect_checker;
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.collect_checker = $gcollect_checker_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 = $gcollect_checker_destroy(gc.collect_checker);
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.collect_checker = $collect_checker_create(scope, gc.collect_checker);
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) {
134 $mpi_sys_status curr_status;
135
136 curr_status = $mpi_get_status();
137 if(comm.gcommIndex == 0)
138 $assert(curr_status == __FINALIZED, "Process terminates without "
139 "calling MPI_Finalize() first.");
140 $comm_destroy(comm.p2p);
141 $comm_destroy(comm.col);
142 $collect_checker_destroy(comm.collect_checker);
143 $barrier_destroy(comm.barrier);
144}
145
146int $mpi_init(void) {
147 $mpi_set_status(__INIT);
148 return 0;
149}
150
151int $mpi_finalize(void) {
152 $mpi_set_status(__FINALIZED);
153 return 0;
154}
155
156void * $mpi_pointerAdd(const void * ptr, int offset, MPI_Datatype datatype) {
157 int type_size = sizeofDatatype(datatype);
158
159#ifdef _MPI_CONTRACT
160 $elaborate(offset);
161#endif
162 return $pointer_add(ptr, offset, type_size);
163}
164
165/********************* Lower level MPI routines *********************/
166/* CMPI_Send and CMPI_Recv are a pair of send receives functions that
167 help implementing MPI routines. They should never be block which
168 means no potential deadlocks related to these functions */
169int $mpi_send(void *buf, int count, MPI_Datatype datatype, int dest,
170 int tag, MPI_Comm comm) {
171 if (dest >= 0) {
172 int size = count*sizeofDatatype(datatype);
173 int place = $comm_place(comm.p2p);
174 $message out = $message_pack(place, dest, tag, buf, size);
175
176#ifdef _MPI_CONTRACT
177 $atomic{
178 $comm_enqueue(comm.p2p, out);
179 $mpi_p2pSendShot(comm.gcommIndex, out, place);
180 }
181#else
182 $comm_enqueue(comm.p2p, out);
183#endif
184 }
185 return 0;
186}
187
188int $mpi_recv(void *buf, int count, MPI_Datatype datatype, int source,
189 int tag, MPI_Comm comm, MPI_Status *status) {
190 if (source >= 0 || source == MPI_ANY_SOURCE) {
191 $message in;
192 int place = $comm_place(comm.p2p);
193
194#ifdef _MPI_CONTRACT
195 $atomic{
196 in = $comm_dequeue(comm.p2p, source, tag);
197 int nonWildsrc = $message_source(in);
198
199 $mpi_p2pRecvShot(comm.gcommIndex, nonWildsrc, place, tag);
200 }
201#else
202 in = $comm_dequeue(comm.p2p, source, tag);
203#endif
204 int size = count*sizeofDatatype(datatype);
205
206 $message_unpack(in, buf, size);
207 if (status != MPI_STATUS_IGNORE) {
208 status->size = $message_size(in);
209 status->MPI_SOURCE = $message_source(in);
210 status->MPI_TAG = $message_tag(in);
211 status->MPI_ERROR = 0;
212 }
213 }
214 return 0;
215}
216
217int $mpi_sendrecv(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
218 int dest, int sendtag, void *recvbuf, int recvcount,
219 MPI_Datatype recvtype, int source, int recvtag,
220 MPI_Comm comm, MPI_Status *status) {
221 //send and receive triggering flags
222 if((dest >= 0) && ((source >= 0 || source == MPI_ANY_SOURCE))) {
223 $message out, in;
224 int size = sendcount*sizeofDatatype(sendtype);
225 int place = $comm_place(comm.p2p);
226
227 out = $message_pack(place, dest, sendtag, sendbuf, size);
228 $choose {
229 $when($true){
230 $atomic{
231 $comm_enqueue(comm.p2p, out);
232#ifdef _MPI_CONTRACT
233 $mpi_p2pSendShot(comm.gcommIndex, out, place);
234#endif
235 }
236 $atomic{
237 in = $comm_dequeue(comm.p2p, source, recvtag);
238#ifdef _MPI_CONTRACT
239 int nonWildSrc = $message_source(in);
240
241 $mpi_p2pRecvShot(comm.gcommIndex, nonWildSrc, place, recvtag);
242#endif
243 }
244 }
245 $when($false){
246 /* This $choose branch plays a trick which correctly
247 implements the sendrecv() semantically. Such a branch
248 ensures that there is no chance of potential deadlocks when
249 all processes do send then recv collectively. However,
250 effectively, this branch is no need and never will be
251 executed.*/
252 in = $comm_dequeue(comm.p2p, source, recvtag);
253 $comm_enqueue(comm.p2p, out);
254 }
255 }
256 size = recvcount*sizeofDatatype(recvtype);
257 $message_unpack(in, recvbuf, size);
258 if (status != MPI_STATUS_IGNORE) {
259 status->size = $message_size(in);
260 status->MPI_SOURCE = $message_source(in);
261 status->MPI_TAG = $message_tag(in);
262 status->MPI_ERROR = 0;
263 }
264 }
265 else if (dest >= 0) {
266 $mpi_send(sendbuf, sendcount, sendtype, dest, sendtag, comm);
267 }
268 else if (source >= 0 || source == MPI_ANY_SOURCE) {
269 $mpi_recv(recvbuf, recvcount, recvtype, source, recvtag, comm, status);
270 }
271 return 0;
272}
273
274/********************* Collective helper functions ********************/
275/* Note: collective helpers functions are functions have same
276 behaviors as MPI collective functions, it can be re-used as a part
277 of implementation by different MPI routines. For example,
278 MPI_Allreduce will call CMPI_Reduce and CMPI_Bcast, both of them
279 should throw errors (if encounters any) as if errors are thrown
280 from MPI_Allreduce.
281*/
282int $mpi_collective_send(void *buf, int count, MPI_Datatype datatype, int dest,
283 int tag, MPI_Comm comm) {
284 if (dest >= 0) {
285 int size = count*sizeofDatatype(datatype);
286 int place = $comm_place(comm.col);
287 $message out = $message_pack(place, dest, tag, buf, size);
288
289#ifdef _MPI_CONTRACT
290 $atomic{
291 $comm_enqueue(comm.col, out);
292 $mpi_colSendShot(comm.gcommIndex, out, place);
293 }
294#else
295 $comm_enqueue(comm.col, out);
296#endif
297 }
298 return 0;
299}
300
301int $mpi_collective_recv(void *buf, int count, MPI_Datatype datatype,
302 int source, int tag, MPI_Comm comm,
303 MPI_Status * status, char * routName) {
304 if(source >= 0 || source == MPI_ANY_SOURCE) {
305 $message in = $comm_dequeue(comm.col, source, MPI_ANY_TAG);
306 int size = count*sizeofDatatype(datatype);
307 int recvTag;
308
309 recvTag = $message_tag(in);
310 $assert (recvTag == tag , "Collective routine %s receives a "
311 "message with a mismatched tag\n", routName);
312 $message_unpack(in, buf, size);
313 if (status != MPI_STATUS_IGNORE) {
314 status->size = $message_size(in);
315 status->MPI_SOURCE = $message_source(in);
316 status->MPI_TAG = recvTag;
317 status->MPI_ERROR = 0;
318 }
319 }
320 return 0;
321}
322
323/* Broadcast helper function that uses any specified message tag */
324int $mpi_bcast(void *buf, int count, MPI_Datatype datatype, int root, int tag,
325 MPI_Comm comm, char * routName) {
326 if ($comm_place(comm.col) == root) {
327 int nprocs = $comm_size(comm.col);
328
329 for (int i=0; i<nprocs; i++)
330 if (i != root)
331 $mpi_collective_send(buf, count, datatype, i, tag, comm);
332 } else
333 $mpi_collective_recv(buf, count, datatype, root, tag, comm,
334 MPI_STATUS_IGNORE, routName);
335 return 0;
336}
337
338/* Reduction helper function that uses any specified message tag */
339int $mpi_reduce(const void* sendbuf, void* recvbuf, int count,
340 MPI_Datatype datatype, MPI_Op op, int root, int tag,
341 MPI_Comm comm, char * routName) {
342 int rank;
343
344 rank = $comm_place(comm.col);
345 if (rank != root)
346 $mpi_collective_send(sendbuf, count, datatype, root, tag, comm);
347 else {
348 int nprocs = $comm_size(comm.col);
349 int size;
350
351 size = count * sizeofDatatype(datatype);
352 memcpy(recvbuf, sendbuf, size);
353 for (int i = 0; i<nprocs; i++) {
354 if(i != root){
355 int colTag;
356 $message in = $comm_dequeue(comm.col, i, MPI_ANY_TAG);
357
358 colTag = $message_tag(in);
359 $assert (colTag == tag , "Collective routine %s receives a "
360 "message with a mismatched tag\n", routName);
361 /* the third argument "count" indicates the number of cells needs doing the
362 operation. */
363 $bundle_unpack_apply(in.data, recvbuf, count, op);
364 $assert (in.size <= size ,
365 "Message of size %d exceeds the specified size %d.", in.size, size);
366 }
367 }
368 }
369 return 0;
370}
371
372/* Gathering helper function that uses any specified message tag */
373int $mpi_gather(const void* sendbuf, int sendcount, MPI_Datatype sendtype,
374 void* recvbuf, int recvcount, MPI_Datatype recvtype,
375 int root, int tag, MPI_Comm comm, char * routName){
376 int rank, nprocs;
377 MPI_Status status;
378
379 rank = $comm_place(comm.col);
380 nprocs = $comm_size(comm.col);
381 /* MPI standard requirement:
382 * For root process, sendtype must be equal to
383 * recvtype. */
384 if(rank == root)
385 $assert (sendtype == recvtype,
386 "%s asks for equality "
387 "between 'sendtype' and 'recvtype'.", routName);
388 /* MPI_standard requirement:
389 * Only root process can use MPI_IN_PLACE*/
390 if(sendbuf == MPI_IN_PLACE){
391 $assert (root == rank,
392 "Only root can replace 'sendbuf' with 'MPI_IN_PLACE'.");
393 } else if(root == rank) {
394 void * ptr;
395
396 $assert(sendcount == recvcount, "Root process of routine %d without using"
397 " MPI_IN_PLACE should give the same value for recvcount and sendcount",
398 routName);
399 ptr = $mpi_pointerAdd(recvbuf, root * recvcount, recvtype);
400 memcpy(ptr, sendbuf, recvcount * sizeofDatatype(recvtype));
401 } else
402 $mpi_collective_send(sendbuf, sendcount, sendtype, root, tag, comm);
403 /* Root process receives messages and put them in right places */
404 if(rank == root){
405 int real_recvcount;
406 int offset;
407
408 for(int i=0; i<nprocs; i++){
409 if(i != root) {
410 void * ptr;
411
412 offset = i * recvcount;
413 ptr = $mpi_pointerAdd(recvbuf, offset, recvtype);
414 $mpi_collective_recv(ptr, recvcount, recvtype,
415 i, tag, comm, &status, routName);
416 real_recvcount = status.size/sizeofDatatype(recvtype);
417 $assert(real_recvcount == recvcount,
418 "%s asks for equality between"
419 " the amount of data sent and the "
420 "amount of data received.", routName);
421 }
422 }
423 }
424 return 0;
425}
426
427int $mpi_gatherv(const void* sendbuf, int sendcount, MPI_Datatype sendtype,
428 void* recvbuf, const int recvcounts[], const int displs[],
429 MPI_Datatype recvtype, int root, int tag,
430 MPI_Comm comm, char * routName){
431 int rank, nprocs;
432
433 rank = $comm_place(comm.col);
434 nprocs = $comm_size(comm.col);
435 /* MPI standard requirement:
436 * For root process, sendtype must be equal to
437 * recvtype. */
438 if(rank == root)
439 $assert(sendtype == recvtype, "%s asks for equality "
440 "between 'sendtype' and 'recvtype'.", routName);
441 /* MPI_standard requirement:
442 * Only root process can use MPI_IN_PLACE*/
443 if(sendbuf == MPI_IN_PLACE){
444 $assert(root == rank, "Only root can replace 'sendbuf' with 'MPI_IN_PLACE'.");
445 }else if(root == rank) {
446 void * ptr;
447
448 $assert(sendcount == recvcounts[root], "For routine %s, recvcounts[%d] "
449 "should be same as the sendcount of the process with rank %d.\n",
450 routName, root, root);
451 ptr = $mpi_pointerAdd(recvbuf, displs[rank], recvtype);
452 memcpy(ptr, sendbuf, sendcount * sizeofDatatype(recvtype));
453 }else{
454 $mpi_collective_send(sendbuf, sendcount, sendtype, root, tag, comm);
455 }
456 /* Root process receives messages and put them in right places */
457 if(rank == root){
458 int real_recvcount;
459 MPI_Status status;
460
461 for(int i=0; i<nprocs; i++){
462 if(i != root){
463 void * ptr = $mpi_pointerAdd(recvbuf, displs[i], recvtype);
464
465 $mpi_collective_recv(ptr, recvcounts[i],
466 recvtype, i, tag, comm, &status, routName);
467 real_recvcount = status.size/sizeofDatatype(recvtype);
468 $assert(real_recvcount == recvcounts[i], "%s asks for equality between"
469 " the amount of data sent and the "
470 "amount of data received.", routName);
471 }
472 }
473 }
474 return 0;
475}
476
477/* Scatter helper function that uses any specified message tag */
478int $mpi_scatter(const void* sendbuf, int sendcount, MPI_Datatype sendtype,
479 void* recvbuf, int recvcount, MPI_Datatype recvtype, int root,
480 int tag, MPI_Comm comm, char * routName){
481 int rank, nprocs;
482
483 rank = $comm_place(comm.col);
484 nprocs = $comm_size(comm.col);
485 /* MPI standard requirement:
486 * For root process, sendtype must be equal to
487 * recvtype. */
488 if(rank == root)
489 $assert(sendtype == recvtype, "MPI_Scatter() asks for equality "
490 "between 'sendtype' and 'recvtype'.");
491 /* MPI_standard requirement:
492 * Only root process can use MPI_IN_PLACE */
493 if(recvbuf == MPI_IN_PLACE){
494 $assert(root == rank, "Only root can replace 'recvbuf' with 'MPI_IN_PLACE'.");
495 }else if(rank == root) {
496 void * ptr;
497
498 $assert(sendcount == recvcount, "Root process of routine %d without using"
499 " MPI_IN_PLACE should give the same value for recvcount and sendcount",
500 routName);
501 ptr = $mpi_pointerAdd(sendbuf, root*recvcount, sendtype);
502 memcpy(recvbuf, ptr, sizeofDatatype(recvtype)*recvcount);
503 }
504 /* Root process scatters data to other processes */
505 if(rank == root){
506 int offset;
507
508 for(int i=0; i<nprocs; i++){
509 if(i != root) {
510 void * ptr;
511
512 offset = i * sendcount;
513 ptr = $mpi_pointerAdd(sendbuf, offset, sendtype);
514 $mpi_collective_send(ptr, sendcount, sendtype, i, tag, comm);
515 }
516 }
517 }
518 /* Non-root processes receive data */
519 if(!(root == rank)){
520 int real_recvcount;
521 MPI_Status status;
522
523 $mpi_collective_recv(recvbuf, recvcount, recvtype,
524 root, tag, comm, &status, routName);
525 real_recvcount = status.size/sizeofDatatype(recvtype);
526 $assert(real_recvcount == recvcount,
527 "%s asks for equality between"
528 " the amount of data sent and the "
529 "amount of data received.", routName);
530 }
531 return 0;
532}
533
534/* Scatterv helper function that uses any specified message tag */
535int $mpi_scatterv(const void* sendbuf, const int sendcounts[], const
536 int displs[], MPI_Datatype sendtype, void* recvbuf,
537 int recvcount, MPI_Datatype recvtype, int root, int tag,
538 MPI_Comm comm, char * routName){
539 int rank, nprocs;
540
541 rank = $comm_place(comm.col);
542 nprocs = $comm_size(comm.col);
543 /* MPI standard requirement:
544 * For root process, sendtype must be equal to
545 * recvtype. */
546 if(rank == root)
547 $assert(sendtype == recvtype, "%s asks for equality "
548 "between 'sendtype' and 'recvtype'.", routName);
549 /* MPI_standard requirement:
550 * Only root process can use MPI_IN_PLACE */
551 if(recvbuf == MPI_IN_PLACE){
552 $assert(root == rank, "Only root can replace 'recvbuf' with 'MPI_IN_PLACE'.");
553 } else if(rank == root) {
554 void * ptr;
555
556 $assert(sendcounts[root] == recvcount, "For routine %s, sendcounts[%d] "
557 "should be same as the recvcount of the process with rank %d.\n",
558 routName, root, root);
559 ptr = $mpi_pointerAdd(sendbuf, displs[root], sendtype);
560 memcpy(recvbuf, ptr, recvcount*sizeofDatatype(recvtype));
561 }
562 /* Root process scatters data to other processes */
563 if(rank == root){
564 for(int i=0; i<nprocs; i++){
565 if(i != root) {
566 void * ptr = $mpi_pointerAdd(sendbuf, displs[i], sendtype);
567
568 $mpi_collective_send(ptr, sendcounts[i], sendtype, i,
569 tag, comm);
570 }
571 }
572 }
573 if(!(root == rank)){
574 MPI_Status status;
575 int real_recvcount;
576
577 $mpi_collective_recv(recvbuf, recvcount, recvtype,
578 root, tag, comm, &status, routName);
579 real_recvcount = status.size/sizeofDatatype(recvtype);
580 $assert(real_recvcount == recvcount, "Process rank:%d\n%s asks for equality between"
581 " the amount of data sent (%d) and the "
582 "amount of data received (%d).", rank, routName, real_recvcount, recvcount);
583 }
584 return 0;
585}
586
587int $mpi_comm_dup($scope scope, MPI_Comm comm, MPI_Comm * newcomm, char * routName) {
588 int place = $comm_place(comm.col);
589 $mpi_gcomm newgcomm;
590 int idx;
591 $scope CMPI_ROOT_SCOPE = $mpi_root_scope(comm.col);
592
593 if(place == 0) {
594 int size = $comm_size(comm.col);
595
596 newgcomm = $mpi_gcomm_create(CMPI_ROOT_SCOPE, size);
597 idx = $mpi_newGcomm(CMPI_ROOT_SCOPE, newgcomm);
598 }
599 $mpi_bcast(&idx, 1, MPI_INT, 0, COMMDUP_TAG,
600 comm, routName);
601 newgcomm = $mpi_getGcomm(CMPI_ROOT_SCOPE, idx);
602 (*newcomm) = $mpi_comm_create(scope, newgcomm, place);
603 newcomm->gcommIndex = idx;
604 $barrier_call(comm.barrier);
605 $gcomm_dup(comm.p2p, newcomm->p2p);
606 $gcomm_dup(comm.col, newcomm->col);
607 $barrier_call(comm.barrier);
608 return 0;
609}
610
611int $mpi_comm_free(MPI_Comm * comm) {
612 int place = $comm_place(comm->col);
613 int size = $comm_size(comm->col);
614 int buf[size];
615 int gcommIndex = comm->gcommIndex;
616 $scope CMPI_ROOT_SCOPE = $mpi_root_scope(comm->col);
617
618 //TODO: $mpi_gather here is just a ugly synchronization
619 $mpi_gather(&place, 1, MPI_INT, buf, 1, MPI_INT, 0,
620 COMMFREE_TAG, (*comm), "MPI_Comm_free synchronization.");
621 $mpi_comm_destroy(*comm);
622 if(place == 0) {
623 $mpi_gcomm temp = $mpi_getGcomm(CMPI_ROOT_SCOPE, gcommIndex);
624
625 $mpi_gcomm_destroy(temp);
626 }
627 return 0;
628}
629
630$bundle $mpi_createCoroutineEntry(int routineTag, int root,
631 int op, int numDatatypes, int * datatypes) {
632 int zero = 0;
633 $bundle bundledEntry;
634 struct Entry {
635 int routine_tag;
636 int root;
637 int op;
638 int numTypes;
639 int datatypes[];
640 }entry;
641
642 entry.routine_tag = routineTag;
643 entry.root = root;
644 entry.op = op;
645 entry.numTypes = numDatatypes;
646 $seq_init(&entry.datatypes, numDatatypes, &zero);
647 for(int i = 0; i < numDatatypes; i++)
648 entry.datatypes[i] = datatypes[i];
649 bundledEntry = $bundle_pack(&entry, sizeof(struct Entry));
650 return bundledEntry;
651}
652
653void $mpi_diffCoroutineEntries($bundle specEntry, $bundle mineEntry, int rank) {
654 struct Entry {
655 int routine_tag;
656 int root;
657 int op;
658 int numTypes;
659 int datatypes[];
660 }spec, mine;
661 char * routine;
662 int numTypes;
663
664 $bundle_unpack(specEntry, &spec);
665 $bundle_unpack(mineEntry, &mine);
666 routine = getCoroutineName(spec.routine_tag);
667 if(spec.routine_tag != mine.routine_tag) {
668 char * mineRoutine = getCoroutineName(mine.routine_tag);
669
670 $assert($false, "Process with rank %d reaches an MPI collective routine "
671 "%s while at least one of others are collectively reaching %s.",
672 rank, mineRoutine, routine);
673 }
674 else if(spec.root != mine.root) {
675 $assert($false, "Process with rank %d reaches an MPI collective routine "
676 "%s which has a different root with at least one of others.", rank, routine);
677 } else if(spec.op != mine.op) {
678 $assert($false, "Process with rank %d reaches an MPI collective routine "
679 "%s which has a different MPI_Op with at least one of others", rank, routine);
680 } else if(spec.numTypes != mine.numTypes) {
681 $assert($false, "Process with rank %d reaches an MPI collective routine "
682 "%s which has an inconsistent datatype specification with at least"
683 " one of others",
684 rank, routine);
685 }
686 numTypes = spec.numTypes;
687 for(int i = 0; i < numTypes; i++)
688 if(spec.datatypes[i] != mine.datatypes[i]) {
689 $assert($false, "Process with rank %d reaches an MPI collective routine "
690 "%s which has an inconsistent datatype specification with at "
691 "least one of others",
692 rank, routine);
693 break;
694 }
695}
696
697/********************* Private helper functions *********************/
698/* Returns the string literal of MPI collective routine names by
699 * giving the unique message tag. */
700char * getCoroutineName(int tag) {
701 switch(tag) {
702 case 9999: return "MPI_Bcast";
703 case 9998: return "MPI_Reduce";
704 case 9997: return "MPI_Allreduce";
705 case 9996: return "MPI_Gather";
706 case 9995: return "MPI_Scatter";
707 case 9994: return "MPI_Gatherv";
708 case 9993: return "MPI_Scatterv";
709 case 9992: return "MPI_Allgather";
710 case 9991: return "MPI_Reduce_scatter";
711 case 9990: return "MPI_Alltoall";
712 case 9989: return "MPI_Alltoallv";
713 case 9988: return "MPI_Alltoallw";
714 case 9987: return "MPI_Barrier";
715 case 9986: return "MPI_Commdup";
716 case 9985: return "MPI_Commfree";
717 default: $assert($false, "Internal Error: Unexpected MPI routine tag:%d.\n", tag);
718 }
719}
720#endif
721
Note: See TracBrowser for help on using the repository browser.