Actual source code: sftype.c

petsc-3.10.5 2019-03-28
Report Typos and Errors
  1:  #include <petsc/private/sfimpl.h>

  3: #if !defined(PETSC_HAVE_MPI_TYPE_GET_ENVELOPE)
  4: #define MPI_Type_get_envelope(datatype,num_ints,num_addrs,num_dtypes,combiner) (*(num_ints)=0,*(num_addrs)=0,*(num_dtypes)=0,*(combiner)=0,1);SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP_SYS,"Need an MPI-2 implementation")
  5: #define MPI_Type_get_contents(datatype,num_ints,num_addrs,num_dtypes,ints,addrs,dtypes) (*(ints)=0,*(addrs)=0,*(dtypes)=0,1);SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP_SYS,"Need an MPI-2 implementation")
  6: #endif
  7: #if !defined(PETSC_HAVE_MPI_COMBINER_DUP) && !defined(MPI_COMBINER_DUP)  /* We have no way to interpret output of MPI_Type_get_envelope without this. */
  8: #  define MPI_COMBINER_DUP   0
  9: #endif
 10: #if !defined(PETSC_HAVE_MPI_COMBINER_NAMED) && !defined(MPI_COMBINER_NAMED)
 11: #define MPI_COMBINER_NAMED -2
 12: #endif
 13: #if !defined(PETSC_HAVE_MPI_COMBINER_CONTIGUOUS) && !defined(MPI_COMBINER_CONTIGUOUS) && MPI_VERSION < 2
 14: #  define MPI_COMBINER_CONTIGUOUS -1
 15: #endif

 17: static PetscErrorCode MPIPetsc_Type_free(MPI_Datatype *a)
 18: {
 19:   PetscMPIInt    nints,naddrs,ntypes,combiner;

 23:   MPI_Type_get_envelope(*a,&nints,&naddrs,&ntypes,&combiner);

 25:   if (combiner != MPI_COMBINER_NAMED) {
 26:     MPI_Type_free(a);
 27:   }

 29:   *a = MPI_DATATYPE_NULL;
 30:   return(0);
 31: }

 33: PetscErrorCode MPIPetsc_Type_unwrap(MPI_Datatype a,MPI_Datatype *atype,PetscBool *flg)
 34: {
 35:   PetscMPIInt    nints,naddrs,ntypes,combiner;

 39:   *flg = PETSC_FALSE;
 40:   *atype = a;
 41:   if (a == MPIU_INT || a == MPIU_REAL || a == MPIU_SCALAR) return(0);
 42:   MPI_Type_get_envelope(a,&nints,&naddrs,&ntypes,&combiner);
 43:   if (combiner == MPI_COMBINER_DUP) {
 44:     PetscMPIInt  ints[1];
 45:     MPI_Aint     addrs[1];
 46:     MPI_Datatype types[1];
 47:     if (nints != 0 || naddrs != 0 || ntypes != 1) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_LIB,"Unexpected returns from MPI_Type_get_envelope()");
 48:     MPI_Type_get_contents(a,0,0,1,ints,addrs,types);
 49:     /* Recursively unwrap dupped types. */
 50:     MPIPetsc_Type_unwrap(types[0],atype,flg);
 51:     if (*flg) {
 52:       /* If the recursive call returns a new type, then that means that atype[0] != types[0] and we're on the hook to
 53:        * free types[0].  Note that this case occurs if combiner(types[0]) is MPI_COMBINER_DUP, so we're safe to
 54:        * directly call MPI_Type_free rather than MPIPetsc_Type_free here. */
 55:       MPI_Type_free(&(types[0]));
 56:     }
 57:     /* In any case, it's up to the caller to free the returned type in this case. */
 58:     *flg = PETSC_TRUE;
 59:   }
 60:   return(0);
 61: }

 63: PetscErrorCode MPIPetsc_Type_compare(MPI_Datatype a,MPI_Datatype b,PetscBool *match)
 64: {
 66:   MPI_Datatype   atype,btype;
 67:   PetscMPIInt    aintcount,aaddrcount,atypecount,acombiner;
 68:   PetscMPIInt    bintcount,baddrcount,btypecount,bcombiner;
 69:   PetscBool      freeatype, freebtype;

 72:   MPIPetsc_Type_unwrap(a,&atype,&freeatype);
 73:   MPIPetsc_Type_unwrap(b,&btype,&freebtype);
 74:   *match = PETSC_FALSE;
 75:   if (atype == btype) {
 76:     *match = PETSC_TRUE;
 77:     goto free_types;
 78:   }
 79:   MPI_Type_get_envelope(atype,&aintcount,&aaddrcount,&atypecount,&acombiner);
 80:   MPI_Type_get_envelope(btype,&bintcount,&baddrcount,&btypecount,&bcombiner);
 81:   if (acombiner == bcombiner && aintcount == bintcount && aaddrcount == baddrcount && atypecount == btypecount && (aintcount > 0 || aaddrcount > 0 || atypecount > 0)) {
 82:     PetscMPIInt  *aints,*bints;
 83:     MPI_Aint     *aaddrs,*baddrs;
 84:     MPI_Datatype *atypes,*btypes;
 85:     PetscInt     i;
 86:     PetscBool    same;
 87:     PetscMalloc6(aintcount,&aints,bintcount,&bints,aaddrcount,&aaddrs,baddrcount,&baddrs,atypecount,&atypes,btypecount,&btypes);
 88:     MPI_Type_get_contents(atype,aintcount,aaddrcount,atypecount,aints,aaddrs,atypes);
 89:     MPI_Type_get_contents(btype,bintcount,baddrcount,btypecount,bints,baddrs,btypes);
 90:     PetscMemcmp(aints,bints,aintcount*sizeof(aints[0]),&same);
 91:     if (same) {
 92:       PetscMemcmp(aaddrs,baddrs,aaddrcount*sizeof(aaddrs[0]),&same);
 93:       if (same) {
 94:         /* Check for identity first */
 95:         PetscMemcmp(atypes,btypes,atypecount*sizeof(atypes[0]),&same);
 96:         if (!same) {
 97:           /* If the atype or btype were not predefined data types, then the types returned from MPI_Type_get_contents
 98:            * will merely be equivalent to the types used in the construction, so we must recursively compare. */
 99:           for (i=0; i<atypecount; i++) {
100:             MPIPetsc_Type_compare(atypes[i],btypes[i],&same);
101:             if (!same) break;
102:           }
103:         }
104:       }
105:     }
106:     for (i=0; i<atypecount; i++) {
107:       MPIPetsc_Type_free(&(atypes[i]));
108:       MPIPetsc_Type_free(&(btypes[i]));
109:     }
110:     PetscFree6(aints,bints,aaddrs,baddrs,atypes,btypes);
111:     if (same) *match = PETSC_TRUE;
112:   }
113: free_types:
114:   if (freeatype) {
115:     MPIPetsc_Type_free(&atype);
116:   }
117:   if (freebtype) {
118:     MPIPetsc_Type_free(&btype);
119:   }
120:   return(0);
121: }

