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: }