Actual source code: tagm.c

  1: #include <petsc/private/petscimpl.h>
  2: #include <petsc/private/hashmapobj.h>
  3: #include <petsc/private/garbagecollector.h>

  5: /*
  6:    A simple way to manage tags inside a communicator.

  8:    It uses the attributes to determine if a new communicator
  9:       is needed and to store the available tags.

 11: */

 13: /*@C
 14:     PetscObjectGetNewTag - Gets a unique new tag from a PETSc object. All
 15:     processors that share the object MUST call this routine EXACTLY the same
 16:     number of times.  This tag should only be used with the current objects
 17:     communicator; do NOT use it with any other MPI communicator.

 19:     Collective

 21:     Input Parameter:
 22: .   obj - the PETSc object; this must be cast with a (`PetscObject`), for example,
 23:          `PetscObjectGetNewTag`((`PetscObject`)mat,&tag);

 25:     Output Parameter:
 26: .   tag - the new tag

 28:     Level: developer

 30:     Note:
 31:     This tag is needed if one is writing MPI communication code involving message passing and needs unique MPI tags to ensure the messages are connected to this specific
 32:     object.

 34: .seealso: `PetscCommGetNewTag()`
 35: @*/
 36: PetscErrorCode PetscObjectGetNewTag(PetscObject obj, PetscMPIInt *tag)
 37: {
 38:   PetscFunctionBegin;
 39:   PetscCall(PetscCommGetNewTag(obj->comm, tag));
 40:   PetscFunctionReturn(PETSC_SUCCESS);
 41: }

 43: /*@
 44:     PetscCommGetNewTag - Gets a unique new tag from a PETSc communicator. All
 45:     processors that share the communicator MUST call this routine EXACTLY the same
 46:     number of times.  This tag should only be used with the current objects
 47:     communicator; do NOT use it with any other MPI communicator.

 49:     Collective

 51:     Input Parameter:
 52: .   comm - the MPI communicator

 54:     Output Parameter:
 55: .   tag - the new tag

 57:     Level: developer

 59: .seealso: `PetscObjectGetNewTag()`, `PetscCommDuplicate()`
 60: @*/
 61: PetscErrorCode PetscCommGetNewTag(MPI_Comm comm, PetscMPIInt *tag)
 62: {
 63:   PetscCommCounter *counter;
 64:   PetscMPIInt      *maxval, flg;

 66:   PetscFunctionBegin;

 69:   PetscCallMPI(MPI_Comm_get_attr(comm, Petsc_Counter_keyval, &counter, &flg));
 70:   PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "Bad MPI communicator supplied; must be a PETSc communicator");

 72:   if (counter->tag < 1) {
 73:     PetscCall(PetscInfo(NULL, "Out of tags for object, starting to recycle. Comm reference count %" PetscInt_FMT "\n", counter->refcount));
 74:     PetscCallMPI(MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_TAG_UB, &maxval, &flg));
 75:     PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_LIB, "MPI error: MPI_Comm_get_attr() is not returning a MPI_TAG_UB");
 76:     counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
 77:   }

 79:   *tag = counter->tag--;
 80:   if (PetscDefined(USE_DEBUG)) {
 81:     /*
 82:      Hanging here means that some processes have called PetscCommGetNewTag() and others have not.
 83:      */
 84:     PetscCallMPI(MPI_Barrier(comm));
 85:   }
 86:   PetscFunctionReturn(PETSC_SUCCESS);
 87: }

 89: /*@C
 90:   PetscCommGetComm - get a new MPI communicator from a PETSc communicator that can be passed off to another package

 92:   Collective

 94:   Input Parameter:
 95: . comm_in - Input communicator

 97:   Output Parameter:
 98: . comm_out - Output communicator

100:   Level: developer

102:   Notes:
103:     Use `PetscCommRestoreComm()` to return the communicator when the external package no longer needs it

105:     Certain MPI implementations have `MPI_Comm_free()` that do not work, thus one can run out of available MPI communicators causing
106:     mysterious crashes in the code after running a long time. This routine allows reusing previously obtained MPI communicators that
107:     are no longer needed.

109: .seealso: `PetscObjectGetNewTag()`, `PetscCommGetNewTag()`, `PetscCommDestroy()`, `PetscCommRestoreComm()`
110: @*/
111: PetscErrorCode PetscCommGetComm(MPI_Comm comm_in, MPI_Comm *comm_out)
112: {
113:   PetscCommCounter *counter;
114:   PetscMPIInt       flg;

116:   PetscFunctionBegin;
117:   PetscCall(PetscSpinlockLock(&PetscCommSpinLock));
118:   PetscCallMPI(MPI_Comm_get_attr(comm_in, Petsc_Counter_keyval, &counter, &flg));
119:   PetscCheck(flg, comm_in, PETSC_ERR_ARG_WRONGSTATE, "Requires a PETSc communicator as input, do not use something like MPI_COMM_WORLD");

121:   if (counter->comms) {
122:     struct PetscCommStash *pcomms = counter->comms;

124:     *comm_out      = pcomms->comm;
125:     counter->comms = pcomms->next;
126:     PetscCall(PetscFree(pcomms));
127:     PetscCall(PetscInfo(NULL, "Reusing a communicator %ld %ld\n", (long)comm_in, (long)*comm_out));
128:   } else {
129:     PetscCallMPI(MPI_Comm_dup(comm_in, comm_out));
130:   }
131:   PetscCall(PetscSpinlockUnlock(&PetscCommSpinLock));
132:   PetscFunctionReturn(PETSC_SUCCESS);
133: }

