Merge pull request #5868 from raffenet/4.0.x-fixes

4.0.x fixes

configure.ac

@@ -4202,6 +4202,12 @@ if test "$enable_f08" = "yes" ; then
     AC_CONFIG_COMMANDS([gen_binding_f08], [$cmd_gen_binding_f08], [cmd_gen_binding_f08="$cmd"])
 fi
 
+case "$host_os" in
+    freebsd*)
+        AC_DEFINE(DELAY_SHM_MUTEX_DESTROY, 1, [Define to workaround interprocess mutex issue on FreeBSD])
+        ;;
+esac
+
 dnl This includes an experimental pkgconfig file for ch3 in the src/pkgconfig
 dnl directory
 AC_CONFIG_FILES([Makefile \

maint/local_python/binding_c.py

@@ -2249,6 +2249,14 @@ def dump_validate_op(op, dt, is_coll):
     if dt:
         G.out.append("} else {")
         G.out.append("    mpi_errno = (*MPIR_OP_HDL_TO_DTYPE_FN(%s)) (%s);" % (op, dt))
+        # check predefined datatype and replace with basic_type if necessary
+        G.out.append("    if (mpi_errno != MPI_SUCCESS) {")
+        G.out.append("        MPI_Datatype alt_dt = MPIR_Op_get_alt_datatype(%s, %s);" % (op, dt))
+        G.out.append("        if (alt_dt != MPI_DATATYPE_NULL) {")
+        G.out.append("            %s = alt_dt;" % dt)
+        G.out.append("            mpi_errno = MPI_SUCCESS;")
+        G.out.append("        }")
+        G.out.append("    }")
     G.out.append("}")
     dump_error_check("")
 

maint/local_python/binding_f08.py

@@ -1128,7 +1128,7 @@ def dump_handle_routines():
             for a in G.f08_handle_list:
                 # e.g. MPI_Comm_eq
                 G.out.append("")
-                G.out.append("FUNCTION MPI_%s_%s(x, y) result(res)" % (a, op))
+                G.out.append("elemental FUNCTION MPI_%s_%s(x, y) result(res)" % (a, op))
                 G.out.append("    TYPE(MPI_%s), INTENT(in) :: x, y" % a)
                 G.out.append("    LOGICAL :: res")
                 if op == "eq":
@@ -1141,7 +1141,7 @@ def dump_handle_routines():
                 for p in [("f08", "f"), ("f", "f08")]:
                     func_name = "MPI_%s_%s_%s_%s" % (a, p[0], op, p[1])
                     G.out.append("")
-                    G.out.append("FUNCTION %s(%s, %s) result(res)" % (func_name, p[0], p[1]))
+                    G.out.append("elemental FUNCTION %s(%s, %s) result(res)" % (func_name, p[0], p[1]))
                     G.out.append("    TYPE(MPI_%s), INTENT(in) :: f08" % a)
                     G.out.append("    INTEGER, INTENT(in) :: f")
                     G.out.append("    LOGICAL :: res")

src/include/mpir_op.h

@@ -220,4 +220,8 @@ extern MPIR_Op_check_dtype_fn *MPIR_Op_check_dtype_table[];
 
 int MPIR_Op_is_commutative(MPI_Op);
 
+/* for some predefined datatypes, e.g. from MPI_Type_create_f90_xxx, we need
+ * use its basic type for operations */
+MPI_Datatype MPIR_Op_get_alt_datatype(MPI_Op op, MPI_Datatype datatype);
+
 #endif /* MPIR_OP_H_INCLUDED */

src/mpi/coll/op/oputil.c

@@ -86,3 +86,25 @@ const char *MPIR_Op_builtin_get_shortname(MPI_Op op)
     }
     return "";
 }
