Date: 2022-03-31T04:46:07+00:00

Actual source code: tagm.c

      1: #include <petsc/private/petscimpl.h>
      2: /* ---------------------------------------------------------------- */
      3: /*
      4:    A simple way to manage tags inside a communicator.

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

      9: */

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

     17:     Collective on PetscObject

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

     23:     Output Parameter:
     24: .   tag - the new tag

     26:     Level: developer

     28: .seealso: PetscCommGetNewTag()
     29: @*/
     30: PetscErrorCode  PetscObjectGetNewTag(PetscObject obj,PetscMPIInt *tag)
     31: {
     32:   PetscCommGetNewTag(obj->comm,tag);
     33:   return 0;
     34: }

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

     42:     Collective

     44:     Input Parameter:
     45: .   comm - the MPI communicator

     47:     Output Parameter:
     48: .   tag - the new tag

     50:     Level: developer

     52: .seealso: PetscObjectGetNewTag(), PetscCommDuplicate()
     53: @*/
     54: PetscErrorCode  PetscCommGetNewTag(MPI_Comm comm,PetscMPIInt *tag)
     55: {
     56:   PetscCommCounter *counter;
     57:   PetscMPIInt      *maxval,flg;

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

     64:   if (counter->tag < 1) {

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

     72:   *tag = counter->tag--;
     73:   if (PetscDefined(USE_DEBUG)) {
     74:     /*
     75:      Hanging here means that some processes have called PetscCommGetNewTag() and others have not.
     76:      */
     77:     MPI_Barrier(comm);
     78:   }
     79:   return 0;
     80: }

     82: /*@C
     83:   PetscCommGetComm - get an MPI communicator from a PETSc communicator that can be passed off to another package

     85:   Collective

     87:   Input Parameter:
     88: . comm_in - Input communicator

     90:   Output Parameters:
     91: . comm_out - Output communicator

     93:   Notes:
     94:     Use PetscCommRestoreComm() to return the communicator when the external package no longer needs it

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

    100: Level: developer

    102: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy(), PetscCommRestoreComm()
    103: @*/
    104: PetscErrorCode  PetscCommGetComm(MPI_Comm comm_in,MPI_Comm *comm_out)
    105: {
    106:   PetscCommCounter *counter;
    107:   PetscMPIInt      flg;

    109:   PetscSpinlockLock(&PetscCommSpinLock);
    110:   MPI_Comm_get_attr(comm_in,Petsc_Counter_keyval,&counter,&flg);

    113:   if (counter->comms) {
    114:     struct PetscCommStash *pcomms = counter->comms;

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

    127: /*@C
    128:   PetscCommRestoreComm - restores an MPI communicator that was obtained with PetscCommGetComm()

    130:   Collective

    132:   Input Parameters:
    133: +  comm_in - Input communicator
    134: -  comm_out - returned communicator

    136: Level: developer

    138: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy(), PetscCommRestoreComm()
    139: @*/
    140: PetscErrorCode PetscCommRestoreComm(MPI_Comm comm_in,MPI_Comm *comm_out)
    141: {
    142:   PetscCommCounter      *counter;
    143:   PetscMPIInt           flg;
    144:   struct PetscCommStash *pcomms,*ncomm;

    146:   PetscSpinlockLock(&PetscCommSpinLock);
    147:   MPI_Comm_get_attr(comm_in,Petsc_Counter_keyval,&counter,&flg);

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

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

    168:   Collective

    170:   Input Parameter:
    171:   . comm_in - Input communicator

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

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

    184: Level: developer

    186: .seealso: PetscObjectGetNewTag(), PetscCommGetNewTag(), PetscCommDestroy()
    187: @*/
    188: PetscErrorCode  PetscCommDuplicate(MPI_Comm comm_in,MPI_Comm *comm_out,PetscMPIInt *first_tag)
    189: {
    190:   PetscCommCounter *counter;
    191:   PetscMPIInt      *maxval,flg;

    193:   PetscSpinlockLock(&PetscCommSpinLock);
    194:   MPI_Comm_get_attr(comm_in,Petsc_Counter_keyval,&counter,&flg);

    196:   if (!flg) {  /* this is NOT a PETSc comm */
    197:     union {MPI_Comm comm; void *ptr;} ucomm;
    198:     /* check if this communicator has a PETSc communicator imbedded in it */
    199:     MPI_Comm_get_attr(comm_in,Petsc_InnerComm_keyval,&ucomm,&flg);
    200:     if (!flg) {
    201:       /* This communicator is not yet known to this system, so we duplicate it and make an internal communicator */
    202:       MPI_Comm_dup(comm_in,comm_out);
    203:       MPI_Comm_get_attr(MPI_COMM_WORLD,MPI_TAG_UB,&maxval,&flg);
    205:       PetscNew(&counter); /* all fields of counter are zero'ed */
    206:       counter->tag = *maxval;
    207:       MPI_Comm_set_attr(*comm_out,Petsc_Counter_keyval,counter);
    208:       PetscInfo(NULL,"Duplicating a communicator %ld %ld max tags = %d\n",(long)comm_in,(long)*comm_out,*maxval);

    210:       /* save PETSc communicator inside user communicator, so we can get it next time */
    211:       ucomm.comm = *comm_out;   /* ONLY the comm part of the union is significant. */
    212:       MPI_Comm_set_attr(comm_in,Petsc_InnerComm_keyval,ucomm.ptr);
    213:       ucomm.comm = comm_in;
    214:       MPI_Comm_set_attr(*comm_out,Petsc_OuterComm_keyval,ucomm.ptr);
    215:     } else {
    216:       *comm_out = ucomm.comm;
    217:       /* pull out the inner MPI_Comm and hand it back to the caller */
    218:       MPI_Comm_get_attr(*comm_out,Petsc_Counter_keyval,&counter,&flg);
    220:       PetscInfo(NULL,"Using internal PETSc communicator %ld %ld\n",(long)comm_in,(long)*comm_out);
    221:     }
    222:   } else *comm_out = comm_in;

    224:   if (PetscDefined(USE_DEBUG)) {
    225:     /*
    226:      Hanging here means that some processes have called PetscCommDuplicate() and others have not.
    227:      This likley means that a subset of processes in a MPI_Comm have attempted to create a PetscObject!
    228:      ALL processes that share a communicator MUST shared objects created from that communicator.
    229:      */
    230:     MPI_Barrier(comm_in);
    231:   }

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

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

    242:   counter->refcount++; /* number of references to this comm */
    243:   PetscSpinlockUnlock(&PetscCommSpinLock);
    244:   return 0;
    245: }

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

    250:    Collective

    252:    Input Parameter:
    253: .  comm - the communicator to free

    255:    Level: developer

    257: .seealso:   PetscCommDuplicate()
    258: @*/
    259: PetscErrorCode  PetscCommDestroy(MPI_Comm *comm)
    260: {
    261:   PetscCommCounter *counter;
    262:   PetscMPIInt      flg;
    263:   MPI_Comm         icomm = *comm,ocomm;
    264:   union {MPI_Comm comm; void *ptr;} ucomm;

    266:   if (*comm == MPI_COMM_NULL) return 0;
    267:   PetscSpinlockLock(&PetscCommSpinLock);
    268:   MPI_Comm_get_attr(icomm,Petsc_Counter_keyval,&counter,&flg);
    269:   if (!flg) { /* not a PETSc comm, check if it has an inner comm */
    270:     MPI_Comm_get_attr(icomm,Petsc_InnerComm_keyval,&ucomm,&flg);
    272:     icomm = ucomm.comm;
    273:     MPI_Comm_get_attr(icomm,Petsc_Counter_keyval,&counter,&flg);
    275:   }

    277:   counter->refcount--;

    279:   if (!counter->refcount) {
    280:     /* if MPI_Comm has outer comm then remove reference to inner MPI_Comm from outer MPI_Comm */
    281:     MPI_Comm_get_attr(icomm,Petsc_OuterComm_keyval,&ucomm,&flg);
    282:     if (flg) {
    283:       ocomm = ucomm.comm;
    284:       MPI_Comm_get_attr(ocomm,Petsc_InnerComm_keyval,&ucomm,&flg);
    285:       if (flg) {
    286:         MPI_Comm_delete_attr(ocomm,Petsc_InnerComm_keyval);
    287:       } else SETERRQ(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);
    288:     }

    290:     PetscInfo(NULL,"Deleting PETSc MPI_Comm %ld\n",(long)icomm);
    291:     MPI_Comm_free(&icomm);
    292:   }
    293:   *comm = MPI_COMM_NULL;
    294:   PetscSpinlockUnlock(&PetscCommSpinLock);
    295:   return 0;
    296: }

    298: /*@C
    299:     PetscObjectsListGetGlobalNumbering - computes a global numbering
    300:     of PetscObjects living on subcommunicators of a given communicator.

    302:     Collective.

    304:     Input Parameters:
    305: +   comm    - MPI_Comm
    306: .   len     - local length of objlist
    307: -   objlist - a list of PETSc objects living on subcomms of comm and containing this comm rank
    308:               (subcomm ordering is assumed to be deadlock-free)

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

    314:     Level: developer

    316: @*/
    317: PetscErrorCode  PetscObjectsListGetGlobalNumbering(MPI_Comm comm, PetscInt len, PetscObject *objlist, PetscInt *count, PetscInt *numbering)
    318: {
    319:   PetscInt       i, roots, offset;
    320:   PetscMPIInt    size, rank;

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

    325:   MPI_Comm_size(comm, &size);
    326:   MPI_Comm_rank(comm, &rank);
    327:   roots = 0;
    328:   for (i = 0; i < len; ++i) {
    329:     PetscMPIInt srank;
    330:     MPI_Comm_rank(objlist[i]->comm, &srank);
    331:     /* Am I the root of the i-th subcomm? */
    332:     if (!srank) ++roots;
    333:   }
    334:   if (count) {
    335:     /* Obtain the sum of all roots -- the global number of distinct subcomms. */
    336:     MPIU_Allreduce(&roots,count,1,MPIU_INT,MPI_SUM,comm);
    337:   }
    338:   if (numbering) {
    339:     /* Introduce a global numbering for subcomms, initially known only by subcomm roots. */
    340:     /*
    341:       At each subcomm root number all of the subcomms it owns locally
    342:       and make it global by calculating the shift among all of the roots.
    343:       The roots are ordered using the comm ordering.
    344:     */
    345:     MPI_Scan(&roots,&offset,1,MPIU_INT,MPI_SUM,comm);
    346:     offset -= roots;
    347:     /* Now we are ready to broadcast global subcomm numbers within each subcomm.*/
    348:     /*
    349:       This is where the assumption of a deadlock-free ordering of the subcomms is assumed:
    350:       broadcast is collective on the subcomm.
    351:     */
    352:     roots = 0;
    353:     for (i = 0; i < len; ++i) {
    354:       PetscMPIInt srank;
    355:       numbering[i] = offset + roots; /* only meaningful if !srank. */

    357:       MPI_Comm_rank(objlist[i]->comm, &srank);
    358:       MPI_Bcast(numbering+i,1,MPIU_INT,0,objlist[i]->comm);
    359:       if (!srank) ++roots;
    360:     }
    361:   }
    362:   return 0;
    363: }