135: /*@C
136:   PetscCommRestoreComm - restores an MPI communicator that was obtained with `PetscCommGetComm()`

138:   Collective

140:   Input Parameters:
141: +  comm_in - Input communicator
142: -  comm_out - returned communicator

144:    Level: developer

146: .seealso: `PetscObjectGetNewTag()`, `PetscCommGetNewTag()`, `PetscCommDestroy()`, `PetscCommRestoreComm()`
147: @*/
148: PetscErrorCode PetscCommRestoreComm(MPI_Comm comm_in, MPI_Comm *comm_out)
149: {
150:   PetscCommCounter      *counter;
151:   PetscMPIInt            flg;
152:   struct PetscCommStash *pcomms, *ncomm;

154:   PetscFunctionBegin;
155:   PetscCall(PetscSpinlockLock(&PetscCommSpinLock));
156:   PetscCallMPI(MPI_Comm_get_attr(comm_in, Petsc_Counter_keyval, &counter, &flg));
157:   PetscCheck(flg, comm_in, PETSC_ERR_ARG_WRONGSTATE, "Requires a PETSc communicator as input, do not use something like MPI_COMM_WORLD");

159:   PetscCall(PetscMalloc(sizeof(struct PetscCommStash), &ncomm));
160:   ncomm->comm = *comm_out;
161:   ncomm->next = NULL;
162:   pcomms      = counter->comms;
163:   while (pcomms && pcomms->next) pcomms = pcomms->next;
164:   if (pcomms) {
165:     pcomms->next = ncomm;
166:   } else {
167:     counter->comms = ncomm;
168:   }
169:   *comm_out = 0;
170:   PetscCall(PetscSpinlockUnlock(&PetscCommSpinLock));
171:   PetscFunctionReturn(PETSC_SUCCESS);
172: }

174: /*@C
175:    PetscCommDuplicate - Duplicates the communicator only if it is not already a PETSc communicator.

177:    Collective

179:    Input Parameter:
180: .  comm_in - Input communicator

182:    Output Parameters:
183: +  comm_out - Output communicator.  May be `comm_in`.
184: -  first_tag - Tag available that has not already been used with this communicator (you may pass in `NULL` if you do not need a tag)

186:    Level: developer

188:    Note:
189:    PETSc communicators are just regular MPI communicators that keep track of which
190:    tags have been used to prevent tag conflict. If you pass a non-PETSc communicator into
191:    a PETSc creation routine it will attach a private communicator for use in the objects communications.
192:    The internal `MPI_Comm` is used to perform all the MPI calls for PETSc, the outer `MPI_Comm` is a user
193:    level `MPI_Comm` that may be performing communication for the user or other library and so IS NOT used by PETSc.

195: .seealso: `PetscObjectGetNewTag()`, `PetscCommGetNewTag()`, `PetscCommDestroy()`
196: @*/
197: PetscErrorCode PetscCommDuplicate(MPI_Comm comm_in, MPI_Comm *comm_out, PetscMPIInt *first_tag)
198: {
199:   PetscInt64       *cidx;
200:   PetscCommCounter *counter;
201:   PetscMPIInt      *maxval, flg;

203:   PetscFunctionBegin;
204:   PetscCall(PetscSpinlockLock(&PetscCommSpinLock));
205:   PetscCallMPI(MPI_Comm_get_attr(comm_in, Petsc_Counter_keyval, &counter, &flg));

207:   if (!flg) { /* this is NOT a PETSc comm */
208:     union
209:     {
210:       MPI_Comm comm;
211:       void    *ptr;
212:     } ucomm;
213:     /* check if this communicator has a PETSc communicator embedded in it */
214:     PetscCallMPI(MPI_Comm_get_attr(comm_in, Petsc_InnerComm_keyval, &ucomm, &flg));
215:     if (!flg) {
216:       /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */
217:       PetscCallMPI(MPI_Comm_dup(comm_in, comm_out));
218:       PetscCallMPI(MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_TAG_UB, &maxval, &flg));
219:       PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_LIB, "MPI error: MPI_Comm_get_attr() is not returning a MPI_TAG_UB");
220:       PetscCall(PetscNew(&counter)); /* all fields of counter are zero'ed */
221:       counter->tag = *maxval;
222:       PetscCallMPI(MPI_Comm_set_attr(*comm_out, Petsc_Counter_keyval, counter));
223:       /* Add an object creation index to the communicator */
224:       PetscCall(PetscNew(&cidx));
225:       PetscCallMPI(MPI_Comm_set_attr(*comm_out, Petsc_CreationIdx_keyval, cidx));
226:       PetscCall(PetscInfo(NULL, "Duplicating a communicator %ld %ld max tags = %d\n", (long)comm_in, (long)*comm_out, *maxval));

228:       /* save PETSc communicator inside user communicator, so we can get it next time */
229:       ucomm.comm = *comm_out; /* ONLY the comm part of the union is significant. */
230:       PetscCallMPI(MPI_Comm_set_attr(comm_in, Petsc_InnerComm_keyval, ucomm.ptr));
231:       ucomm.comm = comm_in;
232:       PetscCallMPI(MPI_Comm_set_attr(*comm_out, Petsc_OuterComm_keyval, ucomm.ptr));
233:     } else {
234:       *comm_out = ucomm.comm;
235:       /* pull out the inner MPI_Comm and hand it back to the caller */
236:       PetscCallMPI(MPI_Comm_get_attr(*comm_out, Petsc_Counter_keyval, &counter, &flg));
237:       PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_PLIB, "Inner PETSc communicator does not have its tag/name counter attribute set");
238:       PetscCall(PetscInfo(NULL, "Using internal PETSc communicator %ld %ld\n", (long)comm_in, (long)*comm_out));
239:     }
240:   } else *comm_out = comm_in;

