1
2 /*
3 Code for tracing mistakes in MPI usage. For example, sends that are never received,
4 nonblocking messages that are not correctly waited for, etc.
5 */
6
7 #include <petscsys.h> /*I "petscsys.h" I*/
8
9 #if defined(PETSC_USE_LOG) && !defined(PETSC_HAVE_MPIUNI)
10
11 /*@C
12 PetscMPIDump - Dumps a listing of incomplete MPI operations, such as sends that
13 have never been received, etc.
14
15 Collective on PETSC_COMM_WORLD
16
17 Input Parameter:
18 . fp - file pointer. If fp is NULL, stdout is assumed.
19
20 Options Database Key:
21 . -mpidump - Dumps MPI incompleteness during call to PetscFinalize()
22
23 Level: developer
24
25 .seealso: PetscMallocDump()
26 @*/
PetscMPIDump(FILE * fd)27 PetscErrorCode PetscMPIDump(FILE *fd)
28 {
29 PetscErrorCode ierr;
30 PetscMPIInt rank;
31 double tsends,trecvs,work;
32 int err;
33
34 PetscFunctionBegin;
35 ierr = MPI_Comm_rank(PETSC_COMM_WORLD,&rank);CHKERRQ(ierr);
36 if (!fd) fd = PETSC_STDOUT;
37
38 /* Did we wait on all the non-blocking sends and receives? */
39 ierr = PetscSequentialPhaseBegin(PETSC_COMM_WORLD,1);CHKERRQ(ierr);
40 if (petsc_irecv_ct + petsc_isend_ct != petsc_sum_of_waits_ct) {
41 ierr = PetscFPrintf(PETSC_COMM_SELF,fd,"[%d]You have not waited on all non-blocking sends and receives",rank);CHKERRQ(ierr);
42 ierr = PetscFPrintf(PETSC_COMM_SELF,fd,"[%d]Number non-blocking sends %g receives %g number of waits %g\n",rank,petsc_isend_ct,petsc_irecv_ct,petsc_sum_of_waits_ct);CHKERRQ(ierr);
43 err = fflush(fd);
44 if (err) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SYS,"fflush() failed on file");
45 }
46 ierr = PetscSequentialPhaseEnd(PETSC_COMM_WORLD,1);CHKERRQ(ierr);
47 /* Did we receive all the messages that we sent? */
48 work = petsc_irecv_ct + petsc_recv_ct;
49 ierr = MPI_Reduce(&work,&trecvs,1,MPI_DOUBLE,MPI_SUM,0,PETSC_COMM_WORLD);CHKERRQ(ierr);
50 work = petsc_isend_ct + petsc_send_ct;
51 ierr = MPI_Reduce(&work,&tsends,1,MPI_DOUBLE,MPI_SUM,0,PETSC_COMM_WORLD);CHKERRQ(ierr);
52 if (!rank && tsends != trecvs) {
53 ierr = PetscFPrintf(PETSC_COMM_SELF,fd,"Total number sends %g not equal receives %g\n",tsends,trecvs);CHKERRQ(ierr);
54 err = fflush(fd);
55 if (err) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SYS,"fflush() failed on file");
56 }
57 PetscFunctionReturn(0);
58 }
59
60 #else
61
PetscMPIDump(FILE * fd)62 PetscErrorCode PetscMPIDump(FILE *fd)
63 {
64 PetscFunctionBegin;
65 PetscFunctionReturn(0);
66 }
67
68 #endif
69
70 #if defined(PETSC_HAVE_MPI_PROCESS_SHARED_MEMORY)
71 /*
72 OpenMPI version of MPI_Win_allocate_shared() does not provide __float128 alignment so we provide
73 a utility that insures alignment up to data item size.
74 */
MPIU_Win_allocate_shared(MPI_Aint sz,PetscMPIInt szind,MPI_Info info,MPI_Comm comm,void * ptr,MPI_Win * win)75 PetscErrorCode MPIU_Win_allocate_shared(MPI_Aint sz,PetscMPIInt szind,MPI_Info info,MPI_Comm comm,void *ptr,MPI_Win *win)
76 {
77 PetscErrorCode ierr;
78 float *tmp;
79
80 PetscFunctionBegin;
81 ierr = MPI_Win_allocate_shared(16+sz,szind,info,comm,&tmp,win);CHKERRQ(ierr);
82 tmp += ((size_t)tmp) % szind ? szind/4 - ((((size_t)tmp) % szind)/4) : 0;
83 *(void**)ptr = (void*)tmp;
84 PetscFunctionReturn(0);
85 return 0;
86 }
87
MPIU_Win_shared_query(MPI_Win win,PetscMPIInt rank,MPI_Aint * sz,PetscMPIInt * szind,void * ptr)88 PETSC_EXTERN PetscErrorCode MPIU_Win_shared_query(MPI_Win win,PetscMPIInt rank,MPI_Aint *sz,PetscMPIInt *szind,void *ptr)
89 {
90 PetscErrorCode ierr;
91 float *tmp;
92
93 PetscFunctionBegin;
94 ierr = MPI_Win_shared_query(win,rank,sz,szind,&tmp);CHKERRQ(ierr);
95 if (*szind <= 0) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"szkind %d must be positive\n",*szind);
96 tmp += ((size_t)tmp) % *szind ? *szind/4 - ((((size_t)tmp) % *szind)/4) : 0;
97 *(void**)ptr = (void*)tmp;
98 PetscFunctionReturn(0);
99 }
100
101 #endif
102
103
104
105
106
107
108
109