Actual source code: tagm.c

  1: #include <petsc/private/petscimpl.h>
  2: #include <petsc/private/hashmapobj.h>
  3: #include <petsc/private/garbagecollector.h>
  4: /* ---------------------------------------------------------------- */
  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:   PetscCommGetNewTag(obj->comm, tag);
 39:   return 0;
 40: }

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

 48:     Collective

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

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

 56:     Level: developer

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


 67:   MPI_Comm_get_attr(comm, Petsc_Counter_keyval, &counter, &flg);

 70:   if (counter->tag < 1) {
 71:     PetscInfo(NULL, "Out of tags for object, starting to recycle. Comm reference count %" PetscInt_FMT "\n", counter->refcount);
 72:     MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_TAG_UB, &maxval, &flg);
 74:     counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
 75:   }

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

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

 90:   Collective

 92:   Input Parameter:
 93: . comm_in - Input communicator

 95:   Output Parameters:
 96: . comm_out - Output communicator

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

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

105: Level: developer

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

114:   PetscSpinlockLock(&PetscCommSpinLock);
115:   MPI_Comm_get_attr(comm_in, Petsc_Counter_keyval, &counter, &flg);

118:   if (counter->comms) {
119:     struct PetscCommStash *pcomms = counter->comms;

121:     *comm_out      = pcomms->comm;
122:     counter->comms = pcomms->next;
123:     PetscFree(pcomms);
124:     PetscInfo(NULL, "Reusing a communicator %ld %ld\n", (long)comm_in, (long)*comm_out);
125:   } else {
126:     MPI_Comm_dup(comm_in, comm_out);
127:   }
128:   PetscSpinlockUnlock(&PetscCommSpinLock);
129:   return 0;
130: }

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

135:   Collective

137:   Input Parameters:
138: +  comm_in - Input communicator
139: -  comm_out - returned communicator

141: Level: developer

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

151:   PetscSpinlockLock(&PetscCommSpinLock);
152:   MPI_Comm_get_attr(comm_in, Petsc_Counter_keyval, &counter, &flg);

155:   PetscMalloc(sizeof(struct PetscCommStash), &ncomm);
156:   ncomm->comm = *comm_out;
157:   ncomm->next = NULL;
158:   pcomms      = counter->comms;
159:   while (pcomms && pcomms->next) pcomms = pcomms->next;
160:   if (pcomms) {
161:     pcomms->next = ncomm;
162:   } else {
163:     counter->comms = ncomm;
164:   }
165:   *comm_out = 0;
166:   PetscSpinlockUnlock(&PetscCommSpinLock);
167:   return 0;
168: }

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

173:    Collective

175:    Input Parameter:
176: .  comm_in - Input communicator

178:    Output Parameters:
179: +  comm_out - Output communicator.  May be comm_in.
180: -  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)

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

189: Level: developer

191: .seealso: `PetscObjectGetNewTag()`, `PetscCommGetNewTag()`, `PetscCommDestroy()`
192: @*/
193: PetscErrorCode PetscCommDuplicate(MPI_Comm comm_in, MPI_Comm *comm_out, PetscMPIInt *first_tag)
194: {
195:   PetscInt64       *cidx;
196:   PetscCommCounter *counter;
197:   PetscMPIInt      *maxval, flg;

199:   PetscSpinlockLock(&PetscCommSpinLock);
200:   MPI_Comm_get_attr(comm_in, Petsc_Counter_keyval, &counter, &flg);

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

223:       /* save PETSc communicator inside user communicator, so we can get it next time */
224:       ucomm.comm = *comm_out; /* ONLY the comm part of the union is significant. */
225:       MPI_Comm_set_attr(comm_in, Petsc_InnerComm_keyval, ucomm.ptr);
226:       ucomm.comm = comm_in;
227:       MPI_Comm_set_attr(*comm_out, Petsc_OuterComm_keyval, ucomm.ptr);
228:     } else {
229:       *comm_out = ucomm.comm;
230:       /* pull out the inner MPI_Comm and hand it back to the caller */
231:       MPI_Comm_get_attr(*comm_out, Petsc_Counter_keyval, &counter, &flg);
233:       PetscInfo(NULL, "Using internal PETSc communicator %ld %ld\n", (long)comm_in, (long)*comm_out);
234:     }
235:   } else *comm_out = comm_in;

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