+
+/* for some predefined datatypes, e.g. from MPI_Type_create_f90_xxx, we need
+ * use its basic type for operations */
+MPI_Datatype MPIR_Op_get_alt_datatype(MPI_Op op, MPI_Datatype datatype)
+{
+    MPI_Datatype alt_dt = MPI_DATATYPE_NULL;
+    if (!HANDLE_IS_BUILTIN(datatype)) {
+        MPIR_Datatype *dt_ptr;
+        MPIR_Datatype_get_ptr(datatype, dt_ptr);
+
+        if (dt_ptr && dt_ptr->contents) {
+            int combiner = dt_ptr->contents->combiner;
+            if (combiner == MPI_COMBINER_F90_REAL ||
+                combiner == MPI_COMBINER_F90_COMPLEX || combiner == MPI_COMBINER_F90_INTEGER) {
+                if (MPI_SUCCESS == (*MPIR_OP_HDL_TO_DTYPE_FN(op)) (dt_ptr->basic_type)) {
+                    alt_dt = dt_ptr->basic_type;
+                }
+            }
+        }
+    }
+    return alt_dt;
+}

src/mpi/init/mpir_init.c

@@ -208,6 +208,21 @@ int MPII_Init_thread(int *argc, char ***argv, int user_required, int *provided,
     mpi_errno = MPID_Init(required, &MPIR_ThreadInfo.thread_provided);
     MPIR_ERR_CHECK(mpi_errno);
 
+    /* The current default mechanism of MPIR Process Acquisition Interface is to
+     * break on MPIR_Breakpoint in mpiexec.hydra. Adding a PMI call that need
+     * response from mpiexec will hold the MPI process to provide opportunity for
+     * debugger to attach. Currently, the only effective call is PMI_Barrier.
+     */
+    /* NOTE: potentially we already calls PMI barrier during device business
+     * card exchange. But there may be optimizations that make it not true.
+     * We are adding a separate PMI barrier call here to ensure the debugger
+     * mechanism. And it is also cleaner. If init latency is a concern, we may
+     * add a config option to skip it. But focus on optimize PMI Barrier may
+     * be a better effort.
+     */
+    mpi_errno = MPIR_pmi_barrier();
+    MPIR_ERR_CHECK(mpi_errno);
+
     bool need_init_builtin_comms = true;
 #ifdef ENABLE_LOCAL_SESSION_INIT
     need_init_builtin_comms = is_world_model;

src/mpi/romio/adio/common/ad_flush.c

@@ -14,11 +14,8 @@ void ADIOI_GEN_Flush(ADIO_File fd, int *error_code)
     int err;
     static char myname[] = "ADIOI_GEN_FLUSH";
 
-    /* If MPI_File_sync is a temporally synchronizing sync, the caller can
-     * avoid the 'sync/barrier/sync' process to ensure visibility and just call
-     * 'sync' */
-    if (fd->hints->synchronizing_flush > 0)
-        MPI_Barrier(fd->comm);
+    *error_code = MPI_SUCCESS;
+
     /* the deferred-open optimization may mean that a file has not been opened
      * on this processor */
     /* additionally, if this process did no writes, there is no work to be done */
@@ -29,11 +26,15 @@ void ADIOI_GEN_Flush(ADIO_File fd, int *error_code)
             *error_code = MPIO_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE,
                                                myname, __LINE__, MPI_ERR_IO,
                                                "**io", "**io %s", strerror(errno));
-            return;
+        } else {
+            fd->dirty_write = 0;
         }
         /* --END ERROR HANDLING-- */
     }
-    fd->dirty_write = 0;
 
-    *error_code = MPI_SUCCESS;
+    /* If MPI_File_sync is a temporally synchronizing sync, the caller can
+     * avoid the 'sync/barrier/sync' process to ensure visibility and just call
+     * 'sync' */
+    if (fd->hints->synchronizing_flush > 0)
+        MPI_Barrier(fd->comm);
 }

src/mpid/ch3/channels/sock/src/ch3_progress.c

@@ -4,7 +4,6 @@
  */
 
 #include "mpidi_ch3_impl.h"
-#include "pmi.h"
 #include "mpidu_sock.h"
 #include "utlist.h"
 

