fortran/use-mpi-f08: fix mpi_f08 bindings build condition.

ggouaillardet · hppritcha · commit d9e4b07c540a · 2023-12-05T08:32:23.000-07:00
Fortran 2008 bindings can now be built if the Fortran compiler
supports IGNORE_TKR *or* Fortran ISO bindings.

Some other fixes were included in this commit.

Signed-off-by: Gilles Gouaillardet &lt;gilles@rist.or.jp&gt;
diff --git a/config/ompi_config_files.m4 b/config/ompi_config_files.m4
@@ -45,6 +45,7 @@ AC_DEFUN([OMPI_CONFIG_FILES],[
         ompi/mpi/fortran/use-mpi-f08/bindings/Makefile
         ompi/mpi/fortran/use-mpi-f08/ts/Makefile
         ompi/mpi/fortran/use-mpi-f08/mod/Makefile
+        ompi/mpi/fortran/use-mpi-f08/mod/mpi-f08-subarrays-config.h
         ompi/mpi/fortran/use-mpi-f08/mod/mpi-f08-interfaces.h
         ompi/mpi/fortran/use-mpi-f08/mod/mpi-f08-rename.h
         ompi/mpi/fortran/mpiext-use-mpi/Makefile
diff --git a/config/ompi_setup_mpi_fortran.m4 b/config/ompi_setup_mpi_fortran.m4
@@ -449,11 +449,27 @@ end program]])],
     # If we got all the stuff from above, then also look for the new
     # F08 syntax that we can use for the use_mpif08 module.
 
-    # We need to have ignore TKR functionality to build the mpi_f08
+    OMPI_FORTRAN_HAVE_TS=0
+    OMPI_MPI_SUBARRAYS_SUPPORTED=.false.
+    OMPI_MPI_ASYNC_PROTECTS_NONBLOCKING=.false.
+    AS_IF([test $OMPI_TRY_FORTRAN_BINDINGS -ge $OMPI_FORTRAN_USEMPIF08_BINDINGS],
+          [OMPI_FORTRAN_CHECK_TS([OMPI_FORTRAN_HAVE_TS=1])])
+
+    AC_SUBST(OMPI_MPI_SUBARRAYS_SUPPORTED)
+    AC_SUBST(OMPI_MPI_ASYNC_PROTECTS_NONBLOCKING)
+
+    # We need to have ignore TKR or the ISO Fortran bindings functionality to build the mpi_f08
     # module
-    AS_IF([test $OMPI_TRY_FORTRAN_BINDINGS -ge $OMPI_FORTRAN_USEMPIF08_BINDINGS && \
-           test $OMPI_FORTRAN_HAVE_IGNORE_TKR -eq 1],
-          [OMPI_BUILD_FORTRAN_BINDINGS=$OMPI_FORTRAN_USEMPIF08_BINDINGS])
+    AS_IF([test $OMPI_TRY_FORTRAN_BINDINGS -ge $OMPI_FORTRAN_USEMPIF08_BINDINGS],
+          [AS_IF([test $OMPI_FORTRAN_HAVE_IGNORE_TKR -eq 1],
+                 [OMPI_BUILD_FORTRAN_BINDINGS=$OMPI_FORTRAN_USEMPIF08_BINDINGS
+                  OMPI_FORTRAN_F08_PREDECL=$OMPI_FORTRAN_IGNORE_TKR_PREDECL
+                  OMPI_FORTRAN_F08_TYPE=$OMPI_FORTRAN_IGNORE_TKR_TYPE
+                 ])
+           AS_IF([test $OMPI_FORTRAN_HAVE_TS -eq 1],
+                 [OMPI_BUILD_FORTRAN_BINDINGS=$OMPI_FORTRAN_USEMPIF08_BINDINGS
+                  OMPI_MPI_SUBARRAYS_SUPPORTED=.true.
+                  OMPI_MPI_ASYNC_PROTECTS_NONBLOCKING=.true.])])
 
     # The overall "_BIND_C" variable will be set to 1 if we have all
     # the necessary forms of BIND(C)
diff --git a/ompi/include/Makefile.am b/ompi/include/Makefile.am
@@ -42,7 +42,8 @@ include_HEADERS += \
         mpif-handles.h \
         mpif-io-constants.h \
         mpif-io-handles.h \
-        mpif-sentinels.h
+        mpif-sentinels.h \
+        mpif-subarrays-config.h
 
 endif
 