246:   if (counter->tag < 1) {
247:     PetscInfo(NULL, "Out of tags for object, starting to recycle. Comm reference count %" PetscInt_FMT "\n", counter->refcount);
248:     MPI_Comm_get_attr(MPI_COMM_WORLD, MPI_TAG_UB, &maxval, &flg);
250:     counter->tag = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
251:   }

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

255:   counter->refcount++; /* number of references to this comm */
256:   PetscSpinlockUnlock(&PetscCommSpinLock);
257:   return 0;
258: }

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

263:    Collective

265:    Input Parameter:
266: .  comm - the communicator to free

268:    Level: developer

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

285:   if (*comm == MPI_COMM_NULL) return 0;
286:   PetscSpinlockLock(&PetscCommSpinLock);
287:   MPI_Comm_get_attr(icomm, Petsc_Counter_keyval, &counter, &flg);
288:   if (!flg) { /* not a PETSc comm, check if it has an inner comm */
289:     MPI_Comm_get_attr(icomm, Petsc_InnerComm_keyval, &ucomm, &flg);
291:     icomm = ucomm.comm;
292:     MPI_Comm_get_attr(icomm, Petsc_Counter_keyval, &counter, &flg);
294:   }
295:   counter->refcount--;
296:   if (!counter->refcount) {
297:     /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */
298:     MPI_Comm_get_attr(icomm, Petsc_OuterComm_keyval, &ucomm, &flg);
299:     if (flg) {
300:       ocomm = ucomm.comm;
301:       MPI_Comm_get_attr(ocomm, Petsc_InnerComm_keyval, &ucomm, &flg);
303:       MPI_Comm_delete_attr(ocomm, Petsc_InnerComm_keyval);
304:     }

306:     /* Remove the object creation index on the communicator */
307:     MPI_Comm_get_attr(icomm, Petsc_CreationIdx_keyval, &cidx, &flg);
308:     if (flg) {
309:       PetscFree(cidx);
310:     } else SETERRQ(PETSC_COMM_SELF, PETSC_ERR_ARG_CORRUPT, "MPI_Comm does not have object creation index");

312:     /* Remove garbage hashmap set up by garbage collection */
313:     MPI_Comm_get_attr(icomm, Petsc_Garbage_HMap_keyval, &garbage, &flg);
314:     if (flg) {
315:       PetscInt entries = 0;
316:       PetscHMapObjGetSize(garbage.map, &entries);
317:       if (entries > 0) PetscGarbageCleanup(icomm);
318:       PetscHMapObjDestroy(&(garbage.map));
319:     }

321:     PetscInfo(NULL, "Deleting PETSc MPI_Comm %ld\n", (long)icomm);
322:     MPI_Comm_free(&icomm);
323:   }
324:   *comm = MPI_COMM_NULL;
325:   PetscSpinlockUnlock(&PetscCommSpinLock);
326:   return 0;
327: }

329: /*@C
330:     PetscObjectsListGetGlobalNumbering - computes a global numbering
331:     of `PetscObject`s living on subcommunicators of a given communicator.

333:     Collective.

335:     Input Parameters:
336: +   comm    - the `MPI_Comm`
337: .   len     - local length of objlist
338: -   objlist - a list of PETSc objects living on subcomms of comm and containing this comm rank
339:               (subcomm ordering is assumed to be deadlock-free)

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

345:     Level: developer

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

350: @*/
351: PetscErrorCode PetscObjectsListGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering)
352: {
353:   PetscInt    i, roots, offset;
354:   PetscMPIInt size, rank;

357:   if (!count && !numbering) return 0;

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

391:       MPI_Comm_rank(objlist[i]->comm, &srank);
392:       MPI_Bcast(numbering + i, 1, MPIU_INT, 0, objlist[i]->comm);
393:       if (!srank) ++roots;
394:     }
395:   }
396:   return 0;
397: }