123: /* Check whether a was created via MPI_Type_contiguous from b
124:  *
125:  */
126: PetscErrorCode MPIPetsc_Type_compare_contig(MPI_Datatype a,MPI_Datatype b,PetscInt *n)
127: {
129:   MPI_Datatype   atype,btype;
130:   PetscMPIInt    aintcount,aaddrcount,atypecount,acombiner;
131:   PetscBool      freeatype,freebtype;
133:   MPIPetsc_Type_unwrap(a,&atype,&freeatype);
134:   MPIPetsc_Type_unwrap(b,&btype,&freebtype);
135:   *n = PETSC_FALSE;
136:   if (atype == btype) {
137:     *n = 1;
138:     goto free_types;
139:   }
140:   MPI_Type_get_envelope(atype,&aintcount,&aaddrcount,&atypecount,&acombiner);
141:   if (acombiner == MPI_COMBINER_CONTIGUOUS && aintcount >= 1) {
142:     PetscMPIInt  *aints;
143:     MPI_Aint     *aaddrs;
144:     MPI_Datatype *atypes;
145:     PetscInt      i;
146:     PetscBool     same;
147:     PetscMalloc3(aintcount,&aints,aaddrcount,&aaddrs,atypecount,&atypes);
148:     MPI_Type_get_contents(atype,aintcount,aaddrcount,atypecount,aints,aaddrs,atypes);
149:     /* Check for identity first. */
150:     if (atypes[0] == btype) {
151:       *n = aints[0];
152:     } else {
153:       /* atypes[0] merely has to be equivalent to the type used to create atype. */
154:       MPIPetsc_Type_compare(atypes[0],btype,&same);
155:       if (same) *n = aints[0];
156:     }
157:     for (i=0; i<atypecount; i++) {
158:       MPIPetsc_Type_free(&(atypes[i]));
159:     }
160:     PetscFree3(aints,aaddrs,atypes);
161:   }
162: free_types:
163:   if (freeatype) {
164:     MPIPetsc_Type_free(&atype);
165:   }
166:   if (freebtype) {
167:     MPIPetsc_Type_free(&btype);
168:   }
169:   return(0);
170: }