diff --git a/ompi/include/mpif-config.h.in b/ompi/include/mpif-config.h.in
@@ -15,6 +15,8 @@
 !                         reserved.
 ! Copyright (c) 2019      Triad National Security, LLC. All rights
 !                         reserved.
+! Copyright (c) 2019      Research Organization for Information Science
+!                         and Technology (RIST).  All rights reserved.
 ! $COPYRIGHT$
 !
 ! Additional copyrights may follow
@@ -84,4 +86,3 @@
       parameter (MPI_SUBARRAYS_SUPPORTED= .false.)
       ! Hard-coded for .false. for now
       parameter (MPI_ASYNC_PROTECTS_NONBLOCKING = .false.)
-
diff --git a/ompi/include/mpif-subarrays-config.h b/ompi/include/mpif-subarrays-config.h
@@ -0,0 +1,19 @@
+! -*- fortran -*-
+!
+! Copyright (c) 2019      Research Organization for Information Science
+!                         and Technology (RIST).  All rights reserved.
+! $COPYRIGHT$
+!
+! Additional copyrights may follow
+!
+! $HEADER$
+!
+
+!
+! MPI F08 conformance
+!
+      logical MPI_SUBARRAYS_SUPPORTED
+      logical MPI_ASYNC_PROTECTS_NONBLOCKING
+      parameter (MPI_SUBARRAYS_SUPPORTED= .FALSE.) 
+      parameter (MPI_ASYNC_PROTECTS_NONBLOCKING = .FALSE.)
+
diff --git a/ompi/include/mpif.h.in b/ompi/include/mpif.h.in
@@ -11,8 +11,8 @@
 ! Copyright (c) 2004-2005 The Regents of the University of California.
 !                         All rights reserved.
 ! Copyright (c) 2006-2014 Cisco Systems, Inc.  All rights reserved.
-! Copyright (c) 2017      Research Organization for Information Science
-!                         and Technology (RIST). All rights reserved.
+! Copyright (c) 2017-2019 Research Organization for Information Science
+!                         and Technology (RIST).  All rights reserved.
 ! $COPYRIGHT$
 !
 ! Additional copyrights may follow
@@ -54,6 +54,7 @@
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
       include 'mpif-config.h'
+      include 'mpif-subarrays-config.h'
       include 'mpif-constants.h'
       include 'mpif-handles.h'
       include 'mpif-io-constants.h'
diff --git a/ompi/mpi/fortran/use-mpi-f08/mod/Makefile.am b/ompi/mpi/fortran/use-mpi-f08/mod/Makefile.am
@@ -64,7 +64,10 @@ libforce_usempif08_internal_modules_to_be_built_la_SOURCES = \
 
 nodist_noinst_HEADERS = mpi-f08-interfaces.h
 
-noinst_HEADERS = mpi-f08-rename.h
+noinst_HEADERS =  \
+        mpi-f08-subarrays-config.h \
+        mpi-f08-rename.h \
+        mpi-f08-interfaces.h
 
 libforce_usempi_internal_modules_to_be_built.la: libusempif08_internal_modules.la
 
diff --git a/ompi/mpi/fortran/use-mpi-f08/mod/mpi-f08-subarrays-config.h.in b/ompi/mpi/fortran/use-mpi-f08/mod/mpi-f08-subarrays-config.h.in
@@ -0,0 +1,19 @@
+! -*- fortran -*-
+!
+! Copyright (c) 2019      Research Organization for Information Science
+!                         and Technology (RIST).  All rights reserved.
+! $COPYRIGHT$
+!
+! Additional copyrights may follow
+!
+! $HEADER$
+!
+
+!
+! MPI F08 conformance
+!
+      logical MPI_SUBARRAYS_SUPPORTED
+      logical MPI_ASYNC_PROTECTS_NONBLOCKING
+      parameter (MPI_SUBARRAYS_SUPPORTED= @OMPI_MPI_SUBARRAYS_SUPPORTED@)
+      parameter (MPI_ASYNC_PROTECTS_NONBLOCKING = @OMPI_MPI_ASYNC_PROTECTS_NONBLOCKING@)
+
diff --git a/ompi/mpi/fortran/use-mpi-f08/mod/mpi-f08-types.F90 b/ompi/mpi/fortran/use-mpi-f08/mod/mpi-f08-types.F90
@@ -25,6 +25,7 @@ module mpi_f08_types
    use mpi_types
 
    include "mpif-config.h"
+   include "mpi-f08-subarrays-config.h"
    include "mpif-constants.h"
    include "mpif-io-constants.h"
 
