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

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

fix collate_departs bug

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