[open-coarrays] 35/80: Upstream 1.7.4 release
Alastair McKinstry
mckinstry at moszumanska.debian.org
Wed Oct 25 13:45:47 UTC 2017
This is an automated email from the git hooks/post-receive script.
mckinstry pushed a commit to branch debian/master
in repository open-coarrays.
commit bd3531a5b519fb3ff3fe8efb3a9dcaf6b53d03cb
Author: Alastair McKinstry <mckinstry at debian.org>
Date: Fri Nov 4 01:35:53 2016 +0000
Upstream 1.7.4 release
---
CMakeLists.txt | 3 +-
install.sh | 1 -
install.sh-usage | 2 +-
prerequisites/acceptable_compiler.f90 | 2 +-
prerequisites/build-functions/build_and_install.sh | 7 +
.../build-functions/download_if_necessary.sh | 54 +-
prerequisites/build-functions/ftp-url.sh | 26 +-
prerequisites/build-functions/set_or_print_url.sh | 8 +-
prerequisites/build.sh | 4 +-
prerequisites/build.sh-usage | 2 +-
prerequisites/install-functions/find_or_install.sh | 45 +-
src/libcaf.h | 111 +-
src/mpi/mpi_caf.c | 1440 +++++++++++++++++++-
src/tests/integration/CMakeLists.txt | 1 +
src/tests/integration/events/CMakeLists.txt | 2 +
src/tests/integration/events/async-hello.f90 | 77 ++
src/tests/unit/send-get/get_with_offset_1d.f90 | 2 +-
17 files changed, 1646 insertions(+), 141 deletions(-)
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 709ad5b..0c293b0 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -7,7 +7,7 @@ set ( CMAKE_BUILD_TYPE "Release"
set_property ( CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS ${CMAKE_CONFIGURATION_TYPES} )
#Name project and specify source languages
-project(opencoarrays VERSION 1.7.0 LANGUAGES C Fortran)
+project(opencoarrays VERSION 1.7.4 LANGUAGES C Fortran)
#Print an error message on an attempt to build inside the source directory tree:
if ("${CMAKE_CURRENT_SOURCE_DIR}" STREQUAL "${CMAKE_CURRENT_BINARY_DIR}")
@@ -208,6 +208,7 @@ if(opencoarrays_aware_compiler)
add_mpi_test(hello_multiverse 2 ${tests_root}/integration/coarrayHelloWorld/hello_multiverse)
add_mpi_test(coarray_burgers_pde 2 ${tests_root}/integration/pde_solvers/coarrayBurgers/coarray_burgers_pde)
add_mpi_test(co_heat 2 ${tests_root}/integration/pde_solvers/coarrayHeatSimplified/co_heat)
+ add_mpi_test(asynchronous_hello_world 2 ${tests_root}/integration/events/asynchronous_hello_world)
if ( ("${CMAKE_SYSTEM_PROCESSOR}" MATCHES "x86_64") AND ("${CMAKE_SYSTEM_NAME}" MATCHES "Linux") )
if ( NOT (DEFINED ENV{TRAVIS}))
add_mpi_test(coarray_navier_stokes 2 ${tests_root}/integration/pde_solvers/navier-stokes/coarray_navier_stokes)
diff --git a/install.sh b/install.sh
index 1e2645c..a764b92 100755
--- a/install.sh
+++ b/install.sh
@@ -296,7 +296,6 @@ elif [[ "${arg_p:-}" == "opencoarrays" ]]; then
# shellcheck source=./prerequisites/build-functions/set_SUDO_if_needed_to_write_to_directory.sh
source "${OPENCOARRAYS_SRC_DIR:-}/prerequisites/build-functions/set_SUDO_if_needed_to_write_to_directory.sh"
version="$("${opencoarrays_src_dir}/install.sh" -V opencoarrays)"
- install_path="${install_path}/opencoarrays/${version}"
set_SUDO_if_needed_to_write_to_directory "${install_path}"
build_opencoarrays 2>&1 | tee ../"${installation_record}"
report_results 2>&1 | tee -a ../"${installation_record}"
diff --git a/install.sh-usage b/install.sh-usage
index c81e66d..bcd5c1d 100644
--- a/install.sh-usage
+++ b/install.sh-usage
@@ -1,4 +1,4 @@
- -b --branch [arg] Install the specified repository development branch.
+ -b --install-branch [arg] Install the specified repository development branch.
-B --list-branches [arg] List the available branches in the specified package's repository.
-c --with-c [arg] Use specified C compiler.
-C --with-cxx [arg] Use specified C++ compiler.
diff --git a/prerequisites/acceptable_compiler.f90 b/prerequisites/acceptable_compiler.f90
index 404c4f4..159b491 100644
--- a/prerequisites/acceptable_compiler.f90
+++ b/prerequisites/acceptable_compiler.f90
@@ -35,5 +35,5 @@
program main
use iso_fortran_env, only : compiler_version
implicit none
- print *,compiler_version() >= "GCC version 6.1.0 "
+ print *,(compiler_version() >= "GCC version 6.1.0 ") .and. (compiler_version() < "GCC version 7.0.0 ")
end program
diff --git a/prerequisites/build-functions/build_and_install.sh b/prerequisites/build-functions/build_and_install.sh
index 2a8cc63..211118f 100644
--- a/prerequisites/build-functions/build_and_install.sh
+++ b/prerequisites/build-functions/build_and_install.sh
@@ -17,6 +17,13 @@ build_and_install()
if [[ "${package_to_build}" == "gcc" ]]; then
info "pushd ${download_path}/${package_source_directory} "
pushd "${download_path}/${package_source_directory}"
+ arg_string="${args[@]:-}"
+ if [[ "$(uname)" == "Linux" ]]; then
+ sed -i'' "s/wget/${fetch} ${arg_string}/g" "${PWD}/contrib/download_prerequisites"
+ else
+ # This works on OS X and other POSIX-compliant operating systems:
+ sed -i '' "s/wget/${fetch} ${arg_string}/g" "${PWD}/contrib/download_prerequisites"
+ fi
"${PWD}"/contrib/download_prerequisites
info "popd"
popd
diff --git a/prerequisites/build-functions/download_if_necessary.sh b/prerequisites/build-functions/download_if_necessary.sh
index 53e881f..3eac265 100644
--- a/prerequisites/build-functions/download_if_necessary.sh
+++ b/prerequisites/build-functions/download_if_necessary.sh
@@ -10,6 +10,32 @@ download_if_necessary()
{
download_path="${OPENCOARRAYS_SRC_DIR}/prerequisites/downloads"
set_SUDO_if_needed_to_write_to_directory "${download_path}"
+
+ # We set args regardless of whether this function performs a download because
+ # GCC builds will need this to modify GCC's contrib/download_prerequisites script
+ if [[ "${fetch}" == "svn" ]]; then
+ if [[ "${arg_B:-}" == "gcc" ]]; then
+ args=("ls")
+ else
+ args=("checkout")
+ fi
+ elif [[ "${fetch}" == "wget" ]]; then
+ args=("--no-check-certificate")
+ elif [[ "${fetch}" == "ftp-url" ]]; then
+ args=("-n")
+ elif [[ "${fetch}" == "git" ]]; then
+ args=("clone")
+ elif [[ "${fetch}" == "curl" ]]; then
+ first_three_characters=$(echo "${package_url}" | cut -c1-3)
+ if [[ "${first_three_characters}" == "ftp" ]]; then
+ args=("-LO" "-u" "anonymous:")
+ elif [[ "${first_three_characters}" == "htt" ]]; then
+ args=("-LO")
+ else
+ emergency "download_if_necessary.sh: Unrecognized URL."
+ fi
+ fi
+
if [[ -f "${download_path}/${url_tail}" || -d "${download_path}/${url_tail}" ]] ; then
info "Found '${url_tail}' in ${download_path}."
info "If it resulted from an incomplete download, building ${package_name} could fail."
@@ -35,29 +61,6 @@ download_if_necessary()
info "Place the downloaded file in ${download_path} and restart this script."
emergency "Aborting [exit 90]"
else
- # The download mechanism is in the path.
- if [[ "${fetch}" == "svn" ]]; then
- if [[ "${arg_B:-}" == "gcc" ]]; then
- args="ls"
- else
- args="checkout"
- fi
- elif [[ "${fetch}" == "wget" ]]; then
- args="--no-check-certificate"
- elif [[ "${fetch}" == "ftp-url" ]]; then
- args="-n"
- elif [[ "${fetch}" == "git" ]]; then
- args="clone"
- elif [[ "${fetch}" == "curl" ]]; then
- first_three_characters=$(echo "${package_url}" | cut -c1-3)
- if [[ "${first_three_characters}" == "ftp" ]]; then
- args="-LO -u anonymous:"
- elif [[ "${first_three_characters}" == "htt" ]]; then
- args="-LO"
- else
- emergency "download_if_necessary.sh: Unrecognized URL."
- fi
- fi
if [[ "${fetch}" == "svn" || "${fetch}" == "git" ]]; then
package_source_directory="${url_tail}"
@@ -66,11 +69,10 @@ download_if_necessary()
fi
info "Downloading ${package_name} ${version_to_build-} to the following location:"
info "${download_path}/${package_source_directory}"
- info "Download command: \"${fetch}\" ${args:-} ${package_url}"
+ info "Download command: \"${fetch}\" ${args[@]:-} ${package_url}"
info "Depending on the file size and network bandwidth, this could take several minutes or longer."
pushd "${download_path}"
- # args should be an array. Then "${args[@]:-}" will prevent shellcheck from complaining
- "${fetch}" ${args:-} "${package_url}"
+ "${fetch}" ${args[@]:-} "${package_url}"
popd
if [[ ! -z "${arg_B:-}" ]]; then
return
diff --git a/prerequisites/build-functions/ftp-url.sh b/prerequisites/build-functions/ftp-url.sh
index f9756f5..0ac426c 100644
--- a/prerequisites/build-functions/ftp-url.sh
+++ b/prerequisites/build-functions/ftp-url.sh
@@ -1,28 +1,34 @@
# Download a file from an anonymous ftp site
#
# Usage:
-# ftp-url <ftp-mode> <ftp-site-address>:/<path-to-file>/<file-name>
+# ftp-url <ftp-mode> ftp://<fully-qualified-domain>:/<path-to-file>/<file-name>
#
# Example:
-# ftp-url -n ftp.gnu.org:/gnu/m4/m4-1.4.17.tar.bz2
+# ftp-url -n ftp://ftp.gnu.org:/gnu/gcc/gcc-6.1.0/gcc-6.1.0.tar.bz2
ftp-url()
{
ftp_mode="${1}"
url="${2}"
- text_before_colon="${url%%:*}"
- FTP_SERVER="${text_before_colon}"
+ if [[ "${ftp_mode}" != "-n" ]]; then
+ emergency "Unexpected ftp mode received by ftp-url.sh: ${ftp_mode}"
+ fi
- text_after_colon="${url##*:}"
- text_after_final_slash="${text_after_colon##*/}"
- FILE_NAME="${text_after_final_slash}"
+ protocol="${url%%:*}" # grab text_before_first_colon
+ if [[ "${protocol}" != "ftp" ]]; then
+ emergency "URL with unexpected protocol received by ftp-url.sh: ${text_before_first_colon}"
+ fi
- text_before_final_slash="${text_after_colon%/*}"
- FILE_PATH="${text_before_final_slash}"
+ text_after_double_slash="${url##*//}"
+ FTP_SERVER="${text_after_double_slash%:*}" # grab remaining text before colon
+
+ text_after_final_colon="${url##*:}"
+ FILE_NAME="${url##*/}" # grab text after final slash
+ FILE_PATH="${text_after_final_colon%/*}" # grab remaining text before final slash
USERNAME=anonymous
PASSWORD=""
- info "starting anonymous download: ftp ${ftp_mode} ${FTP_SERVER}... cd ${FILE_PATH}... get ${FILE_NAME}"
+ info "starting anonymous download: ${protocol} ${ftp_mode} ${FTP_SERVER}... cd ${FILE_PATH}... get ${FILE_NAME}"
ftp "${ftp_mode}" "${FTP_SERVER}" <<Done-ftp
user "${USERNAME}" "${PASSWORD}"
diff --git a/prerequisites/build-functions/set_or_print_url.sh b/prerequisites/build-functions/set_or_print_url.sh
index ffe68ef..139178c 100644
--- a/prerequisites/build-functions/set_or_print_url.sh
+++ b/prerequisites/build-functions/set_or_print_url.sh
@@ -14,20 +14,20 @@ set_or_print_url()
major_minor="${version_to_build%.*}"
elif [[ "${package_to_build}" == "gcc" ]]; then
if [[ -z "${arg_b:-${arg_B}}" ]]; then
- gcc_url_head="ftp.gnu.org:/gnu/gcc/gcc-${version_to_build}/"
+ gcc_url_head="ftp://ftp.gnu.org:/gnu/gcc/gcc-${version_to_build}/"
else
gcc_url_head="svn://gcc.gnu.org/svn/gcc/"
fi
fi
package_url_head=(
"gcc;${gcc_url_head-}"
- "wget;ftp.gnu.org:/gnu/wget/"
- "m4;ftp.gnu.org:/gnu/m4/"
+ "wget;ftp://ftp.gnu.org:/gnu/wget/"
+ "m4;ftp://ftp.gnu.org:/gnu/m4/"
"pkg-config;http://pkgconfig.freedesktop.org/releases/"
"mpich;http://www.mpich.org/static/downloads/${version_to_build-}/"
"flex;http://sourceforge.net/projects/flex/files/"
"make;ftp://ftp.gnu.org/gnu/make/"
- "bison;ftp.gnu.org:/gnu/bison/"
+ "bison;ftp://ftp.gnu.org:/gnu/bison/"
"cmake;http://www.cmake.org/files/v${major_minor-}/"
"subversion;http://www.eu.apache.org/dist/subversion/"
)
diff --git a/prerequisites/build.sh b/prerequisites/build.sh
index b83d458..7d6364d 100755
--- a/prerequisites/build.sh
+++ b/prerequisites/build.sh
@@ -88,7 +88,7 @@ info "__os: ${__os}"
info "__usage: ${__usage}"
info "LOG_LEVEL: ${LOG_LEVEL}"
-info "-b (--branch): ${arg_b} "
+info "-b (--install-branch): ${arg_b} "
info "-B (--list-branches): ${arg_B} "
info "-c (--with-c): ${arg_c} "
info "-C (--with-cxx): ${arg_C} "
@@ -149,7 +149,7 @@ if [[ -z "${arg_B}" ]]; then
# shellcheck source=./build-functions/set_compilers.sh
source "${OPENCOARRAYS_SRC_DIR:-}/prerequisites/build-functions/set_compilers.sh"
set_compilers
-
+
# shellcheck source=./build-functions/build_and_install.sh
source "${OPENCOARRAYS_SRC_DIR:-}/prerequisites/build-functions/build_and_install.sh"
build_and_install
diff --git a/prerequisites/build.sh-usage b/prerequisites/build.sh-usage
index 0ac2287..ed08869 100644
--- a/prerequisites/build.sh-usage
+++ b/prerequisites/build.sh-usage
@@ -8,8 +8,8 @@
-f --with-fortran [arg] Specify Fortran compiler location. Default="gfortran"
-h --help This page.
-i --install-prefix [arg] Install package in specified path. Default="${OPENCOARRAYS_SRC_DIR%/}/prerequisites/installations/"
- -j --num-threads [arg] Number of threads to use when invoking make. Default="1"
-I --install-version [arg] Package version to install. (To see default, use -V or --print-version)
+ -j --num-threads [arg] Number of threads to use when invoking make. Default="1"
-l --list-packages List the packages this script can install.
-m --with-cmake [arg] Use the specified CMake installation. Default="cmake"
-M --with-mpi [arg] Use the specified MPI installation.
diff --git a/prerequisites/install-functions/find_or_install.sh b/prerequisites/install-functions/find_or_install.sh
index 4e0734e..5229677 100644
--- a/prerequisites/install-functions/find_or_install.sh
+++ b/prerequisites/install-functions/find_or_install.sh
@@ -163,14 +163,17 @@ find_or_install()
else
- echo -e "$this_script: Checking whether $executable in PATH wraps gfortran version $(./build.sh -V gcc) or later... "
- $executable acceptable_compiler.f90 -o acceptable_compiler
- $executable print_true.f90 -o print_true
- acceptable=$(./acceptable_compiler)
- is_true=$(./print_true)
- rm acceptable_compiler print_true
-
- if [[ "$acceptable" == "$is_true" ]]; then
+ info "$this_script: Checking whether $executable in PATH wraps gfortran version >= $(./build.sh -V gcc) and < 7.0.0 ... "
+ $executable acceptable_compiler.f90 -o acceptable_compiler || true;
+ $executable print_true.f90 -o print_true || true;
+ if [[ -f ./acceptable_compiler && -f ./print_true ]]; then
+ acceptable=$(./acceptable_compiler)
+ is_true=$(./print_true)
+ rm acceptable_compiler print_true
+ else
+ acceptable=false
+ fi
+ if [[ "$acceptable" == "${is_true:-}" ]]; then
printf "yes.\n %s: Using the $executable found in the PATH.\n" "$this_script"
export MPIFC=mpif90
export MPICC=mpicc
@@ -260,13 +263,17 @@ find_or_install()
stack_push dependency_path "none"
elif [[ "$package_in_path" == "true" ]]; then
- echo -e "$this_script: Checking whether $executable in PATH is version $(./build.sh -V gcc) or later..."
- $executable -o acceptable_compiler acceptable_compiler.f90
- $executable -o print_true print_true.f90
- is_true=$(./print_true)
- acceptable=$(./acceptable_compiler)
- rm acceptable_compiler print_true
- if [[ "$acceptable" == "$is_true" ]]; then
+ info "$this_script: Checking whether $executable in PATH is version $(./build.sh -V gcc) or later..."
+ $executable -o acceptable_compiler acceptable_compiler.f90 || true;
+ $executable -o print_true print_true.f90 || true;
+ if [[ -f ./accepatable_compiler && -f ./print_true ]]; then
+ is_true=$(./print_true)
+ acceptable=$(./acceptable_compiler)
+ rm acceptable_compiler print_true
+ else
+ acceptable=false
+ fi
+ if [[ "$acceptable" == "${is_true:-}" ]]; then
printf "yes.\n"
echo -e "$this_script: Using the $executable found in the PATH.\n"
export FC=gfortran
@@ -578,9 +585,13 @@ find_or_install()
default_package_version=$(./build.sh -V "${package}")
package_install_prefix="${package_install_path%${package}/${arg_I:-${default_package_version}}*}"
+ if [[ "${arg_y}" == "${__flag_present}" ]]; then
+ yes_to_all="-y"
+ fi
+
echo -e "$this_script: Downloading, building, and installing $package \n"
- echo "$this_script: Build command: FC=$FC CC=$CC CXX=$CXX ./build.sh -p $package -i $package_install_prefix -j $num_threads"
- FC="$FC" CC="$CC" CXX="$CXX" ./build.sh -p "$package" -i "$package_install_prefix" -j "$num_threads"
+ echo "$this_script: Build command: FC=$FC CC=$CC CXX=$CXX ./build.sh -p $package -i $package_install_prefix -j $num_threads ${yes_to_all:-}"
+ FC="$FC" CC="$CC" CXX="$CXX" ./build.sh -p "$package" -i "$package_install_prefix" -j "$num_threads" "${yes_to_all:-}"
if [[ -x "$package_install_path/bin/$executable" ]]; then
echo -e "$this_script: Installation successful.\n"
diff --git a/src/libcaf.h b/src/libcaf.h
index 1ea065c..cd7edbd 100644
--- a/src/libcaf.h
+++ b/src/libcaf.h
@@ -43,6 +43,10 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */
#define unlikely(x) __builtin_expect(!!(x), 0)
#endif
+#if __GNUC__ >= 7
+#define GCC_GE_7 1
+#endif
+
#ifdef PREFIX_NAME
#define PREFIX3(X,Y) X ## Y
#define PREFIX2(X,Y) PREFIX3(X,Y)
@@ -101,6 +105,87 @@ typedef struct caf_vector_t {
caf_vector_t;
+#ifdef GCC_GE_7
+/* Keep in sync with gcc/libgfortran/caf/libcaf.h. */
+typedef enum caf_ref_type_t {
+ /* Reference a component of a derived type, either regular one or an
+ allocatable or pointer type. For regular ones idx in caf_reference_t is
+ set to -1. */
+ CAF_REF_COMPONENT,
+ /* Reference an allocatable array. */
+ CAF_REF_ARRAY,
+ /* Reference a non-allocatable/non-pointer array. */
+ CAF_REF_STATIC_ARRAY
+} caf_ref_type_t;
+
+/* Keep in sync with gcc/libgfortran/caf/libcaf.h. */
+typedef enum caf_array_ref_t {
+ /* No array ref. This terminates the array ref. */
+ CAF_ARR_REF_NONE = 0,
+ /* Reference array elements given by a vector. Only for this mode
+ caf_reference_t.u.a.dim[i].v is valid. */
+ CAF_ARR_REF_VECTOR,
+ /* A full array ref (:). */
+ CAF_ARR_REF_FULL,
+ /* Reference a range on elements given by start, end and stride. */
+ CAF_ARR_REF_RANGE,
+ /* Only a single item is referenced given in the start member. */
+ CAF_ARR_REF_SINGLE,
+ /* An array ref of the kind (i:), where i is an arbitrary valid index in the
+ array. The index i is given in the start member. */
+ CAF_ARR_REF_OPEN_END,
+ /* An array ref of the kind (:i), where the lower bound of the array ref
+ is given by the remote side. The index i is given in the end member. */
+ CAF_ARR_REF_OPEN_START
+} caf_array_ref_t;
+
+/* References to remote components of a derived type.
+ Keep in sync with gcc/libgfortran/caf/libcaf.h. */
+typedef struct caf_reference_t {
+ /* A pointer to the next ref or NULL. */
+ struct caf_reference_t *next;
+ /* The type of the reference. */
+ /* caf_ref_type_t, replaced by int to allow specification in fortran FE. */
+ int type;
+ /* The size of an item referenced in bytes. I.e. in an array ref this is
+ the factor to advance the array pointer with to get to the next item.
+ For component refs this gives just the size of the element referenced. */
+ size_t item_size;
+ union {
+ struct {
+ /* The offset (in bytes) of the component in the derived type. */
+ ptrdiff_t offset;
+ /* The offset (in bytes) to the caf_token associated with this
+ component. NULL, when not allocatable/pointer ref. */
+ ptrdiff_t caf_token_offset;
+ } c;
+ struct {
+ /* The mode of the array ref. See CAF_ARR_REF_*. */
+ /* caf_array_ref_t, replaced by unsigend char to allow specification in
+ fortran FE. */
+ unsigned char mode[GFC_MAX_DIMENSIONS];
+ /* The type of a static array. Unset for array's with descriptors. */
+ int static_array_type;
+ /* Subscript refs (s) or vector refs (v). */
+ union {
+ struct {
+ /* The start and end boundary of the ref and the stride. */
+ ptrdiff_t start, end, stride;
+ } s;
+ struct {
+ /* nvec entries of kind giving the elements to reference. */
+ void *vector;
+ /* The number of entries in vector. */
+ size_t nvec;
+ /* The integer kind used for the elements in vector. */
+ int kind;
+ } v;
+ } dim[GFC_MAX_DIMENSIONS];
+ } a;
+ } u;
+} caf_reference_t;
+#endif
+
/* Common auxiliary functions: caf_auxiliary.c. */
@@ -115,12 +200,17 @@ void PREFIX (finalize) (void);
int PREFIX (this_image) (int);
int PREFIX (num_images) (int, int);
-void *PREFIX (register) (size_t, caf_register_t, caf_token_t *, int *, char *,
- int);
+#ifdef GCC_GE_7
+void PREFIX (register) (size_t, caf_register_t, caf_token_t *,
+ gfc_descriptor_t *, int *, char *, int);
+#else
+void * PREFIX (register) (size_t, caf_register_t, caf_token_t *,
+ int *, char *, int);
+#endif
void PREFIX (deregister) (caf_token_t *, int *, char *, int);
void PREFIX (caf_get) (caf_token_t, size_t, int, gfc_descriptor_t *,
- caf_vector_t *, gfc_descriptor_t *, int, int);
+ caf_vector_t *, gfc_descriptor_t *, int, int, int);
void PREFIX (caf_send) (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, gfc_descriptor_t *, int, int);
@@ -128,6 +218,21 @@ void PREFIX (caf_sendget) (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, caf_token_t, size_t, int,
gfc_descriptor_t *, caf_vector_t *, int, int);
+#ifdef GCC_GE_7
+void PREFIX(get_by_ref) (caf_token_t, int,
+ gfc_descriptor_t *dst, caf_reference_t *refs,
+ int dst_kind, int src_kind, bool may_require_tmp,
+ bool dst_reallocatable, int *stat);
+void PREFIX(send_by_ref) (caf_token_t token, int image_index,
+ gfc_descriptor_t *src, caf_reference_t *refs,
+ int dst_kind, int src_kind, bool may_require_tmp,
+ bool dst_reallocatable, int *stat);
+void PREFIX(sendget_by_ref) (caf_token_t dst_token, int dst_image_index,
+ caf_reference_t *dst_refs, caf_token_t src_token, int src_image_index,
+ caf_reference_t *src_refs, int dst_kind, int src_kind,
+ bool may_require_tmp, int *dst_stat, int *src_stat);
+#endif
+
void PREFIX (co_max) (gfc_descriptor_t *, int, int *, char *, int, int);
void PREFIX (co_min) (gfc_descriptor_t *, int, int *, char *, int, int);
void PREFIX (co_sum) (gfc_descriptor_t *, int, int *, char *, int);
diff --git a/src/mpi/mpi_caf.c b/src/mpi/mpi_caf.c
index a909916..f1316e2 100644
--- a/src/mpi/mpi_caf.c
+++ b/src/mpi/mpi_caf.c
@@ -47,15 +47,26 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* #define GFC_CAF_CHECK 1 */
+
+#ifdef GCC_GE_7
+typedef struct mpi_caf_token_t
+{
+ void *local_memptr;
+ MPI_Win memptr;
+ MPI_Win *desc;
+} mpi_caf_token_t;
+#define TOKEN(X) &(((mpi_caf_token_t *) (X))->memptr)
+#else
typedef MPI_Win *mpi_caf_token_t;
#define TOKEN(X) ((mpi_caf_token_t) (X))
+#endif
static void error_stop (int error) __attribute__ ((noreturn));
/* Global variables. */
static int caf_this_image;
-static int caf_num_images;
-static int caf_is_finalized;
+static int caf_num_images = 0;
+static int caf_is_finalized = 0;
#if MPI_VERSION >= 3
MPI_Info mpi_info_same_size;
@@ -365,10 +376,10 @@ PREFIX (init) (int *argc, char ***argv)
images_full = (int *) calloc (caf_num_images-1, sizeof (int));
- for (i = 0; i < caf_num_images; i++)
- if (i + 1 != caf_this_image)
+ for (i = 1; i <= caf_num_images; ++i)
+ if (i != caf_this_image)
{
- images_full[j] = i + 1;
+ images_full[j] = i;
j++;
}
@@ -425,11 +436,26 @@ PREFIX (finalize) (void)
while(tmp_tot)
{
prev = tmp_tot->prev;
- p = tmp_tot->token;
+ p = TOKEN(tmp_tot->token);
+#ifdef GCC_GE_7
+# ifndef CAF_MPI_LOCK_UNLOCK
+ MPI_Win_unlock_all(*p);
+# endif // CAF_MPI_LOCK_UNLOCK
+ if (((mpi_caf_token_t *)tmp_tot->token)->desc)
+ {
+ mpi_caf_token_t *mpi_token = (mpi_caf_token_t *)tmp_tot->token;
+# ifndef CAF_MPI_LOCK_UNLOCK
+ MPI_Win_unlock_all(*(mpi_token->desc));
+# endif // CAF_MPI_LOCK_UNLOCK
+ MPI_Win_free (mpi_token->desc);
+ free (mpi_token->desc);
+ }
+#else
# ifndef CAF_MPI_LOCK_UNLOCK
MPI_Win_unlock_all(*p);
# endif // CAF_MPI_LOCK_UNLOCK
MPI_Win_free(p);
+#endif
free(tmp_tot);
tmp_tot = prev;
}
@@ -465,14 +491,26 @@ PREFIX (num_images)(int distance __attribute__ ((unused)),
}
+#ifdef GCC_GE_7
+#ifdef COMPILER_SUPPORTS_CAF_INTRINSICS
+void
+ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
+ gfc_descriptor_t *desc, int *stat, char *errmsg, int errmsg_len)
+#else
+void
+ PREFIX (register) (size_t size, caf_register_t type, caf_token_t *token,
+ gfc_descriptor_t *desc, int *stat, char *errmsg, int errmsg_len)
+#endif
+#else
#ifdef COMPILER_SUPPORTS_CAF_INTRINSICS
void *
_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
- int *stat, char *errmsg, int errmsg_len)
+ int *stat, char *errmsg, int errmsg_len)
#else
void *
PREFIX (register) (size_t size, caf_register_t type, caf_token_t *token,
- int *stat, char *errmsg, int errmsg_len)
+ int *stat, char *errmsg, int errmsg_len)
+#endif
#endif
{
/* int ierr; */
@@ -491,12 +529,6 @@ void *
PREFIX (init) (NULL, NULL);
#endif
- /* Token contains only a list of pointers. */
-
- *token = malloc (sizeof(MPI_Win));
-
- MPI_Win *p = *token;
-
if(type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC ||
type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC ||
type == CAF_REGTYPE_EVENT_ALLOC)
@@ -507,18 +539,44 @@ void *
else
actual_size = size;
+#ifdef GCC_GE_7
+ *token = malloc (sizeof (mpi_caf_token_t));
+ mpi_caf_token_t *mpi_token = (mpi_caf_token_t *) *token;
+ MPI_Win *p = TOKEN(mpi_token);
+ if (GFC_DESCRIPTOR_RANK (desc) == 0)
+ mpi_token->desc = NULL;
+ else
+ {
+ int ierr;
+ size_t desc_size = sizeof (gfc_descriptor_t) + /*GFC_DESCRIPTOR_RANK (desc)*/
+ GFC_MAX_DIMENSIONS * sizeof (descriptor_dimension);
+ mpi_token->desc = (MPI_Win *)malloc (sizeof (MPI_Win));
+ ierr = MPI_Win_create (desc, desc_size, 1, mpi_info_same_size,
+ CAF_COMM_WORLD, mpi_token->desc);
+#if MPI_VERSION >= 3 && !defined(CAF_MPI_LOCK_UNLOCK)
+ MPI_Win_lock_all(MPI_MODE_NOCHECK, *(mpi_token->desc));
+# endif
+ }
+#else
+ /* Token contains only a list of pointers. */
+ *token = malloc (sizeof(MPI_Win));
+ MPI_Win *p = *token;
+#endif
+
#if MPI_VERSION >= 3
- MPI_Win_allocate(actual_size, 1, mpi_info_same_size, CAF_COMM_WORLD, &mem, *token);
+#ifdef GCC_GE_7
+ MPI_Win_allocate(actual_size, 1, MPI_INFO_NULL, CAF_COMM_WORLD, &mem, p);
+#else
+ MPI_Win_allocate(actual_size, 1, mpi_info_same_size, CAF_COMM_WORLD, &mem, p);
+#endif
# ifndef CAF_MPI_LOCK_UNLOCK
MPI_Win_lock_all(MPI_MODE_NOCHECK, *p);
# endif // CAF_MPI_LOCK_UNLOCK
#else // MPI_VERSION
MPI_Alloc_mem(actual_size, MPI_INFO_NULL, &mem);
- MPI_Win_create(mem, actual_size, 1, MPI_INFO_NULL, CAF_COMM_WORLD, *token);
+ MPI_Win_create(mem, actual_size, 1, MPI_INFO_NULL, CAF_COMM_WORLD, p);
#endif // MPI_VERSION
- p = *token;
-
if(l_var)
{
init_array = (int *)calloc(size, sizeof(int));
@@ -553,7 +611,14 @@ void *
if (stat)
*stat = 0;
+#ifdef GCC_GE_7
+ /* The descriptor will be initialized only after the call to register. */
+ mpi_token->local_memptr = mem;
+ desc->base_addr = mem;
+ return;
+#else
return mem;
+#endif
error:
{
@@ -579,8 +644,9 @@ error:
else
caf_runtime_error (msg);
}
-
+#ifndef GCC_GE_7
return NULL;
+#endif
}
@@ -613,7 +679,7 @@ PREFIX (deregister) (caf_token_t *token, int *stat, char *errmsg, int errmsg_len
PREFIX (sync_all) (NULL, NULL, 0);
caf_static_t *tmp = caf_tot, *prev = caf_tot, *next=caf_tot;
- MPI_Win *p = *token;
+ MPI_Win *p;
while(tmp)
{
@@ -621,11 +687,22 @@ PREFIX (deregister) (caf_token_t *token, int *stat, char *errmsg, int errmsg_len
if(tmp->token == *token)
{
- p = *token;
+ p = TOKEN(*token);
# ifndef CAF_MPI_LOCK_UNLOCK
MPI_Win_unlock_all(*p);
# endif // CAF_MPI_LOCK_UNLOCK
MPI_Win_free(p);
+#ifdef GCC_GE_7
+ if ((*(mpi_caf_token_t **)token)->desc)
+ {
+ mpi_caf_token_t *mpi_token = *(mpi_caf_token_t **)token;
+# ifndef CAF_MPI_LOCK_UNLOCK
+ MPI_Win_unlock_all(*(mpi_token->desc));
+# endif // CAF_MPI_LOCK_UNLOCK
+ MPI_Win_free (mpi_token->desc);
+ free (mpi_token->desc);
+ }
+#endif
if(prev)
next->prev = prev->prev;
@@ -760,7 +837,7 @@ PREFIX (sendget) (caf_token_t token_s, size_t offset_s, int image_index_s,
size_t i, size;
int j;
int rank = GFC_DESCRIPTOR_RANK (dest);
- MPI_Win *p_s = token_s, *p_g = token_g;
+ MPI_Win *p_s = TOKEN(token_s), *p_g = TOKEN(token_g);
ptrdiff_t dst_offset = 0;
ptrdiff_t src_offset = 0;
void *pad_str = NULL;
@@ -928,7 +1005,7 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
int j;
/* int position, msg = 0; */
int rank = GFC_DESCRIPTOR_RANK (dest);
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
ptrdiff_t dst_offset = 0;
void *pad_str = NULL;
void *t_buff = NULL;
@@ -1310,7 +1387,7 @@ PREFIX (get) (caf_token_t token, size_t offset,
size_t i, size;
int ierr = 0;
int j;
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
int rank = GFC_DESCRIPTOR_RANK (src);
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
@@ -1347,7 +1424,6 @@ PREFIX (get) (caf_token_t token, size_t offset,
&& (GFC_DESCRIPTOR_TYPE (dest) != BT_CHARACTER || dst_size == src_size)
&& PREFIX (is_contiguous) (dest) && PREFIX (is_contiguous) (src)))
{
- /* FIXME: Handle image_index == this_image(). */
/* if (async == false) */
if(caf_this_image == image_index)
{
@@ -1596,6 +1672,1205 @@ PREFIX (get) (caf_token_t token, size_t offset,
}
+#ifdef GCC_GE_7
+/* Emitted when a theorectically unreachable part is reached. */
+const char unreachable[] = "Fatal error: unreachable alternative found.\n";
+
+static void
+assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
+ unsigned char *src)
+{
+ size_t i, n;
+ n = dst_size/4 > src_size ? src_size : dst_size/4;
+ for (i = 0; i < n; ++i)
+ dst[i] = (int32_t) src[i];
+ for (; i < dst_size/4; ++i)
+ dst[i] = (int32_t) ' ';
+}
+
+
+static void
+assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
+ uint32_t *src)
+{
+ size_t i, n;
+ n = dst_size > src_size/4 ? src_size/4 : dst_size;
+ for (i = 0; i < n; ++i)
+ dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
+ if (dst_size > n)
+ memset (&dst[n], ' ', dst_size - n);
+}
+
+static void
+convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
+ int src_kind, int *stat)
+{
+#ifdef HAVE_GFC_INTEGER_16
+ typedef __int128 int128t;
+#else
+ typedef int64_t int128t;
+#endif
+
+#if defined(GFC_REAL_16_IS_LONG_DOUBLE)
+ typedef long double real128t;
+ typedef _Complex long double complex128t;
+#elif defined(HAVE_GFC_REAL_16)
+ typedef _Complex float __attribute__((mode(TC))) __complex128;
+ typedef __float128 real128t;
+ typedef __complex128 complex128t;
+#elif defined(HAVE_GFC_REAL_10)
+ typedef long double real128t;
+ typedef long double complex128t;
+#else
+ typedef double real128t;
+ typedef _Complex double complex128t;
+#endif
+
+ int128t int_val = 0;
+ real128t real_val = 0;
+ complex128t cmpx_val = 0;
+
+ switch (src_type)
+ {
+ case BT_INTEGER:
+ if (src_kind == 1)
+ int_val = *(int8_t*) src;
+ else if (src_kind == 2)
+ int_val = *(int16_t*) src;
+ else if (src_kind == 4)
+ int_val = *(int32_t*) src;
+ else if (src_kind == 8)
+ int_val = *(int64_t*) src;
+#ifdef HAVE_GFC_INTEGER_16
+ else if (src_kind == 16)
+ int_val = *(int128t*) src;
+#endif
+ else
+ goto error;
+ break;
+ case BT_REAL:
+ if (src_kind == 4)
+ real_val = *(float*) src;
+ else if (src_kind == 8)
+ real_val = *(double*) src;
+#ifdef HAVE_GFC_REAL_10
+ else if (src_kind == 10)
+ real_val = *(long double*) src;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (src_kind == 16)
+ real_val = *(real128t*) src;
+#endif
+ else
+ goto error;
+ break;
+ case BT_COMPLEX:
+ if (src_kind == 4)
+ cmpx_val = *(_Complex float*) src;
+ else if (src_kind == 8)
+ cmpx_val = *(_Complex double*) src;
+#ifdef HAVE_GFC_REAL_10
+ else if (src_kind == 10)
+ cmpx_val = *(_Complex long double*) src;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (src_kind == 16)
+ cmpx_val = *(complex128t*) src;
+#endif
+ else
+ goto error;
+ break;
+ default:
+ goto error;
+ }
+
+ switch (dst_type)
+ {
+ case BT_INTEGER:
+ if (src_type == BT_INTEGER)
+ {
+ if (dst_kind == 1)
+ *(int8_t*) dst = (int8_t) int_val;
+ else if (dst_kind == 2)
+ *(int16_t*) dst = (int16_t) int_val;
+ else if (dst_kind == 4)
+ *(int32_t*) dst = (int32_t) int_val;
+ else if (dst_kind == 8)
+ *(int64_t*) dst = (int64_t) int_val;
+#ifdef HAVE_GFC_INTEGER_16
+ else if (dst_kind == 16)
+ *(int128t*) dst = (int128t) int_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_REAL)
+ {
+ if (dst_kind == 1)
+ *(int8_t*) dst = (int8_t) real_val;
+ else if (dst_kind == 2)
+ *(int16_t*) dst = (int16_t) real_val;
+ else if (dst_kind == 4)
+ *(int32_t*) dst = (int32_t) real_val;
+ else if (dst_kind == 8)
+ *(int64_t*) dst = (int64_t) real_val;
+#ifdef HAVE_GFC_INTEGER_16
+ else if (dst_kind == 16)
+ *(int128t*) dst = (int128t) real_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_COMPLEX)
+ {
+ if (dst_kind == 1)
+ *(int8_t*) dst = (int8_t) cmpx_val;
+ else if (dst_kind == 2)
+ *(int16_t*) dst = (int16_t) cmpx_val;
+ else if (dst_kind == 4)
+ *(int32_t*) dst = (int32_t) cmpx_val;
+ else if (dst_kind == 8)
+ *(int64_t*) dst = (int64_t) cmpx_val;
+#ifdef HAVE_GFC_INTEGER_16
+ else if (dst_kind == 16)
+ *(int128t*) dst = (int128t) cmpx_val;
+#endif
+ else
+ goto error;
+ }
+ else
+ goto error;
+ return;
+ case BT_REAL:
+ if (src_type == BT_INTEGER)
+ {
+ if (dst_kind == 4)
+ *(float*) dst = (float) int_val;
+ else if (dst_kind == 8)
+ *(double*) dst = (double) int_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(long double*) dst = (long double) int_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(real128t*) dst = (real128t) int_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_REAL)
+ {
+ if (dst_kind == 4)
+ *(float*) dst = (float) real_val;
+ else if (dst_kind == 8)
+ *(double*) dst = (double) real_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(long double*) dst = (long double) real_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(real128t*) dst = (real128t) real_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_COMPLEX)
+ {
+ if (dst_kind == 4)
+ *(float*) dst = (float) cmpx_val;
+ else if (dst_kind == 8)
+ *(double*) dst = (double) cmpx_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(long double*) dst = (long double) cmpx_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(real128t*) dst = (real128t) cmpx_val;
+#endif
+ else
+ goto error;
+ }
+ return;
+ case BT_COMPLEX:
+ if (src_type == BT_INTEGER)
+ {
+ if (dst_kind == 4)
+ *(_Complex float*) dst = (_Complex float) int_val;
+ else if (dst_kind == 8)
+ *(_Complex double*) dst = (_Complex double) int_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(_Complex long double*) dst = (_Complex long double) int_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(complex128t*) dst = (complex128t) int_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_REAL)
+ {
+ if (dst_kind == 4)
+ *(_Complex float*) dst = (_Complex float) real_val;
+ else if (dst_kind == 8)
+ *(_Complex double*) dst = (_Complex double) real_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(_Complex long double*) dst = (_Complex long double) real_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(complex128t*) dst = (complex128t) real_val;
+#endif
+ else
+ goto error;
+ }
+ else if (src_type == BT_COMPLEX)
+ {
+ if (dst_kind == 4)
+ *(_Complex float*) dst = (_Complex float) cmpx_val;
+ else if (dst_kind == 8)
+ *(_Complex double*) dst = (_Complex double) cmpx_val;
+#ifdef HAVE_GFC_REAL_10
+ else if (dst_kind == 10)
+ *(_Complex long double*) dst = (_Complex long double) cmpx_val;
+#endif
+#ifdef HAVE_GFC_REAL_16
+ else if (dst_kind == 16)
+ *(complex128t*) dst = (complex128t) cmpx_val;
+#endif
+ else
+ goto error;
+ }
+ else
+ goto error;
+ return;
+ default:
+ goto error;
+ }
+
+error:
+ fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
+ "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
+ if (stat)
+ *stat = 1;
+ else
+ abort ();
+}
+
+
+#ifdef CAF_MPI_LOCK_UNLOCK
+#define CAF_Win_lock(img, win) MPI_Win_lock (MPI_LOCK_SHARED, img, 0, win)
+#define CAF_Win_unlock(img, win) MPI_Win_unlock (img, win)
+#else //CAF_MPI_LOCK_UNLOCK
+#define CAF_Win_lock(img, win)
+#define CAF_Win_unlock(img, win) MPI_Win_flush (img, win)
+#endif //CAF_MPI_LOCK_UNLOCK
+
+
+static void
+copy_data (void *ds, mpi_caf_token_t *token, ptrdiff_t offset, int dst_type,
+ int src_type, int dst_kind, int src_kind, size_t dst_size,
+ size_t src_size, size_t num, int *stat, int image_index)
+{
+ size_t k;
+ if (dst_type == src_type && dst_kind == src_kind)
+ {
+ size_t sz = (dst_size > src_size ? src_size : dst_size) * num;
+ CAF_Win_lock (image_index, token->memptr);
+ MPI_Get (ds, sz, MPI_BYTE, image_index, offset, sz, MPI_BYTE,
+ token->memptr);
+ CAF_Win_unlock (image_index, token->memptr);
+ if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER)
+ && dst_size > src_size)
+ {
+ if (dst_kind == 1)
+ memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size);
+ else /* dst_kind == 4. */
+ for (k = src_size/4; k < dst_size/4; k++)
+ ((int32_t*) ds)[k] = (int32_t) ' ';
+ }
+ }
+ else if (dst_type == BT_CHARACTER && dst_kind == 1)
+ {
+ /* Get the required amount of memory on the stack. */
+ void *srh = alloca (src_size);
+ CAF_Win_lock (image_index, token->memptr);
+ MPI_Get (srh, src_size, MPI_BYTE, image_index, offset,
+ src_size, MPI_BYTE, token->memptr);
+ CAF_Win_unlock (image_index, token->memptr);
+ assign_char1_from_char4 (dst_size, src_size, ds, srh);
+ }
+ else if (dst_type == BT_CHARACTER)
+ {
+ /* Get the required amount of memory on the stack. */
+ void *srh = alloca (src_size);
+ CAF_Win_lock (image_index, token->memptr);
+ MPI_Get (srh, src_size, MPI_BYTE, image_index, offset,
+ src_size, MPI_BYTE, token->memptr);
+ CAF_Win_unlock (image_index, token->memptr);
+ assign_char4_from_char1 (dst_size, src_size, ds, srh);
+ }
+ else
+ {
+ /* Get the required amount of memory on the stack. */
+ void *srh = alloca (src_size * num);
+ CAF_Win_lock (image_index, token->memptr);
+ MPI_Get (srh, src_size * num, MPI_BYTE, image_index, offset,
+ src_size * num, MPI_BYTE, token->memptr);
+ CAF_Win_unlock (image_index, token->memptr);
+ for (k = 0; k < num; ++k)
+ {
+ convert_type (ds, dst_type, dst_kind, srh, src_type, src_kind, stat);
+ ds += dst_size;
+ srh += src_size;
+ }
+ }
+}
+
+
+#define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
+ do { \
+ ptrdiff_t abs_stride = (stride) > 0 ? (stride) : -(stride); \
+ num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
+ if (num <= 0 || abs_stride < 1) return; \
+ num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
+ } while (0)
+
+
+#define GFC_DESCRIPTOR_EXTENT(desc,i) ((desc)->dim[i]._ubound + 1 \
+ - (desc)->dim[i].lower_bound)
+
+
+#define GET_REMOTE_DESC(mpi_token, src, src_desc_data, image_index) \
+ if (mpi_token->desc) \
+ { \
+ size_t desc_size = sizeof (gfc_descriptor_t) + GFC_MAX_DIMENSIONS /* rank */ \
+ * sizeof (descriptor_dimension); \
+ int err; \
+ CAF_Win_lock (image_index, *(mpi_token->desc)); \
+ MPI_Get (&src_desc_data, desc_size, MPI_BYTE, \
+ image_index, 0, desc_size, MPI_BYTE, *(mpi_token->desc)); \
+ err = CAF_Win_unlock (image_index, *(mpi_token->desc)); \
+ src = (gfc_descriptor_t *)&src_desc_data; \
+ } \
+ else \
+ src = NULL
+
+
+typedef struct gfc_max_dim_descriptor_t {
+ void *base_addr;
+ size_t offset;
+ ptrdiff_t dtype;
+ descriptor_dimension dim[GFC_MAX_DIMENSIONS];
+} gfc_max_dim_descriptor_t;
+
+static void
+get_for_ref (caf_reference_t *ref, size_t *i, size_t dst_index,
+ mpi_caf_token_t *mpi_token, gfc_descriptor_t *dst,
+ gfc_descriptor_t *src, void *ds, void *sr,
+ ptrdiff_t sr_byte_offset,
+ int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
+ size_t num, int *stat, int image_index)
+/* !!! The image_index is zero-base here. */
+{
+ ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
+ size_t next_dst_dim;
+ gfc_max_dim_descriptor_t src_desc_data;
+
+ if (unlikely (ref == NULL))
+ /* May be we should issue an error here, because this case should not
+ occur. */
+ return;
+
+ if (ref->next == NULL)
+ {
+ size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
+ size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
+ int src_type = -1;
+
+ switch (ref->type)
+ {
+ case CAF_REF_COMPONENT:
+ /* Because the token is always registered after the component, its
+ offset is always greater zeor. */
+ if (ref->u.c.caf_token_offset > 0)
+ copy_data (ds, mpi_token, ref->u.c.offset,
+ GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst),
+ dst_kind, src_kind, dst_size, ref->item_size, 1, stat,
+ image_index);
+ else
+ copy_data (ds, mpi_token, ref->u.c.offset,
+ GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src),
+ dst_kind, src_kind, dst_size, ref->item_size, 1, stat,
+ image_index);
+ ++(*i);
+ return;
+ case CAF_REF_STATIC_ARRAY:
+ src_type = ref->u.a.static_array_type;
+ /* Intentionally fall through. */
+ case CAF_REF_ARRAY:
+ if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+ {
+ copy_data (ds + dst_index * dst_size, mpi_token,
+ sr_byte_offset, GFC_DESCRIPTOR_TYPE (dst),
+ src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type,
+ dst_kind, src_kind, dst_size, ref->item_size, num,
+ stat, image_index);
+ *i += num;
+ return;
+ }
+ break;
+ default:
+ caf_runtime_error (unreachable);
+ }
+ }
+
+ switch (ref->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (ref->u.c.caf_token_offset > 0)
+ {
+ mpi_token = *(mpi_caf_token_t**)(sr + ref->u.c.caf_token_offset);
+ GET_REMOTE_DESC (mpi_token, src, src_desc_data, image_index);
+ get_for_ref (ref->next, i, dst_index, mpi_token, dst, src,
+ ds, sr + ref->u.c.offset, ref->u.c.offset,
+ dst_kind, src_kind, dst_dim, 0, 1, stat, image_index);
+ }
+ else
+ get_for_ref (ref->next, i, dst_index, mpi_token, dst,
+ (gfc_descriptor_t *)(sr + ref->u.c.offset), ds,
+ sr + ref->u.c.offset, ref->u.c.offset, dst_kind, src_kind,
+ dst_dim, 0, 1, stat, image_index);
+ return;
+ case CAF_REF_ARRAY:
+ if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+ {
+ get_for_ref (ref->next, i, dst_index, mpi_token, dst,
+ src, ds, sr, sr_byte_offset, dst_kind,
+ src_kind, dst_dim, 0, 1, stat, image_index);
+ return;
+ }
+ /* Only when on the left most index switch the data pointer to
+ the array's data pointer. */
+ if (src_dim == 0)
+ {
+ sr = src->base_addr;
+ sr_byte_offset = 0;
+ }
+ switch (ref->u.a.mode[src_dim])
+ {
+ case CAF_ARR_REF_VECTOR:
+ extent_src = GFC_DESCRIPTOR_EXTENT (src, src_dim);
+ array_offset_src = 0;
+ for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
+ ++idx)
+ {
+#define KINDCASE(kind, type) case kind: \
+ array_offset_src = (((ptrdiff_t) \
+ ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
+ - src->dim[src_dim].lower_bound \
+ * src->dim[src_dim]._stride); \
+ break
+
+ switch (ref->u.a.dim[src_dim].v.kind)
+ {
+ KINDCASE (1, int8_t);
+ KINDCASE (2, int16_t);
+ KINDCASE (4, int32_t);
+ KINDCASE (8, int64_t);
+#ifdef HAVE_INT128_T
+ KINDCASE (16, int128_t);
+#endif
+ default:
+ caf_runtime_error (unreachable);
+ return;
+ }
+#undef KINDCASE
+
+ get_for_ref (ref, i, dst_index, mpi_token, dst, src, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, image_index);
+ dst_index += dst->dim[dst_dim]._stride;
+ }
+ return;
+ case CAF_ARR_REF_FULL:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ src->dim[src_dim].lower_bound,
+ src->dim[src_dim]._ubound);
+ stride_src = src->dim[src_dim]._stride
+ * ref->u.a.dim[src_dim].s.stride;
+ array_offset_src = 0;
+ for (ptrdiff_t idx = 0; idx < extent_src;
+ ++idx, array_offset_src += stride_src)
+ {
+ get_for_ref (ref, i, dst_index, mpi_token, dst, src, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, image_index);
+ dst_index += dst->dim[dst_dim]._stride;
+ }
+ return;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ ref->u.a.dim[src_dim].s.start,
+ ref->u.a.dim[src_dim].s.end);
+ array_offset_src = (ref->u.a.dim[src_dim].s.start
+ - src->dim[src_dim].lower_bound)
+ * src->dim[src_dim]._stride;
+ stride_src = src->dim[src_dim]._stride
+ * ref->u.a.dim[src_dim].s.stride;
+ /* Increase the dst_dim only, when the src_extent is greater one
+ or src and dst extent are both one. Don't increase when the scalar
+ source is not present in the dst. */
+ next_dst_dim = extent_src > 1
+ || (GFC_DESCRIPTOR_EXTENT (dst, dst_dim) == 1
+ && extent_src == 1) ? (dst_dim + 1) : dst_dim;
+ for (ptrdiff_t idx = 0; idx < extent_src; ++idx)
+ {
+ get_for_ref (ref, i, dst_index, mpi_token, dst, src, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, next_dst_dim, src_dim + 1,
+ 1, stat, image_index);
+ dst_index += dst->dim[dst_dim]._stride;
+ array_offset_src += stride_src;
+ }
+ return;
+ case CAF_ARR_REF_SINGLE:
+ array_offset_src = (ref->u.a.dim[src_dim].s.start
+ - src->dim[src_dim].lower_bound)
+ * src->dim[src_dim]._stride;
+ get_for_ref (ref, i, dst_index, mpi_token, dst, src, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim, src_dim + 1, 1,
+ stat, image_index);
+ return;
+ case CAF_ARR_REF_OPEN_END:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ ref->u.a.dim[src_dim].s.start,
+ src->dim[src_dim]._ubound);
+ stride_src = src->dim[src_dim]._stride
+ * ref->u.a.dim[src_dim].s.stride;
+ array_offset_src = (ref->u.a.dim[src_dim].s.start
+ - src->dim[src_dim].lower_bound)
+ * src->dim[src_dim]._stride;
+ for (ptrdiff_t idx = 0; idx < extent_src; ++idx)
+ {
+ get_for_ref (ref, i, dst_index, mpi_token, dst, src, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, image_index);
+ dst_index += dst->dim[dst_dim]._stride;
+ array_offset_src += stride_src;
+ }
+ return;
+ case CAF_ARR_REF_OPEN_START:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ src->dim[src_dim].lower_bound,
+ ref->u.a.dim[src_dim].s.end);
+ stride_src = src->dim[src_dim]._stride
+ * ref->u.a.dim[src_dim].s.stride;
+ array_offset_src = 0;
+ for (ptrdiff_t idx = 0; idx < extent_src; ++idx)
+ {
+ get_for_ref (ref, i, dst_index, mpi_token, dst, src, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, image_index);
+ dst_index += dst->dim[dst_dim]._stride;
+ array_offset_src += stride_src;
+ }
+ return;
+ default:
+ caf_runtime_error (unreachable);
+ }
+ return;
+ case CAF_REF_STATIC_ARRAY:
+ if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
+ {
+ get_for_ref (ref->next, i, dst_index, mpi_token, dst, NULL, ds, sr,
+ sr_byte_offset, dst_kind, src_kind,
+ dst_dim, 0, 1, stat, image_index);
+ return;
+ }
+ switch (ref->u.a.mode[src_dim])
+ {
+ case CAF_ARR_REF_VECTOR:
+ array_offset_src = 0;
+ for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
+ ++idx)
+ {
+#define KINDCASE(kind, type) case kind: \
+ array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
+ break
+
+ switch (ref->u.a.dim[src_dim].v.kind)
+ {
+ KINDCASE (1, int8_t);
+ KINDCASE (2, int16_t);
+ KINDCASE (4, int32_t);
+ KINDCASE (8, int64_t);
+#ifdef HAVE_INT128_T
+ KINDCASE (16, int128_t);
+#endif
+ default:
+ caf_runtime_error (unreachable);
+ return;
+ }
+#undef KINDCASE
+
+ get_for_ref (ref, i, dst_index, mpi_token, dst, NULL, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, image_index);
+ dst_index += dst->dim[dst_dim]._stride;
+ }
+ return;
+ case CAF_ARR_REF_FULL:
+ for (array_offset_src = 0 ;
+ array_offset_src <= ref->u.a.dim[src_dim].s.end;
+ array_offset_src += ref->u.a.dim[src_dim].s.stride)
+ {
+ get_for_ref (ref, i, dst_index, mpi_token, dst, NULL, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, image_index);
+ dst_index += dst->dim[dst_dim]._stride;
+ }
+ return;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (extent_src,
+ ref->u.a.dim[src_dim].s.stride,
+ ref->u.a.dim[src_dim].s.start,
+ ref->u.a.dim[src_dim].s.end);
+ array_offset_src = ref->u.a.dim[src_dim].s.start;
+ for (ptrdiff_t idx = 0; idx < extent_src; ++idx)
+ {
+ get_for_ref (ref, i, dst_index, mpi_token, dst, NULL, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim + 1, src_dim + 1,
+ 1, stat, image_index);
+ dst_index += dst->dim[dst_dim]._stride;
+ array_offset_src += ref->u.a.dim[src_dim].s.stride;
+ }
+ return;
+ case CAF_ARR_REF_SINGLE:
+ array_offset_src = ref->u.a.dim[src_dim].s.start;
+ get_for_ref (ref, i, dst_index, mpi_token, dst, NULL, ds,
+ sr + array_offset_src * ref->item_size,
+ sr_byte_offset + array_offset_src * ref->item_size,
+ dst_kind, src_kind, dst_dim, src_dim + 1, 1,
+ stat, image_index);
+ return;
+ /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ default:
+ caf_runtime_error (unreachable);
+ }
+ return;
+ default:
+ caf_runtime_error (unreachable);
+ }
+}
+
+
+void
+_gfortran_caf_get_by_ref (caf_token_t token, int image_index,
+ gfc_descriptor_t *dst, caf_reference_t *refs,
+ int dst_kind, int src_kind,
+ bool may_require_tmp __attribute__ ((unused)),
+ bool dst_reallocatable, int *stat)
+{
+ const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown kind in vector-ref.\n";
+ const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown reference type.\n";
+ const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
+ "unknown array reference type.\n";
+ const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): "
+ "rank out of range.\n";
+ const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
+ "extent out of range.\n";
+ const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
+ "can not allocate memory.\n";
+ const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): "
+ "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
+ const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): "
+ "two or more array part references are not supported.\n";
+ size_t size, i;
+ size_t dst_index;
+ int dst_rank = GFC_DESCRIPTOR_RANK (dst);
+ int dst_cur_dim = 0;
+ size_t src_size;
+ mpi_caf_token_t *mpi_token = (mpi_caf_token_t *) token;
+ void *local_memptr = mpi_token->local_memptr;
+ gfc_descriptor_t *src;
+ gfc_max_dim_descriptor_t src_desc_data, primary_src_desc_data;
+ caf_reference_t *riter = refs;
+ long delta;
+ /* Reallocation of dst.data is needed (e.g., array to small). */
+ bool realloc_needed;
+ /* Reallocation of dst.data is required, because data is not alloced at
+ all. */
+ bool realloc_required;
+ bool extent_mismatch = false;
+ /* Set when the first non-scalar array reference is encountered. */
+ bool in_array_ref = false;
+ bool array_extent_fixed = false;
+ realloc_needed = realloc_required = dst->base_addr == NULL;
+
+ if (stat)
+ *stat = 0;
+
+ GET_REMOTE_DESC (mpi_token, src, primary_src_desc_data, image_index - 1);
+ /* Compute the size of the result. In the beginning size just counts the
+ number of elements. */
+ size = 1;
+ while (riter)
+ {
+ switch (riter->type)
+ {
+ case CAF_REF_COMPONENT:
+ if (riter->u.c.caf_token_offset)
+ {
+ mpi_token = *(mpi_caf_token_t**)
+ (local_memptr + riter->u.c.caf_token_offset);
+ local_memptr = mpi_token->local_memptr;
+ GET_REMOTE_DESC (mpi_token, src, src_desc_data, image_index - 1);
+ }
+ else
+ {
+ local_memptr += riter->u.c.offset;
+ src = (gfc_descriptor_t *)local_memptr;
+ }
+ break;
+ case CAF_REF_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_VECTOR:
+ delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+ local_memptr += (((ptrdiff_t) \
+ ((type *)riter->u.a.dim[i].v.vector)[0]) \
+ - src->dim[i].lower_bound) \
+ * src->dim[i]._stride \
+ * riter->item_size; \
+ break
+
+ switch (riter->u.a.dim[i].v.kind)
+ {
+ KINDCASE (1, int8_t);
+ KINDCASE (2, int16_t);
+ KINDCASE (4, int32_t);
+ KINDCASE (8, int64_t);
+#if HAVE_INT128_T
+ KINDCASE (16, int128_t);
+#endif
+ default:
+ caf_runtime_error (vecrefunknownkind, stat, NULL, 0);
+ return;
+ }
+#undef KINDCASE
+ break;
+ case CAF_ARR_REF_FULL:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ src->dim[i].lower_bound,
+ src->dim[i]._ubound);
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ riter->u.a.dim[i].s.end);
+ local_memptr += (riter->u.a.dim[i].s.start
+ - src->dim[i].lower_bound)
+ * src->dim[i]._stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_SINGLE:
+ delta = 1;
+ local_memptr += (riter->u.a.dim[i].s.start
+ - src->dim[i].lower_bound)
+ * src->dim[i]._stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_END:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ src->dim[i]._ubound);
+ local_memptr += (riter->u.a.dim[i].s.start
+ - src->dim[i].lower_bound)
+ * src->dim[i]._stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_START:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ src->dim[i].lower_bound,
+ riter->u.a.dim[i].s.end);
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ default:
+ caf_runtime_error (unknownarrreftype, stat, NULL, 0);
+ return;
+ }
+ if (delta <= 0)
+ return;
+ /* Check the various properties of the destination array.
+ Is an array expected and present? */
+ if (delta > 1 && dst_rank == 0)
+ {
+ /* No, an array is required, but not provided. */
+ caf_runtime_error (extentoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* When dst is an array. */
+ if (dst_rank > 0)
+ {
+ /* Check that dst_cur_dim is valid for dst. Can be
+ superceeded only by scalar data. */
+ if (dst_cur_dim >= dst_rank && delta != 1)
+ {
+ caf_runtime_error (rankoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* Do further checks, when the source is not scalar. */
+ else if (delta != 1)
+ {
+ /* Check that the extent is not scalar and we are not in
+ an array ref for the dst side. */
+ if (!in_array_ref)
+ {
+ /* Check that this is the non-scalar extent. */
+ if (!array_extent_fixed)
+ {
+ /* In an array extent now. */
+ in_array_ref = true;
+ /* Check that we haven't skipped any scalar
+ dimensions yet and that the dst is
+ compatible. */
+ if (i > 0
+ && dst_rank == GFC_DESCRIPTOR_RANK (src))
+ {
+ if (dst_reallocatable)
+ {
+ /* Dst is reallocatable, which means that
+ the bounds are not set. Set them. */
+ for (dst_cur_dim= 0; dst_cur_dim < (int)i;
+ ++dst_cur_dim)
+ {
+ dst->dim[dst_cur_dim].lower_bound = 1;
+ dst->dim[dst_cur_dim]._ubound = 1;
+ dst->dim[dst_cur_dim]._stride = 1;
+ }
+ }
+ else
+ dst_cur_dim = i;
+ }
+ /* Else press thumbs, that there are enough
+ dimensional refs to come. Checked below. */
+ }
+ else
+ {
+ caf_runtime_error (doublearrayref, stat, NULL,
+ 0);
+ return;
+ }
+ }
+ /* When the realloc is required, then no extent may have
+ been set. */
+ extent_mismatch = realloc_required
+ || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
+ /* When it already known, that a realloc is needed or
+ the extent does not match the needed one. */
+ if (realloc_required || realloc_needed
+ || extent_mismatch)
+ {
+ /* Check whether dst is reallocatable. */
+ if (unlikely (!dst_reallocatable))
+ {
+ caf_runtime_error (nonallocextentmismatch, stat,
+ NULL, 0, delta,
+ GFC_DESCRIPTOR_EXTENT (dst,
+ dst_cur_dim));
+ return;
+ }
+ /* Only report an error, when the extent needs to be
+ modified, which is not allowed. */
+ else if (!dst_reallocatable && extent_mismatch)
+ {
+ caf_runtime_error (extentoutofrange, stat, NULL,
+ 0);
+ return;
+ }
+ realloc_needed = true;
+ }
+ /* Only change the extent when it does not match. This is
+ to prevent resetting given array bounds. */
+ if (extent_mismatch)
+ {
+ dst->dim[dst_cur_dim].lower_bound = 1;
+ dst->dim[dst_cur_dim]._ubound = delta;
+ dst->dim[dst_cur_dim]._stride = size;
+ }
+ }
+
+ /* Only increase the dim counter, when in an array ref. */
+ if (in_array_ref && dst_cur_dim < dst_rank)
+ ++dst_cur_dim;
+ }
+ size *= (ptrdiff_t)delta;
+ }
+ if (in_array_ref)
+ {
+ array_extent_fixed = true;
+ in_array_ref = false;
+ }
+ break;
+ case CAF_REF_STATIC_ARRAY:
+ for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
+ {
+ switch (riter->u.a.mode[i])
+ {
+ case CAF_ARR_REF_VECTOR:
+ delta = riter->u.a.dim[i].v.nvec;
+#define KINDCASE(kind, type) case kind: \
+ local_memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
+ * riter->item_size; \
+ break
+
+ switch (riter->u.a.dim[i].v.kind)
+ {
+ KINDCASE (1, int8_t);
+ KINDCASE (2, int16_t);
+ KINDCASE (4, int32_t);
+ KINDCASE (8, int64_t);
+#if HAVE_INT128_T
+ KINDCASE (16, int128_t);
+#endif
+ default:
+ caf_runtime_error (vecrefunknownkind, stat, NULL, 0);
+ return;
+ }
+#undef KINDCASE
+ break;
+ case CAF_ARR_REF_FULL:
+ delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
+ + 1;
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ case CAF_ARR_REF_RANGE:
+ COMPUTE_NUM_ITEMS (delta,
+ riter->u.a.dim[i].s.stride,
+ riter->u.a.dim[i].s.start,
+ riter->u.a.dim[i].s.end);
+ local_memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_SINGLE:
+ delta = 1;
+ local_memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_OPEN_END:
+ /* This and OPEN_START are mapped to a RANGE and therefore
+ can not occur here. */
+ case CAF_ARR_REF_OPEN_START:
+ default:
+ caf_runtime_error (unknownarrreftype, stat, NULL, 0);
+ return;
+ }
+ if (delta <= 0)
+ return;
+ /* Check the various properties of the destination array.
+ Is an array expected and present? */
+ if (delta > 1 && dst_rank == 0)
+ {
+ /* No, an array is required, but not provided. */
+ caf_runtime_error (extentoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* When dst is an array. */
+ if (dst_rank > 0)
+ {
+ /* Check that dst_cur_dim is valid for dst. Can be
+ superceeded only by scalar data. */
+ if (dst_cur_dim >= dst_rank && delta != 1)
+ {
+ caf_runtime_error (rankoutofrange, stat, NULL, 0);
+ return;
+ }
+ /* Do further checks, when the source is not scalar. */
+ else if (delta != 1)
+ {
+ /* Check that the extent is not scalar and we are not in
+ an array ref for the dst side. */
+ if (!in_array_ref)
+ {
+ /* Check that this is the non-scalar extent. */
+ if (!array_extent_fixed)
+ {
+ /* In an array extent now. */
+ in_array_ref = true;
+ /* The dst is not reallocatable, so nothing more
+ to do, then correct the dim counter. */
+ dst_cur_dim = i;
+ }
+ else
+ {
+ caf_runtime_error (doublearrayref, stat, NULL,
+ 0);
+ return;
+ }
+ }
+ /* When the realloc is required, then no extent may have
+ been set. */
+ extent_mismatch = realloc_required
+ || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
+ /* When it is already known, that a realloc is needed or
+ the extent does not match the needed one. */
+ if (realloc_required || realloc_needed
+ || extent_mismatch)
+ {
+ /* Check whether dst is reallocatable. */
+ if (unlikely (!dst_reallocatable))
+ {
+ caf_runtime_error (nonallocextentmismatch, stat,
+ NULL, 0, delta,
+ GFC_DESCRIPTOR_EXTENT (dst,
+ dst_cur_dim));
+ return;
+ }
+ /* Only report an error, when the extent needs to be
+ modified, which is not allowed. */
+ else if (!dst_reallocatable && extent_mismatch)
+ {
+ caf_runtime_error (extentoutofrange, stat, NULL,
+ 0);
+ return;
+ }
+ realloc_needed = true;
+ }
+ /* Only change the extent when it does not match. This is
+ to prevent resetting given array bounds. */
+ if (extent_mismatch)
+ {
+ dst->dim[dst_cur_dim].lower_bound = 1;
+ dst->dim[dst_cur_dim]._ubound = delta;
+ dst->dim[dst_cur_dim]._stride = size;
+ }
+ }
+ /* Only increase the dim counter, when in an array ref. */
+ if (in_array_ref && dst_cur_dim < dst_rank)
+ ++dst_cur_dim;
+ }
+ size *= (ptrdiff_t)delta;
+ }
+ if (in_array_ref)
+ {
+ array_extent_fixed = true;
+ in_array_ref = false;
+ }
+ break;
+ default:
+ caf_runtime_error (unknownreftype, stat, NULL, 0);
+ return;
+ }
+ src_size = riter->item_size;
+ riter = riter->next;
+ }
+ if (size == 0 || src_size == 0)
+ return;
+ /* Postcondition:
+ - size contains the number of elements to store in the destination array,
+ - src_size gives the size in bytes of each item in the destination array.
+ */
+
+ if (realloc_needed)
+ {
+ if (!array_extent_fixed)
+ {
+ /* This can happen only, when the result is scalar. */
+ for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim)
+ {
+ dst->dim[dst_cur_dim].lower_bound = 1;
+ dst->dim[dst_cur_dim]._ubound = 1;
+ dst->dim[dst_cur_dim]._stride = 1;
+ }
+ }
+ dst->base_addr = malloc (size * GFC_DESCRIPTOR_SIZE (dst));
+ if (unlikely (dst->base_addr == NULL))
+ {
+ caf_runtime_error (cannotallocdst, stat, NULL, 0);
+ return;
+ }
+ }
+
+ /* Reset the token. */
+ mpi_token = (mpi_caf_token_t *) token;
+ local_memptr = mpi_token->local_memptr;
+ src = (gfc_descriptor_t *)&primary_src_desc_data;
+ dst_index = 0;
+ i = 0;
+ get_for_ref (refs, &i, dst_index, mpi_token, dst, src,
+ dst->base_addr, local_memptr, 0, dst_kind, src_kind, 0, 0,
+ 1, stat, image_index - 1);
+}
+
+
+void
+PREFIX(send_by_ref) (caf_token_t token, int image_index,
+ gfc_descriptor_t *src, caf_reference_t *refs,
+ int dst_kind, int src_kind, bool may_require_tmp,
+ bool dst_reallocatable, int *stat)
+{
+ fprintf (stderr, "COARRAY ERROR: caf_send_by_ref() not implemented yet ");
+ error_stop (1);
+}
+
+
+void
+PREFIX(sendget_by_ref) (caf_token_t dst_token, int dst_image_index,
+ caf_reference_t *dst_refs, caf_token_t src_token,
+ int src_image_index, caf_reference_t *src_refs,
+ int dst_kind, int src_kind,
+ bool may_require_tmp, int *dst_stat, int *src_stat)
+{
+ fprintf (stderr, "COARRAY ERROR: caf_sendget_by_ref() not implemented yet ");
+ error_stop (1);
+}
+#endif
+
+
/* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while
SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*)
is not equivalent to SYNC ALL. */
@@ -1603,8 +2878,7 @@ void
PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
int errmsg_len)
{
- int ierr = 0, i=0, remote_stat = 0;
- int dup = 0, j = 0;
+ int ierr = 0, i = 0, remote_stat = 0, j = 0;
MPI_Status s;
if (count == 0 || (count == 1 && images[0] == caf_this_image))
@@ -1615,8 +2889,8 @@ PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
}
/* halt execution if sync images contains duplicate image numbers */
- for(i=0;i<count;i++)
- for(j=0;j<i;j++)
+ for(i = 0; i < count; ++i)
+ for(j = 0; j < i; ++j)
if(images[i] == images[j])
{
ierr = STAT_DUP_SYNC_IMAGES;
@@ -1627,7 +2901,7 @@ PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
#ifdef GFC_CAF_CHECK
{
- for (i = 0; i < count; i++)
+ for (i = 0; i < count; ++i)
if (images[i] < 1 || images[i] > caf_num_images)
{
fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
@@ -1643,65 +2917,85 @@ PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
{
if(count == -1)
{
- for (i = 0; i < caf_num_images - 1; i++)
- orders[images_full[i]-1]++;
- count = caf_num_images-1;
+ for (i = 0; i < caf_num_images - 1; ++i)
+ ++orders[images_full[i] - 1];
+ count = caf_num_images - 1;
images = images_full;
}
else
{
- for (i = 0; i < count; i++)
- orders[images[i]-1]++;
+ for (i = 0; i < count; ++i)
+ ++orders[images[i] - 1];
}
#if defined(NONBLOCKING_PUT) && !defined(CAF_MPI_LOCK_UNLOCK)
- explicit_flush();
+ explicit_flush();
#endif
- for(i = 0; i < count; i++)
- ierr = MPI_Irecv(&arrived[images[i]-1], 1, MPI_INT, images[i]-1, 0, CAF_COMM_WORLD, &handlers[images[i]-1]);
-
- for(i=0;i<count;i++)
- {
+ for(i = 0; i < count; ++i)
+ /* Need to have the request handlers contigously in the handlers
+ array or waitany below will trip about the handler as illegal. */
+ ierr = MPI_Irecv (&arrived[images[i] - 1], 1, MPI_INT, images[i] - 1, 0,
+ CAF_COMM_WORLD, &handlers[i]);
+ for(i = 0; i < count; ++i)
+ {
# ifdef CAF_MPI_LOCK_UNLOCK
- MPI_Win_lock (MPI_LOCK_SHARED, images[i]-1, 0, *stat_tok);
+ MPI_Win_lock (MPI_LOCK_SHARED, images[i] - 1, 0, *stat_tok);
# endif // CAF_MPI_LOCK_UNLOCK
- ierr = MPI_Get (&remote_stat, 1, MPI_INT,
- images[i]-1, 0, 1, MPI_INT, *stat_tok);
+ ierr = MPI_Get (&remote_stat, 1, MPI_INT,
+ images[i] - 1, 0, 1, MPI_INT, *stat_tok);
# ifdef CAF_MPI_LOCK_UNLOCK
- MPI_Win_unlock (images[i]-1, *stat_tok);
+ MPI_Win_unlock (images[i] - 1, *stat_tok);
# else // CAF_MPI_LOCK_UNLOCK
- MPI_Win_flush (images[i]-1, *stat_tok);
+ MPI_Win_flush (images[i] - 1, *stat_tok);
# endif // CAF_MPI_LOCK_UNLOCK
- if(remote_stat != 0)
- {
- ierr = STAT_STOPPED_IMAGE;
- if(stat != NULL)
- *stat = ierr;
- goto sync_images_err_chk;
- }
- }
-
- for(i=0; i < count; i++)
- ierr = MPI_Send(&caf_this_image, 1, MPI_INT, images[i]-1, 0, CAF_COMM_WORLD);
-
- for(i=0; i < count; i++)
- ierr = MPI_Wait(&handlers[images[i]-1], &s);
+ if(remote_stat != 0)
+ {
+ ierr = STAT_STOPPED_IMAGE;
+ /* Let the other images know, that at least one image is
+ stopped by sending STAT_STOPPED_IMAGE instead of our id. */
+ for(i = 0; i < count; ++i)
+ MPI_Send (&ierr, 1, MPI_INT, images[i] - 1, 0, CAF_COMM_WORLD);
+ break;
+ }
+ }
+ if (ierr == 0)
+ {
+ int done_count = 0;
+ for(i = 0; i < count; ++i)
+ {
+ if (arrived[images[i] - 1] != STAT_STOPPED_IMAGE)
+ /* Only send, when no stopped images have been found. */
+ ierr = MPI_Send (&caf_this_image, 1, MPI_INT, images[i] - 1, 0,
+ CAF_COMM_WORLD);
+ else
+ ierr = STAT_STOPPED_IMAGE;
+ }
- memset(arrived, 0, sizeof(int)*caf_num_images);
+ while (ierr != STAT_STOPPED_IMAGE && done_count < count)
+ {
+ ierr = MPI_Waitany (count, handlers, &i, &s);
+ if (i != MPI_UNDEFINED)
+ ++done_count;
+ if (i != MPI_UNDEFINED && arrived[i] == STAT_STOPPED_IMAGE)
+ ierr = STAT_STOPPED_IMAGE;
+ else if (ierr != MPI_SUCCESS)
+ break;
+ }
+ }
+ memset(arrived, 0, sizeof(int) * caf_num_images);
}
+sync_images_err_chk:
if (stat)
*stat = ierr;
- sync_images_err_chk:
-
if (ierr && stat == NULL)
{
char *msg;
if (caf_is_finalized)
- msg = "SYNC IMAGES failed - there are stopped images";
+ msg = "SYNC IMAGES failed - there are stopped images";
else
msg = "SYNC IMAGES failed";
@@ -2117,7 +3411,7 @@ PREFIX (lock) (caf_token_t token, size_t index, int image_index,
int errmsg_len)
{
int dest_img;
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
if(image_index == 0)
dest_img = caf_this_image;
@@ -2133,7 +3427,7 @@ PREFIX (unlock) (caf_token_t token, size_t index, int image_index,
int *stat, char *errmsg, int errmsg_len)
{
int dest_img;
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
if(image_index == 0)
dest_img = caf_this_image;
@@ -2150,7 +3444,7 @@ PREFIX (atomic_define) (caf_token_t token, size_t offset,
int image_index, void *value, int *stat,
int type __attribute__ ((unused)), int kind)
{
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
MPI_Datatype dt;
int ierr = 0;
int image;
@@ -2192,7 +3486,7 @@ PREFIX(atomic_ref) (caf_token_t token, size_t offset,
void *value, int *stat,
int type __attribute__ ((unused)), int kind)
{
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
MPI_Datatype dt;
int ierr = 0;
int image;
@@ -2235,7 +3529,7 @@ PREFIX(atomic_cas) (caf_token_t token, size_t offset,
void *new_val, int *stat,
int type __attribute__ ((unused)), int kind)
{
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
MPI_Datatype dt;
int ierr = 0;
int image;
@@ -2281,7 +3575,7 @@ PREFIX (atomic_op) (int op, caf_token_t token ,
{
int ierr = 0;
MPI_Datatype dt;
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
int image;
#if MPI_VERSION >= 3
@@ -2342,7 +3636,7 @@ PREFIX (event_post) (caf_token_t token, size_t index,
char *errmsg, int errmsg_len)
{
int image, value=1, ierr=0;
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
const char msg[] = "Error on event post";
if(image_index == 0)
@@ -2388,7 +3682,7 @@ PREFIX (event_wait) (caf_token_t token, size_t index,
int *var=NULL,flag,old=0;
int newval=0;
const int spin_loop_max = 20000;
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
const char msg[] = "Error on event wait";
if(stat != NULL)
@@ -2444,7 +3738,7 @@ PREFIX (event_query) (caf_token_t token, size_t index,
int image_index, int *count, int *stat)
{
int image,ierr=0;
- MPI_Win *p = token;
+ MPI_Win *p = TOKEN(token);
if(image_index == 0)
image = caf_this_image-1;
diff --git a/src/tests/integration/CMakeLists.txt b/src/tests/integration/CMakeLists.txt
index 6b19a01..15cb018 100644
--- a/src/tests/integration/CMakeLists.txt
+++ b/src/tests/integration/CMakeLists.txt
@@ -4,4 +4,5 @@ if (opencoarrays_aware_compiler)
add_subdirectory(dist_transpose )
endif()
add_subdirectory(pde_solvers)
+ add_subdirectory(events)
endif()
diff --git a/src/tests/integration/events/CMakeLists.txt b/src/tests/integration/events/CMakeLists.txt
new file mode 100644
index 0000000..757a115
--- /dev/null
+++ b/src/tests/integration/events/CMakeLists.txt
@@ -0,0 +1,2 @@
+add_executable(asynchronous_hello_world async-hello.f90)
+target_link_libraries(asynchronous_hello_world OpenCoarrays)
diff --git a/src/tests/integration/events/async-hello.f90 b/src/tests/integration/events/async-hello.f90
new file mode 100644
index 0000000..869c01f
--- /dev/null
+++ b/src/tests/integration/events/async-hello.f90
@@ -0,0 +1,77 @@
+! async-hello-2015.f90
+!
+! -- A Parallel "Hello World" program in Fortran 2015:
+! Image 1 asynchronously gets and prints greetings defined by every image.
+!
+! The program uses event post, query, and wait defined by a Fortarn 2015.
+program main
+ use iso_fortran_env, only : event_type,output_unit
+ implicit none
+
+ character(len=48) :: greeting[*]
+ type(event_type), allocatable :: greeting_ready(:)[:]
+ type(event_type) :: ok_to_overwrite[*]
+ integer :: step
+ integer, parameter :: nsteps=4
+
+ associate( me=>this_image(), ni=>num_images() )
+
+ allocate(greeting_ready(ni)[*])
+
+ do step=1,nsteps
+
+ if (me/=1) then
+ ! Wait for image 1 signal that it has the previous greeting
+ if (step>1) event wait( ok_to_overwrite ) ! Atomically decrements my ok-to-write counter
+ write(greeting,"(3(a,i2))") "Greetings from image ",me," of ",ni," on step ",step
+ ! Signal image 1 that a new greeting is ready for pickup:
+ event post(greeting_ready(me)[1]) ! Atomically increments my event greeting-ready counter on image 1
+
+ else
+
+ write(greeting,"(3(a,i2))") "Greetings from image ",me," of ",ni," on step ",step
+
+ spin_query_work: block
+ integer :: image,ready_count
+ integer, save, allocatable :: previous_count(:)
+ logical, dimension(2:ni) :: greeting_not_printed
+ integer, parameter :: max_single_digit=9
+
+ if (.not. allocated(previous_count)) allocate(previous_count(2:ni),source=0)
+
+ greeting_not_printed=.true.
+
+ spin: do while( any( greeting_not_printed ) ) ! Loop until all greetings have been printed
+ query: do image=2,min(ni,max_single_digit) ! Atomically access each event's counter
+ if (greeting_not_printed(image)) then ! Print greetings that have not been printed during this step
+ call event_query( greeting_ready(image), ready_count)
+ work_if_ready: select case(ready_count-previous_count(image))
+ case(0) ! keep spinning until greeting is ready
+ case(1) ! event posted so get and print greeting
+ write(greeting,"(2(a,i2))") greeting[image]
+ associate(expected_location=>23)
+ ! Verify that the greetings of images 1-9 have their image number at the expected location:
+ if (scan(greeting,set="123456789")/=expected_location) error stop "Test failed."
+ end associate
+ event post(ok_to_overwrite[image])
+ greeting_not_printed(image)=.false.
+ previous_count(image)=ready_count
+ case default
+ if (ready_count<0) error stop "compiler bug: negative event_query count"
+ error stop "multiple events happened since last the last event query"
+ end select work_if_ready
+ end if
+ end do query
+ end do spin
+
+ end block spin_query_work
+ end if
+ end do
+
+ sync all
+ if (me==1) print *,"Test passed."
+
+ end associate
+
+
+end program
diff --git a/src/tests/unit/send-get/get_with_offset_1d.f90 b/src/tests/unit/send-get/get_with_offset_1d.f90
index 17d4343..c26d2ea 100644
--- a/src/tests/unit/send-get/get_with_offset_1d.f90
+++ b/src/tests/unit/send-get/get_with_offset_1d.f90
@@ -27,5 +27,5 @@ program get_offset_1d
enddo
write(*,*) 'Test passed.'
endif
-
+sync all
end program
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/open-coarrays.git
More information about the debian-science-commits
mailing list