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

1.23 2.0 acw/focus-triggers main test-branch
Last change on this file since 897c8d7 was 5bc08d6, checked in by Ziqing Luo <ziqing@…>, 11 years ago

fix english problem for error reporting

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