Actual source code: mpitr.c

      1: /*
      2:     Code for tracing mistakes in MPI usage. For example, sends that are never received,
      3:   nonblocking messages that are not correctly waited for, etc.
      4: */

      6: #include <petscsys.h>

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

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

     14:   Collective on `PETSC_COMM_WORLD`

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

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

     22:   Level: developer

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

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

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

     55: #else

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

     63: #endif

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

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

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

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

     93: #endif