Actual source code: mpitr.c


  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: */

  7: #include <petscsys.h>

  9: #if defined(PETSC_USE_LOG) && !defined(PETSC_HAVE_MPIUNI)

 11: /*@C
 12:    PetscMPIDump - Dumps a listing of incomplete MPI operations, such as sends that
 13:    have never been received, etc.

 15:    Collective on `PETSC_COMM_WORLD`

 17:    Input Parameter:
 18: .  fp - file pointer.  If fp is `NULL`, `stdout` is assumed.

 20:    Options Database Key:
 21: .  -mpidump - Dumps MPI incompleteness during call to PetscFinalize()

 23:     Level: developer

 25: .seealso: `PetscMallocDump()`
 26:  @*/
 27: PetscErrorCode PetscMPIDump(FILE *fd)
 28: {
 29:   PetscMPIInt rank;
 30:   double      tsends, trecvs, work;

 32:   PetscFunctionBegin;
 33:   PetscCallMPI(MPI_Comm_rank(PETSC_COMM_WORLD, &rank));
 34:   if (!fd) fd = PETSC_STDOUT;

 36:   /* Did we wait on all the non-blocking sends and receives? */
 37:   PetscCall(PetscSequentialPhaseBegin(PETSC_COMM_WORLD, 1));
 38:   if (petsc_irecv_ct + petsc_isend_ct != petsc_sum_of_waits_ct) {
 39:     PetscCall(PetscFPrintf(PETSC_COMM_SELF, fd, "[%d]You have not waited on all non-blocking sends and receives", rank));
 40:     PetscCall(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));
 41:     PetscCall(PetscFFlush(fd));
 42:   }
 43:   PetscCall(PetscSequentialPhaseEnd(PETSC_COMM_WORLD, 1));
 44:   /* Did we receive all the messages that we sent? */
 45:   work = petsc_irecv_ct + petsc_recv_ct;
 46:   PetscCallMPI(MPI_Reduce(&work, &trecvs, 1, MPI_DOUBLE, MPI_SUM, 0, PETSC_COMM_WORLD));
 47:   work = petsc_isend_ct + petsc_send_ct;
 48:   PetscCallMPI(MPI_Reduce(&work, &tsends, 1, MPI_DOUBLE, MPI_SUM, 0, PETSC_COMM_WORLD));
 49:   if (rank == 0 && tsends != trecvs) {
 50:     PetscCall(PetscFPrintf(PETSC_COMM_SELF, fd, "Total number sends %g not equal receives %g\n", tsends, trecvs));
 51:     PetscCall(PetscFFlush(fd));
 52:   }
 53:   PetscFunctionReturn(PETSC_SUCCESS);
 54: }

 56: #else

 58: PetscErrorCode PetscMPIDump(FILE *fd)
 59: {
 60:   PetscFunctionBegin;
 61:   PetscFunctionReturn(PETSC_SUCCESS);
 62: }

 64: #endif

 66: #if defined(PETSC_HAVE_MPI_PROCESS_SHARED_MEMORY)
 67: /*
 68:     OpenMPI version of MPI_Win_allocate_shared() does not provide __float128 alignment so we provide
 69:     a utility that insures alignment up to data item size.
 70: */
 71: PetscErrorCode MPIU_Win_allocate_shared(MPI_Aint sz, PetscMPIInt szind, MPI_Info info, MPI_Comm comm, void *ptr, MPI_Win *win)
 72: {
 73:   float *tmp;

 75:   PetscFunctionBegin;
 76:   PetscCallMPI(MPI_Win_allocate_shared(16 + sz, szind, info, comm, &tmp, win));
 77:   tmp += ((size_t)tmp) % szind ? szind / 4 - ((((size_t)tmp) % szind) / 4) : 0;
 78:   *(void **)ptr = (void *)tmp;
 79:   PetscFunctionReturn(PETSC_SUCCESS);
 80: }

 82: PETSC_EXTERN PetscErrorCode MPIU_Win_shared_query(MPI_Win win, PetscMPIInt rank, MPI_Aint *sz, PetscMPIInt *szind, void *ptr)
 83: {
 84:   float *tmp;

 86:   PetscFunctionBegin;
 87:   PetscCallMPI(MPI_Win_shared_query(win, rank, sz, szind, &tmp));
 88:   PetscCheck(*szind > 0, PETSC_COMM_SELF, PETSC_ERR_LIB, "szkind %d must be positive", *szind);
 89:   tmp += ((size_t)tmp) % *szind ? *szind / 4 - ((((size_t)tmp) % *szind) / 4) : 0;
 90:   *(void **)ptr = (void *)tmp;
 91:   PetscFunctionReturn(PETSC_SUCCESS);
 92: }

 94: #endif