src/mpid/ch3/include/mpidimpl.h

@@ -1006,6 +1006,7 @@ int MPIDI_CH3I_Port_destroy(int port_name_tag);
   --------------------------*/
 
 #define MPIDI_MAX_KVS_VALUE_LEN    4096
+#define MPIDI_MAX_JOBID_LEN        1024
 
 /* ------------------------------------------------------------------------- */
 /* mpirma.h (in src/mpi/rma?) */

src/mpid/ch3/src/ch3u_comm_spawn_multiple.c

@@ -25,66 +25,6 @@
    children */
 #define PARENT_PORT_KVSKEY "PARENT_ROOT_PORT_NAME"
 
-/* FIXME: We can avoid these two routines if we define PMI as using 
-   MPI info values */
-/* Turn a SINGLE MPI_Info into an array of PMI_keyvals (return the pointer
-   to the array of PMI keyvals) */
-static int  mpi_to_pmi_keyvals( MPIR_Info *info_ptr, PMI_keyval_t **kv_ptr,
-				int *nkeys_ptr )
-{
-    char key[MPI_MAX_INFO_KEY];
-    PMI_keyval_t *kv = 0;
-    int          i, nkeys = 0, vallen, flag, mpi_errno=MPI_SUCCESS;
-
-    if (!info_ptr || info_ptr->handle == MPI_INFO_NULL) {
-	goto fn_exit;
-    }
-
-    MPIR_Info_get_nkeys_impl( info_ptr, &nkeys );
-    if (nkeys == 0) {
-	goto fn_exit;
-    }
-    kv = (PMI_keyval_t *)MPL_malloc( nkeys * sizeof(PMI_keyval_t), MPL_MEM_DYNAMIC );
-    if (!kv) { MPIR_ERR_POP(mpi_errno); }
-
-    for (i=0; i<nkeys; i++) {
-	mpi_errno = MPIR_Info_get_nthkey_impl( info_ptr, i, key );
-	if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
-	MPIR_Info_get_valuelen_impl( info_ptr, key, &vallen, &flag );
-        MPIR_ERR_CHKANDJUMP1(!flag, mpi_errno, MPI_ERR_OTHER,"**infonokey", "**infonokey %s", key);
-
-	kv[i].key = MPL_strdup(key);
-	kv[i].val = MPL_malloc( vallen + 1, MPL_MEM_DYNAMIC );
-	if (!kv[i].key || !kv[i].val) { 
-	    MPIR_ERR_SETANDJUMP(mpi_errno,MPI_ERR_OTHER,"**nomem" );
-	}
-	MPIR_Info_get_impl( info_ptr, key, vallen+1, kv[i].val, &flag );
-        MPIR_ERR_CHKANDJUMP1(!flag, mpi_errno, MPI_ERR_OTHER,"**infonokey", "**infonokey %s", key);
-	MPL_DBG_MSG_FMT(MPIDI_CH3_DBG_OTHER,TERSE,(MPL_DBG_FDEST,"key: <%s>, value: <%s>\n", kv[i].key, kv[i].val));
-    }
-
- fn_fail:
- fn_exit:
-    *kv_ptr    = kv;
-    *nkeys_ptr = nkeys;
-    return mpi_errno;
-}
-/* Free the entire array of PMI keyvals */
-static void free_pmi_keyvals(PMI_keyval_t **kv, int size, int *counts)
-{
-    int i,j;
-
-    for (i=0; i<size; i++)
-    {
-	for (j=0; j<counts[i]; j++)
-	{
-            MPL_free((char *)kv[i][j].key);
-            MPL_free(kv[i][j].val);
-	}
-        MPL_free(kv[i]);
-    }
-}
-
 /*
  * MPIDI_CH3_Comm_spawn_multiple()
  */
