Actual source code: tagm.c

  1: #define PETSC_DLL
  2: /*
  3:       Some PETSc utilites
  4: */
 5:  #include petscsys.h
  6: #if defined(PETSC_HAVE_STDLIB_H)
  7: #include <stdlib.h>
  8: #endif

 10: /* ---------------------------------------------------------------- */
 11: /*
 12:    A simple way to manage tags inside a communicator.  

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

 17:    Notes on the implementation

 19:    The tagvalues to use are stored in a two element array.  The first element
 20:    is the first free tag value.  The second is used to indicate how
 21:    many references of the communicator there, when it equals zero the communicator may be freed.

 23:   
 24: */

 26: static PetscMPIInt Petsc_Tag_keyval       = MPI_KEYVAL_INVALID;
 27: static PetscMPIInt Petsc_InnerComm_keyval = MPI_KEYVAL_INVALID;
 28: static PetscMPIInt Petsc_OuterComm_keyval = MPI_KEYVAL_INVALID;
 32: /*
 33:    Private routine to delete internal tag storage when a communicator is freed.

 35:    This is called by MPI, not by users.


 39: */
 40: PetscMPIInt  Petsc_DelTag(MPI_Comm comm,PetscMPIInt keyval,void* attr_val,void* extra_state)
 41: {

 45:   PetscInfo1(0,"Deleting tag data in an MPI_Comm %ld\n",(long)comm);if (ierr) PetscFunctionReturn((PetscMPIInt)ierr);
 46:   PetscFree(attr_val);if (ierr) PetscFunctionReturn((PetscMPIInt)ierr);
 47:   PetscFunctionReturn(MPI_SUCCESS);
 48: }

 54: /*
 55:   This does not actually free anything, it simply marks when a reference count to an internal MPI_Comm reaches zero and the
 56:   the external MPI_Comm drops its reference to the internal MPI_Comm

 58:   This is called by MPI, not by users.


 62: */
 63: PetscMPIInt  Petsc_DelComm(MPI_Comm comm,PetscMPIInt keyval,void* attr_val,void* extra_state)
 64: {

 68:   PetscInfo1(0,"Deleting PETSc communicator imbedded in a user MPI_Comm %ld\n",(long)comm);if (ierr) PetscFunctionReturn((PetscMPIInt)ierr);
 69:   /* actually don't delete anything because we cannot increase the reference count of the communicator anyways */
 70:   PetscFunctionReturn(MPI_SUCCESS);
 71: }

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

 82:     Collective on PetscObject

 84:     Input Parameter:
 85: .   obj - the PETSc object; this must be cast with a (PetscObject), for example, 
 86:          PetscObjectGetNewTag((PetscObject)mat,&tag);

 88:     Output Parameter:
 89: .   tag - the new tag

 91:     Level: developer

 93:     Concepts: tag^getting
 94:     Concepts: message tag^getting
 95:     Concepts: MPI message tag^getting

 97: .seealso: PetscCommGetNewTag()
 98: @*/
 99: PetscErrorCode  PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
100: {

104:   PetscCommGetNewTag(obj->comm,tag);
105:   return(0);
106: }

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

116:     Collective on comm

118:     Input Parameter:
119: .   comm - the MPI communicator

121:     Output Parameter:
122: .   tag - the new tag

124:     Level: developer

126:     Concepts: tag^getting
127:     Concepts: message tag^getting
128:     Concepts: MPI message tag^getting

130: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
131: @*/
132: PetscErrorCode  PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
133: {
135:   PetscMPIInt    *tagvalp=0,*maxval;
136:   PetscTruth     flg;


141:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
142:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
143:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
144:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
145:   }

147:   MPI_Attr_get(comm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
148:   if (!flg) SETERRQ(PETSC_ERR_ARG_CORRUPT,"Bad MPI communicator supplied; must be a PETSc communicator");

150:   if (tagvalp[0] < 1) {
151:     PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]);
152:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
153:     if (!flg) {
154:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
155:     }
156:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
157:   }

159:   *tag = tagvalp[0]--;
160: #if defined(PETSC_USE_DEBUG)
161:   /* 
162:      Hanging here means that some processes have called PetscCommGetNewTag() and others have not.
163:   */
164:   MPI_Barrier(comm);
165: #endif
166:   return(0);
167: }

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

174:   Collective on MPI_Comm

176:   Input Parameters:
177: . comm_in - Input communicator

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

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

190:   Level: developer

192:   Concepts: communicator^duplicate

194: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag()
195: @*/
196: PetscErrorCode  PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt* first_tag)
197: {
199:   PetscMPIInt    *tagvalp,*maxval;
200:   PetscTruth     flg;

203:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
204:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
205:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
206:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
207:   }
208:   MPI_Attr_get(comm_in,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);