242:   if (PetscDefined(USE_DEBUG)) {
243:     /*
244:      Hanging here means that some processes have called PetscCommDuplicate() and others have not.
245:      This likely means that a subset of processes in a MPI_Comm have attempted to create a PetscObject!
246:      ALL processes that share a communicator MUST shared objects created from that communicator.
247:      */
248:     PetscCallMPI(MPI_Barrier(comm_in));
249:   }

251:   if (counter->tag < 1) {
252:     PetscCall(PetscInfo(NULL, "Out of tags for object, starting to recycle. Comm reference count %" PetscInt_FMT "\n", counter->refcount));
253:     PetscCallMPI(MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_TAG_UB, &maxval, &flg));
254:     PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_LIB, "MPI error: MPI_Comm_get_attr() is not returning a MPI_TAG_UB");
255:     counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
256:   }

258:   if (first_tag) *first_tag = counter->tag--;

260:   counter->refcount++; /* number of references to this comm */
261:   PetscCall(PetscSpinlockUnlock(&PetscCommSpinLock));
262:   PetscFunctionReturn(PETSC_SUCCESS);
263: }

265: /*@C
266:    PetscCommDestroy - Frees communicator obtained with `PetscCommDuplicate()`.

268:    Collective

270:    Input Parameter:
271: .  comm - the communicator to free

273:    Level: developer

275: .seealso: `PetscCommDuplicate()`
276: @*/
277: PetscErrorCode PetscCommDestroy(MPI_Comm *comm)
278: {
279:   PetscInt64       *cidx;
280:   PetscCommCounter *counter;
281:   PetscMPIInt       flg;
282:   PetscGarbage      garbage;
283:   MPI_Comm          icomm = *comm, ocomm;
284:   union
285:   {
286:     MPI_Comm comm;
287:     void    *ptr;
288:   } ucomm;

290:   PetscFunctionBegin;
291:   if (*comm == MPI_COMM_NULL) PetscFunctionReturn(PETSC_SUCCESS);
292:   PetscCall(PetscSpinlockLock(&PetscCommSpinLock));
293:   PetscCallMPI(MPI_Comm_get_attr(icomm, Petsc_Counter_keyval, &counter, &flg));
294:   if (!flg) { /* not a PETSc comm, check if it has an inner comm */
295:     PetscCallMPI(MPI_Comm_get_attr(icomm, Petsc_InnerComm_keyval, &ucomm, &flg));
296:     PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "MPI_Comm does not have tag/name counter nor does it have inner MPI_Comm");
297:     icomm = ucomm.comm;
298:     PetscCallMPI(MPI_Comm_get_attr(icomm, Petsc_Counter_keyval, &counter, &flg));
299:     PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "Inner MPI_Comm does not have expected tag/name counter, problem with corrupted memory");
300:   }
301:   counter->refcount--;
302:   if (!counter->refcount) {
303:     /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */
304:     PetscCallMPI(MPI_Comm_get_attr(icomm, Petsc_OuterComm_keyval, &ucomm, &flg));
305:     if (flg) {
306:       ocomm = ucomm.comm;
307:       PetscCallMPI(MPI_Comm_get_attr(ocomm, Petsc_InnerComm_keyval, &ucomm, &flg));
308:       PetscCheck(flg, PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "Outer MPI_Comm %ld does not have expected reference to inner comm %ld, problem with corrupted memory", (long int)ocomm, (long int)icomm);
309:       PetscCallMPI(MPI_Comm_delete_attr(ocomm, Petsc_InnerComm_keyval));
310:     }

312:     /* Remove the object creation index on the communicator */
313:     PetscCallMPI(MPI_Comm_get_attr(icomm, Petsc_CreationIdx_keyval, &cidx, &flg));
314:     if (flg) {
315:       PetscCall(PetscFree(cidx));
316:     } else SETERRQ(PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "MPI_Comm does not have object creation index");

318:     /* Remove garbage hashmap set up by garbage collection */
319:     PetscCallMPI(MPI_Comm_get_attr(icomm, Petsc_Garbage_HMap_keyval, &garbage, &flg));
320:     if (flg) {
321:       PetscInt entries = 0;
322:       PetscCall(PetscHMapObjGetSize(garbage.map, &entries));
323:       if (entries > 0) PetscCall(PetscGarbageCleanup(icomm));
324:       PetscCall(PetscHMapObjDestroy(&(garbage.map)));
325:     }

327:     PetscCall(PetscInfo(NULL, "Deleting PETSc MPI_Comm %ld\n", (long)icomm));
328:     PetscCallMPI(MPI_Comm_free(&icomm));
329:   }
330:   *comm = MPI_COMM_NULL;
331:   PetscCall(PetscSpinlockUnlock(&PetscCommSpinLock));
332:   PetscFunctionReturn(PETSC_SUCCESS);
333: }