@@ -95,14 +35,12 @@ int MPIDI_Comm_spawn_multiple(int count, char **commands,
                                   **intercomm, int *errcodes) 
 {
     char port_name[MPI_MAX_PORT_NAME];
-    int *info_keyval_sizes=0, i, mpi_errno=MPI_SUCCESS;
-    PMI_keyval_t **info_keyval_vectors=0, preput_keyval_vector;
-    int *pmi_errcodes = 0, pmi_errno;
+    int i, mpi_errno=MPI_SUCCESS;
+    int *pmi_errcodes = 0;
     int total_num_processes, should_accept = 1;
 
     MPIR_FUNC_ENTER;
 
-
     if (comm_ptr->rank == root) {
 	/* create an array for the pmi error codes */
 	total_num_processes = 0;
@@ -126,105 +64,12 @@ int MPIDI_Comm_spawn_multiple(int count, char **commands,
 	/* --END ERROR HANDLING-- */
 
 	/* Spawn the processes */
-#ifdef USE_PMI2_API
-        MPIR_Assert(count > 0);
-        {
-            int *argcs = MPL_malloc(count*sizeof(int), MPL_MEM_DYNAMIC);
-            struct MPIR_Info preput;
-            struct MPIR_Info *preput_p[1] = { &preput };
-
-            MPIR_Assert(argcs);
-            /*
-            info_keyval_sizes = MPL_malloc(count * sizeof(int), MPL_MEM_DYNAMIC);
-            */
-
-            /* FIXME cheating on constness */
-            preput.key = (char *)PARENT_PORT_KVSKEY;
-            preput.value = port_name;
-            preput.next = NULL;
-
-            /* compute argcs array */
-            for (i = 0; i < count; ++i) {
-                argcs[i] = 0;
-                if (argvs != NULL && argvs[i] != NULL) {
-                    while (argvs[i][argcs[i]]) {
-                        ++argcs[i];
-                    }
-                }
-
-                /* a fib for now */
-                /*
-                info_keyval_sizes[i] = 0;
-                */
-            }
-            /* XXX DJG don't need this, PMI API is thread-safe? */
-            /*MPID_THREAD_CS_ENTER(POBJ, MPIR_THREAD_POBJ_PMI_MUTEX);*/
-            /* release the global CS for spawn PMI calls */
-            MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
-            pmi_errno = PMI2_Job_Spawn(count, (const char **)commands,
-                                       argcs, (const char ***)argvs,
-                                       maxprocs,
-                                       info_keyval_sizes, (const MPIR_Info **)info_ptrs,
-                                       1, (const struct MPIR_Info **)preput_p,
-                                       NULL, 0,
-                                       /*jobId, jobIdSize,*/ /* XXX DJG job stuff? */
-                                       pmi_errcodes);
-            MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
-            /*MPID_THREAD_CS_EXIT(POBJ, MPIR_THREAD_POBJ_PMI_MUTEX);*/
-            MPL_free(argcs);
-            if (pmi_errno != PMI2_SUCCESS) {
-                MPIR_ERR_SETANDJUMP1(mpi_errno, MPI_ERR_OTHER,
-                     "**pmi_spawn_multiple", "**pmi_spawn_multiple %d", pmi_errno);
-            }
-        }
-#else
-        /* FIXME: This is *really* awkward.  We should either
-           Fix on MPI-style info data structures for PMI (avoid unnecessary
-           duplication) or add an MPIU_Info_getall(...) that creates
-           the necessary arrays of key/value pairs */
-
-        /* convert the infos into PMI keyvals */
-        info_keyval_sizes   = (int *) MPL_malloc(count * sizeof(int), MPL_MEM_DYNAMIC);
-        info_keyval_vectors = 
-            (PMI_keyval_t**) MPL_malloc(count * sizeof(PMI_keyval_t*), MPL_MEM_DYNAMIC);
-        if (!info_keyval_sizes || !info_keyval_vectors) { 
-            MPIR_ERR_SETANDJUMP(mpi_errno,MPI_ERR_OTHER,"**nomem");
-        }
+        MPIR_PMI_KEYVAL_t preput;
+        preput.key = PARENT_PORT_KVSKEY;
+        preput.val = port_name;
 
-        if (!info_ptrs) {
-            for (i=0; i<count; i++) {
-                info_keyval_vectors[i] = 0;
-                info_keyval_sizes[i]   = 0;
-            }
-        }
-        else {
-            for (i=0; i<count; i++) {
-                mpi_errno = mpi_to_pmi_keyvals( info_ptrs[i], 
-                                                &info_keyval_vectors[i],
-                                                &info_keyval_sizes[i] );
-                if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
-            }
-        }
-
-        preput_keyval_vector.key = PARENT_PORT_KVSKEY;
-        preput_keyval_vector.val = port_name;
-
-
-        MPID_THREAD_CS_ENTER(POBJ, MPIR_THREAD_POBJ_PMI_MUTEX);
-        pmi_errno = PMI_Spawn_multiple(count, (const char **)
-                                       commands, 
-                                       (const char ***) argvs,
-                                       maxprocs, info_keyval_sizes,
-                                       (const PMI_keyval_t **)
-                                       info_keyval_vectors, 1, 
-                                       &preput_keyval_vector,
-                                       pmi_errcodes);
-	MPID_THREAD_CS_EXIT(POBJ, MPIR_THREAD_POBJ_PMI_MUTEX);
-        if (pmi_errno != PMI_SUCCESS) {
-	    MPIR_ERR_SETANDJUMP1(mpi_errno, MPI_ERR_OTHER,
-		 "**pmi_spawn_multiple", "**pmi_spawn_multiple %d", pmi_errno);
-        }
-#endif
+        mpi_errno = MPIR_pmi_spawn_multiple(count, commands, argvs, maxprocs, info_ptrs, 1, &preput, pmi_errcodes);
+        MPIR_ERR_CHECK(mpi_errno);
 
 	if (errcodes != MPI_ERRCODES_IGNORE) {
 	    for (i=0; i<total_num_processes; i++) {
@@ -274,11 +119,6 @@ int MPIDI_Comm_spawn_multiple(int count, char **commands,
     }
 
  fn_exit:
-    if (info_keyval_vectors) {
-	free_pmi_keyvals(info_keyval_vectors, count, info_keyval_sizes);
-	MPL_free(info_keyval_sizes);
-	MPL_free(info_keyval_vectors);
-    }
     MPL_free(pmi_errcodes);
     MPIR_FUNC_EXIT;
     return mpi_errno;

src/mpid/ch3/src/mpid_init.c

@@ -5,8 +5,6 @@
 
 #include "mpidimpl.h"
 
-#define MAX_JOBID_LEN 1024
-
 #if defined(HAVE_LIMITS_H)
 #include <limits.h>
 #endif

src/mpid/ch3/src/mpidi_pg.c

@@ -10,8 +10,6 @@
 #include "pmi.h"
 #endif
 
-#define MAX_JOBID_LEN 1024
-
 /*
 === BEGIN_MPI_T_CVAR_INFO_BLOCK ===
 
@@ -739,12 +737,12 @@ int MPIDI_PG_InitConnKVS( MPIDI_PG_t *pg )
 #ifdef USE_PMI2_API
     int mpi_errno = MPI_SUCCESS;
 
-    pg->connData = (char *)MPL_malloc(MAX_JOBID_LEN, MPL_MEM_STRINGS);
+    pg->connData = (char *)MPL_malloc(MPIDI_MAX_JOBID_LEN, MPL_MEM_STRINGS);
     if (pg->connData == NULL) {
 	MPIR_ERR_SETANDJUMP(mpi_errno,MPI_ERR_OTHER, "**nomem");
     }
 
-    mpi_errno = PMI2_Job_GetId(pg->connData, MAX_JOBID_LEN);
+    mpi_errno = PMI2_Job_GetId(pg->connData, MPIDI_MAX_JOBID_LEN);
     MPIR_ERR_CHECK(mpi_errno);
 #else
     int pmi_errno, kvs_name_sz;