diff --git a/ompi/mpi/fortran/use-mpi-f08/ts/bcast_ts.c b/ompi/mpi/fortran/use-mpi-f08/ts/bcast_ts.c
@@ -35,13 +35,17 @@ void ompi_bcast_ts(CFI_cdesc_t* x, MPI_Fint *count, MPI_Fint *datatype,
     MPI_Comm c_comm = PMPI_Comm_f2c(*comm);
     MPI_Datatype c_datatype = NULL, c_type = NULL;
     int c_root = OMPI_FINT_2_INT(*root);
-    void *buffer = x->base_addr;
+    void *buffer = NULL;
     int c_count = 0;
 
     if (OMPI_COMM_IS_INTRA(c_comm) || MPI_PROC_NULL != c_root) {
         c_type = PMPI_Type_f2c(*datatype);
         c_count = OMPI_FINT_2_INT(*count);
-        OMPI_CFI_2_C(x, c_count, c_type, c_datatype, c_ierr);
+        if ((OMPI_COMM_IS_INTER(c_comm) && MPI_PROC_NULL == c_root) || (ompi_comm_rank(c_comm) == c_root)) {
+            OMPI_CFI_2_C_COPY(x, buffer, c_count, c_type, c_datatype, c_ierr);
+        } else {
+            OMPI_CFI_2_C_ALLOC(x, buffer, c_count, c_type, c_datatype, c_ierr);
+        }
         if (MPI_SUCCESS != c_ierr) {
             if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
             OMPI_ERRHANDLER_INVOKE(c_comm, c_ierr, FUNC_NAME)
@@ -54,8 +58,12 @@ void ompi_bcast_ts(CFI_cdesc_t* x, MPI_Fint *count, MPI_Fint *datatype,
                        c_datatype,
                        c_root,
                        c_comm);
-    if (c_datatype != c_type) {
-        ompi_datatype_destroy(&c_datatype);
-    }
     if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
+    if (OMPI_COMM_IS_INTRA(c_comm) || MPI_PROC_NULL != c_root) {
+        if ((OMPI_COMM_IS_INTER(c_comm) && MPI_ROOT == c_root) || (ompi_comm_rank(c_comm) == c_root)) {
+            OMPI_C_2_CFI_FREE(x, buffer, c_count, c_type, c_datatype, c_ierr);
+        } else {
+            OMPI_C_2_CFI_COPY(x, buffer, c_count, c_type, c_datatype, c_ierr);
+        }
+    }
 }
diff --git a/ompi/mpi/fortran/use-mpi-f08/ts/gather_ts.c b/ompi/mpi/fortran/use-mpi-f08/ts/gather_ts.c
@@ -37,8 +37,8 @@ void ompi_gather_ts(CFI_cdesc_t *x1, MPI_Fint *sendcount, MPI_Fint *sendtype,
     MPI_Datatype c_senddatatype = NULL, c_sendtype = NULL;
     void *sendbuf = x1->base_addr;
     int c_sendcount =  0, c_recvcount = 0;
-    MPI_Datatype c_recvtype = NULL;
-    void *recvbuf = x2->base_addr;
+    MPI_Datatype c_recvtype = NULL, c_recvdatatype = NULL;
+    char *recvbuf = NULL;
 
     c_comm = PMPI_Comm_f2c(*comm);
     c_root = OMPI_FINT_2_INT(*root);
@@ -47,7 +47,7 @@ void ompi_gather_ts(CFI_cdesc_t *x1, MPI_Fint *sendcount, MPI_Fint *sendtype,
         if (MPI_ROOT == c_root) {
             c_recvtype = PMPI_Type_f2c(*recvtype);
             c_recvcount = OMPI_FINT_2_INT(*recvcount);
-            OMPI_CFI_CHECK_CONTIGUOUS(x2, c_ierr);
+            OMPI_CFI_2_C_ALLOC(x2, recvbuf, c_recvcount, c_recvtype, c_recvdatatype, c_ierr);
             if (MPI_SUCCESS != c_ierr) {
                 if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
                 OMPI_ERRHANDLER_INVOKE(c_comm, c_ierr, FUNC_NAME)
@@ -67,16 +67,19 @@ void ompi_gather_ts(CFI_cdesc_t *x1, MPI_Fint *sendcount, MPI_Fint *sendtype,
         if (ompi_comm_rank(c_comm) == c_root) {
             c_recvtype = PMPI_Type_f2c(*recvtype);
             c_recvcount = OMPI_FINT_2_INT(*recvcount);
-            OMPI_CFI_CHECK_CONTIGUOUS(x2, c_ierr);
+            if (OMPI_IS_FORTRAN_IN_PLACE(sendbuf)) {
+                sendbuf = MPI_IN_PLACE;
+                OMPI_CFI_2_C_COPY(x2, recvbuf, c_recvcount, c_recvtype, c_recvdatatype, c_ierr);
+            } else {
+                OMPI_CFI_2_C_ALLOC(x2, recvbuf, c_recvcount, c_recvtype, c_recvdatatype, c_ierr);
+            }
             if (MPI_SUCCESS != c_ierr) {
                 if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
                 OMPI_ERRHANDLER_INVOKE(c_comm, c_ierr, FUNC_NAME)
                 return;
             }
         }
-        if (OMPI_IS_FORTRAN_IN_PLACE(sendbuf)) {
-            sendbuf = MPI_IN_PLACE;
-        } else {
+        if (!OMPI_IS_FORTRAN_IN_PLACE(sendbuf)) {
             c_sendtype = PMPI_Type_f2c(*sendtype);
             c_sendcount = OMPI_FINT_2_INT(*sendcount);
             OMPI_CFI_2_C(x1, c_sendcount, c_sendtype, c_senddatatype, c_ierr);
@@ -95,11 +98,15 @@ void ompi_gather_ts(CFI_cdesc_t *x1, MPI_Fint *sendcount, MPI_Fint *sendtype,
     c_ierr = PMPI_Gather(sendbuf, c_sendcount,
                         c_senddatatype, recvbuf,
                         c_recvcount,
-                        c_recvtype,
+                        c_recvdatatype,
                         c_root,
                         c_comm);
     if (c_senddatatype != c_sendtype) {
         ompi_datatype_destroy(&c_senddatatype);
     }
     if (NULL != ierr) *ierr = OMPI_INT_2_FINT(c_ierr);
+    if ((OMPI_COMM_IS_INTER(c_comm) && (MPI_ROOT == c_root)) ||
+        (!OMPI_COMM_IS_INTER(c_comm) && (ompi_comm_rank(c_comm) == c_root))) {
+        OMPI_C_2_CFI_COPY(x2, recvbuf, c_recvcount, c_recvtype, c_recvdatatype, c_ierr);
+    }   
 }
diff --git a/ompi/mpi/fortran/use-mpi-f08/ts/ts.c b/ompi/mpi/fortran/use-mpi-f08/ts/ts.c
@@ -92,3 +92,47 @@ int ompi_ts_create_datatype(CFI_cdesc_t *cdesc, int oldcount, MPI_Datatype oldty
         PMPI_Type_free(&types[j]);
     return mpi_errno;
 }
+
+static void copy(CFI_dim_t *dim, int rank, char * base, char **dest, size_t len) {
+    for (size_t i=0; i<dim->extent; i++) {
+        if (rank > 1) {
+            copy(dim-1, rank-1, base, dest, len);
+        } else {
+            int v;
+            memcpy(*dest, base, len);
+            *dest += len;
+        }
+        base += dim->sm;
+    }
+}
+
+int ompi_ts_copy(CFI_cdesc_t *cdesc, char *buffer) {
+    copy(&cdesc->dim[cdesc->rank - 1], cdesc->rank, cdesc->base_addr, &buffer, cdesc->elem_len);
+    return OMPI_SUCCESS;
+}
+
+static void copy_back(CFI_dim_t *dim, int rank, char * base, char **source, size_t len) {
+    for (size_t i=0; i<dim->extent; i++) {
+        if (rank > 1) {
+            copy_back(dim-1, rank-1, base, source, len);
+        } else {
+            int v;
+            memcpy(base, *source, len);
+            *source += len;
+        }
+        base += dim->sm;
+    }
+}
+
+int ompi_ts_copy_back(char *buffer, CFI_cdesc_t *cdesc) {
+    copy_back(&cdesc->dim[cdesc->rank - 1], cdesc->rank, cdesc->base_addr, &buffer, cdesc->elem_len);
+    return OMPI_SUCCESS;
+}
+
+size_t ompi_ts_size(CFI_cdesc_t *cdesc) {
+    size_t res = cdesc->elem_len;
+    for (int i=0; i<cdesc->rank; i++) {
+         res *= cdesc->dim[i].extent;
+    }
+    return res;
+}
diff --git a/ompi/mpi/fortran/use-mpi-f08/ts/ts.h b/ompi/mpi/fortran/use-mpi-f08/ts/ts.h
@@ -19,21 +19,80 @@
 
 extern int ompi_ts_create_datatype(CFI_cdesc_t *cdesc, int oldcount, MPI_Datatype oldtype, MPI_Datatype *newtype);
 
+extern size_t ompi_ts_size(CFI_cdesc_t *cdesc);
+
+extern int ompi_ts_copy_back(char *buffer, CFI_cdesc_t *cdesc);
+
+extern int ompi_ts_copy(CFI_cdesc_t *cdesc, char *buffer);
+
 #define OMPI_CFI_2_C(x, count, type, datatype, rc)                      \
     do {                                                                \
         datatype = type;                                                \
         if (x->rank != 0 && !CFI_is_contiguous(x)) {                    \
             rc = ompi_ts_create_datatype(x, count, type, &datatype);    \
-            if (MPI_SUCCESS != rc) {                                    \
-                return;                                                 \
-            } else {                                                    \
+            if (MPI_SUCCESS == rc) {                                    \
                 count = 1;                                              \
             }                                                           \
         } else {                                                        \
             rc = MPI_SUCCESS;                                           \
         }                                                               \
     } while (0)
 
+#define OMPI_CFI_2_C_ALLOC(x, buffer, count, type, datatype, rc)        \
+    do {                                                                \
+        datatype = type;                                                \
+        if (x->rank != 0 && !CFI_is_contiguous(x)) {                    \
+            size_t size = ompi_ts_size(x);                              \
+            buffer = malloc(size);                                      \
+            if (NULL == buffer) {                                       \
+                rc = MPI_ERR_NO_MEM;                                    \
+            } else {                                                    \
+                rc = MPI_SUCCESS;                                       \
+            }                                                           \
+        } else {                                                        \
+            buffer = x->base_addr;                                      \
+            rc = MPI_SUCCESS;                                           \
+        }                                                               \
+    } while (0)
+
+#define OMPI_CFI_2_C_COPY(x, buffer, count, type, datatype, rc)         \
+    do {                                                                \
+        datatype = type;                                                \
+        if (x->rank != 0 && !CFI_is_contiguous(x)) {                    \
+            size_t size = ompi_ts_size(x);                              \
+            buffer = malloc(size);                                      \
+            if (NULL == buffer) {                                       \
+                rc = MPI_ERR_NO_MEM;                                    \
+            } else {                                                    \
+                rc = ompi_ts_copy(x, buffer);                           \
+            }                                                           \
+        } else {                                                        \
+            buffer = x->base_addr;                                      \
+            rc = MPI_SUCCESS;                                           \
+        }                                                               \
+    } while (0)
+
+#define OMPI_C_2_CFI_FREE(x, buffer, count, type, datatype, rc)         \
+    do {                                                                \
+        if (buffer != x->base_addr) {                                   \
+            free(buffer);                                               \
+        }                                                               \
+        if (type != datatype) {                                         \
+	    rc = PMPI_Type_free(&datatype);                             \
+        }                                                               \
+    } while (0)
+
+#define OMPI_C_2_CFI_COPY(x, buffer, count, type, datatype, rc)         \
+    do {                                                                \
+        if (buffer != x->base_addr) {                                   \
+	    rc = ompi_ts_copy_back(buffer, x);                          \
+            free(buffer);                                               \
+        }                                                               \
+        if (type != datatype) {                                         \
+	    rc = PMPI_Type_free(&datatype);                             \
+        }                                                               \
+    } while (0)
+
 #define OMPI_CFI_IS_CONTIGUOUS(x)                                       \
     (0 == x->rank || CFI_is_contiguous(x))
 
diff --git a/ompi/mpi/fortran/use-mpi-ignore-tkr/mpi-ignore-tkr.F90 b/ompi/mpi/fortran/use-mpi-ignore-tkr/mpi-ignore-tkr.F90
@@ -28,6 +28,7 @@ module mpi
   use mpi_types
 #endif
   include "mpif-config.h"
+  include "mpif-subarrays-config.h"
   include "mpif-constants.h"
   include "mpif-handles.h"
   include "mpif-io-constants.h"
diff --git a/ompi/mpi/fortran/use-mpi-tkr/mpi.F90 b/ompi/mpi/fortran/use-mpi-tkr/mpi.F90
@@ -29,6 +29,7 @@ module mpi
 #endif
 
   include "mpif-config.h"
+  include "mpif-subarrays-config.h"
   include "mpif-constants.h"
   include "mpif-handles.h"
   include "mpif-io-constants.h"