335: /*@C
336:     PetscObjectsListGetGlobalNumbering - computes a global numbering
337:     of `PetscObject`s living on subcommunicators of a given communicator.

339:     Collective.

341:     Input Parameters:
342: +   comm    - the `MPI_Comm`
343: .   len     - local length of `objlist`
344: -   objlist - a list of PETSc objects living on subcomms of comm and containing this comm rank
345:               (subcomm ordering is assumed to be deadlock-free)

347:     Output Parameters:
348: +   count      - global number of distinct subcommunicators on objlist (may be > len)
349: -   numbering  - global numbers of objlist entries (allocated by user)

351:     Level: developer

353:     Note:
354:     This is needed when PETSc is used with certain languages that do garbage collection to manage object life cycles.

356: @*/
357: PetscErrorCode PetscObjectsListGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering)
358: {
359:   PetscInt    i, roots, offset;
360:   PetscMPIInt size, rank;

362:   PetscFunctionBegin;
364:   if (!count && !numbering) PetscFunctionReturn(PETSC_SUCCESS);

366:   PetscCallMPI(MPI_Comm_size(comm, &size));
367:   PetscCallMPI(MPI_Comm_rank(comm, &rank));
368:   roots = 0;
369:   for (i = 0; i < len; ++i) {
370:     PetscMPIInt srank;
371:     PetscCallMPI(MPI_Comm_rank(objlist[i]->comm, &srank));
372:     /* Am I the root of the i-th subcomm? */
373:     if (!srank) ++roots;
374:   }
375:   if (count) {
376:     /* Obtain the sum of all roots -- the global number of distinct subcomms. */
377:     PetscCall(MPIU_Allreduce(&roots, count, 1, MPIU_INT, MPI_SUM, comm));
378:   }
379:   if (numbering) {
380:     /* Introduce a global numbering for subcomms, initially known only by subcomm roots. */
381:     /*
382:       At each subcomm root number all of the subcomms it owns locally
383:       and make it global by calculating the shift among all of the roots.
384:       The roots are ordered using the comm ordering.
385:     */
386:     PetscCallMPI(MPI_Scan(&roots, &offset, 1, MPIU_INT, MPI_SUM, comm));
387:     offset -= roots;
388:     /* Now we are ready to broadcast global subcomm numbers within each subcomm.*/
389:     /*
390:       This is where the assumption of a deadlock-free ordering of the subcomms is assumed:
391:       broadcast is collective on the subcomm.
392:     */
393:     roots = 0;
394:     for (i = 0; i < len; ++i) {
395:       PetscMPIInt srank;
396:       numbering[i] = offset + roots; /* only meaningful if !srank. */

398:       PetscCallMPI(MPI_Comm_rank(objlist[i]->comm, &srank));
399:       PetscCallMPI(MPI_Bcast(numbering + i, 1, MPIU_INT, 0, objlist[i]->comm));
400:       if (!srank) ++roots;
401:     }
402:   }
403:   PetscFunctionReturn(PETSC_SUCCESS);
404: }