210:   if (!flg) {  /* this is NOT a PETSc comm */
211:     void *ptr;
212:     /* check if this communicator has a PETSc communicator imbedded in it */
213:     MPI_Attr_get(comm_in,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);
214:     if (!flg) {
215:       /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */
216:       MPI_Comm_dup(comm_in,comm_out);
217:       MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
218:       if (!flg) {
219:         SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
220:       }
221:       PetscMalloc(2*sizeof(PetscMPIInt),&tagvalp);
222:       tagvalp[0] = *maxval;
223:       tagvalp[1] = 0;
224:       MPI_Attr_put(*comm_out,Petsc_Tag_keyval,tagvalp);
225:       PetscInfo3(0,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);

227:       /* save PETSc communicator inside user communicator, so we can get it next time */
228:       /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
229:       PetscMemcpy(&ptr,comm_out,sizeof(MPI_Comm));
230:       MPI_Attr_put(comm_in,Petsc_InnerComm_keyval,ptr);
231:       /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
232:       PetscMemcpy(&ptr,&comm_in,sizeof(MPI_Comm));
233:       MPI_Attr_put(*comm_out,Petsc_OuterComm_keyval,ptr);
234:     } else {
235:       /* pull out the inner MPI_Comm and hand it back to the caller */
236:       /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
237:       PetscMemcpy(comm_out,&ptr,sizeof(MPI_Comm));
238:       MPI_Attr_get(*comm_out,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
239:       if (!flg) {
240:         SETERRQ(PETSC_ERR_PLIB,"Inner PETSc communicator does not have its tagvalp attribute set");
241:       }
242:       PetscInfo2(0,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
243:     }
244:   } else {
245:     *comm_out = comm_in;
246:   }

248: #if defined(PETSC_USE_DEBUG)
249:   /* 
250:      Hanging here means that some processes have called PetscCommDuplicate() and others have not.
251:      This likley means that a subset of processes in a MPI_Comm have attempted to create a PetscObject!
252:      ALL processes that share a communicator MUST shared objects created from that communicator.
253:   */
254:   MPI_Barrier(comm_in);
255: #endif

257:   if (tagvalp[0] < 1) {
258:     PetscInfo1(0,"Out of tags for object, starting to recycle. Comm reference count %d\n",tagvalp[1]);
259:     MPI_Attr_get(MPI_COMM_WORLD,MPI_TAG_UB,(void**)&maxval,(PetscMPIInt*)&flg);
260:     if (!flg) {
261:       SETERRQ(PETSC_ERR_LIB,"MPI error: MPI_Attr_get() is not returning a MPI_TAG_UB");
262:     }
263:     tagvalp[0] = *maxval - 128; /* hope that any still active tags were issued right at the beginning of the run */
264:   }

266:   if (first_tag) {
267:     *first_tag = tagvalp[0]--;
268:     PetscInfo1(0,"  returning tag %ld\n",(long)*first_tag);
269:   }
270:   tagvalp[1]++; /* number of references to this comm */
271:   return(0);
272: }

276: /*@C
277:    PetscCommDestroy - Frees communicator.  Use in conjunction with PetscCommDuplicate().

279:    Collective on MPI_Comm

281:    Input Parameter:
282: .  comm - the communicator to free

284:    Level: developer

286:    Concepts: communicator^destroy

288: @*/
289: PetscErrorCode  PetscCommDestroy(MPI_Comm *comm)
290: {
292:   PetscMPIInt    *tagvalp;
293:   PetscTruth     flg;
294:   MPI_Comm       icomm = *comm,ocomm;
295:   void           *ptr;

298:   if (Petsc_Tag_keyval == MPI_KEYVAL_INVALID) {
299:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelTag,&Petsc_Tag_keyval,(void*)0);
300:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_InnerComm_keyval,(void*)0);
301:     MPI_Keyval_create(MPI_NULL_COPY_FN,Petsc_DelComm,&Petsc_OuterComm_keyval,(void*)0);
302:   }
303:   MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
304:   if (!flg) { /* not a PETSc comm, check if it has an inner comm */
305:     MPI_Attr_get(icomm,Petsc_InnerComm_keyval,&ptr,(PetscMPIInt*)&flg);
306:     if (!flg) {
307:       SETERRQ(PETSC_ERR_ARG_CORRUPT,"MPI_Comm does not have tagvalues nor does it have inner MPI_Comm");
308:     }
309:     /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
310:     PetscMemcpy(&icomm,&ptr,sizeof(MPI_Comm));
311:     MPI_Attr_get(icomm,Petsc_Tag_keyval,(void**)&tagvalp,(PetscMPIInt*)&flg);
312:     if (!flg) {
313:       SETERRQ(PETSC_ERR_ARG_CORRUPT,"Inner MPI_Comm does not have expected tagvalues, problem with corrupted memory");
314:     }
315:   }
316:   tagvalp[1]--;
317:   if (!tagvalp[1]) {

319:     /* if MPI_Comm has outter comm then remove reference to inner MPI_Comm from outter MPI_Comm */
320:     MPI_Attr_get(icomm,Petsc_OuterComm_keyval,&ptr,(PetscMPIInt*)&flg);
321:     /*  Use PetscMemcpy() because casting from pointer to integer of different size is not allowed with some compilers  */
322:     PetscMemcpy(&ocomm,&ptr,sizeof(MPI_Comm));
323:     if (flg) {
324:       MPI_Attr_delete(ocomm,Petsc_InnerComm_keyval);
325:     }

327:     PetscInfo1(0,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);
328:     MPI_Comm_free(&icomm);
329:   }
330:   return(0);
331: }