[open-coarrays] 63/80: 1.9.0 release
Alastair McKinstry
mckinstry at moszumanska.debian.org
Wed Oct 25 13:45:50 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 5c3ad51dcfecf1f4158d9696fc04900ec97be83c
Author: Alastair McKinstry <mckinstry at debian.org>
Date: Thu Jun 1 10:02:23 2017 +0100
1.9.0 release
---
.VERSION | 19 +-
CMakeLists.txt | 125 +-
INSTALL.md | 1 +
cmake/AddInstallationScriptTest.cmake | 13 +-
install.sh | 7 +-
prerequisites/check_version.sh | 7 +-
prerequisites/install-functions/report_results.sh | 91 +-
src/libcaf.h | 22 +-
src/mpi/CMakeLists.txt | 69 +-
src/mpi/mpi_caf.c | 1465 +++++++++++++++-----
src/tests/installation/installation-scripts.sh | 26 +-
src/tests/installation/test-stack.sh | 179 ++-
src/tests/unit/CMakeLists.txt | 3 +
src/tests/unit/extensions/CMakeLists.txt | 2 +-
src/tests/unit/fail_images/CMakeLists.txt | 27 +
.../image_fail_and_failed_images_test_1.f90 | 31 +
.../unit/fail_images/image_fail_and_get_test_1.f90 | 32 +
.../fail_images/image_fail_and_status_test_1.f90 | 33 +
.../image_fail_and_stopped_images_test_1.f90 | 30 +
.../fail_images/image_fail_and_sync_test_1.f90 | 27 +
.../fail_images/image_fail_and_sync_test_2.f90 | 25 +
.../fail_images/image_fail_and_sync_test_3.f90 | 24 +
src/tests/unit/fail_images/image_fail_test_1.f90 | 21 +
src/tests/unit/fail_images/image_status_test_1.f90 | 18 +
src/tests/unit/init_register/async_comp_alloc.f90 | 6 +-
src/tests/unit/sync/syncimages_status.f90 | 1 +
26 files changed, 1793 insertions(+), 511 deletions(-)
diff --git a/.VERSION b/.VERSION
index ff1f65f..7772b9a 100644
--- a/.VERSION
+++ b/.VERSION
@@ -1,5 +1,18 @@
-# OpenCoarrays version file. Odd patch levels indicate inter-release
-# version, i.e., code is from SCM/git. This project uses semantic
+ (tag: 1.9.0)
+
+
+# Fall back version, probably last release:
+1.9.0
+
+# OpenCoarrays version file. This project uses semantic
# versioning. For details see http://semver.org
+#
+# Release archive created from commit:
+# fdc783deea8205615e1f591ea746236b696307c8 (tag: 1.9.0)
+# Created on 2017-05-26 17:07:34 -0400 by Izaak Beekman, and
+# signed by using E8C38C70328B3A0E.
+# Signature status: E
+gpg: Signature made Fri 26 May 2017 02:08:03 PM PDT
+gpg: using RSA key E8C38C70328B3A0E
+gpg: Can't check signature: public key not found
-1.8.10
diff --git a/CMakeLists.txt b/CMakeLists.txt
index f7f7b61..a8ce977 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -7,20 +7,64 @@ set ( CMAKE_BUILD_TYPE "Release"
set_property ( CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS ${CMAKE_CONFIGURATION_TYPES} )
# Add option and check environment to determine if developer tests should be run
-if(ENV{OPENCOARRAYS_DEVELOPER})
- option(RUN_DEVELOPER_TESTS "Run tests intended only for developers" ON)
+if($ENV{OPENCOARRAYS_DEVELOPER})
+ option(CAF_RUN_DEVELOPER_TESTS "Run tests intended only for developers" ON)
else()
- option(RUN_DEVELOPER_TESTS "Run tests intended only for developers" OFF)
+ option(CAF_RUN_DEVELOPER_TESTS "Run tests intended only for developers" OFF)
+endif()
+mark_as_advanced(CAF_RUN_DEVELOPER_TESTS)
+
+if( NOT DEFINED ENV{OPENCOARRAYS_DEVELOPER})
+ set ( ENV{OPENCOARRAYS_DEVELOPER} FALSE )
endif()
-mark_as_advanced(RUN_DEVELOPER_TESTS)
# Name project and specify source languages
# Parse version from .VERSION file so that more info can be added and easier to get from scripts
-file( STRINGS ".VERSION" OpenCoarraysVersion
+file(STRINGS ".VERSION" first_line
+ LIMIT_COUNT 1
+ )
+
+string(REGEX MATCH "[0-9]+\\.[0-9]+\\.[0-9]+"
+ OpenCoarraysVersion "${first_line}")
+
+if((NOT (OpenCoarraysVersion MATCHES "[0-9]+\\.[0-9]+\\.[0-9]+")) AND (EXISTS "${CMAKE_SOURCE_DIR}/.git"))
+ message( STATUS "Build from git repository detected")
+ find_package(Git)
+ if(GIT_FOUND)
+ execute_process(COMMAND "${GIT_EXECUTABLE}" describe --abbrev=0
+ WORKING_DIRECTORY "${CMAKE_SOURCE_DIR}"
+ RESULT_VARIABLE git_status
+ OUTPUT_VARIABLE git_output
+ OUTPUT_STRIP_TRAILING_WHITESPACE)
+ if((git_status STREQUAL "0") AND (git_output MATCHES "[0-9]+\\.[0-9]+\\.[0-9]+"))
+ set(OpenCoarraysVersion "${git_output}")
+ endif()
+ execute_process(COMMAND "${GIT_EXECUTABLE}" describe --always --dirty
+ WORKING_DIRECTORY "${CMAKE_SOURCE_DIR}"
+ RESULT_VARIABLE git_status
+ OUTPUT_VARIABLE full_git_describe
+ OUTPUT_STRIP_TRAILING_WHITESPACE)
+ if(NOT (git_status STREQUAL "0"))
+ set(full_git_describe NOTFOUND)
+ endif()
+ else()
+ message( WARNING "Could not find git executable!")
+ endif()
+endif()
+
+if(NOT (OpenCoarraysVersion MATCHES "[0-9]+\\.[0-9]+\\.[0-9]+"))
+ message( WARNING "Could not extract version from git, falling back on .VERSION, line 3.")
+ file(STRINGS ".VERSION" OpenCoarraysVersion
REGEX "[0-9]+\\.[0-9]+\\.[0-9]+"
-)
+ )
+endif()
+
+if(NOT full_git_describe)
+ set(full_git_describe ${OpenCoarraysVersion})
+endif()
+
project(opencoarrays VERSION "${OpenCoarraysVersion}" LANGUAGES C Fortran)
-message( STATUS "Building OpenCoarrays version: ${OpenCoarraysVersion}" )
+message( STATUS "Building OpenCoarrays version: ${full_git_describe}" )
#Print an error message on an attempt to build inside the source directory tree:
if ("${CMAKE_CURRENT_SOURCE_DIR}" STREQUAL "${CMAKE_CURRENT_BINARY_DIR}")
@@ -383,7 +427,7 @@ include(GNUInstallDirs)
#-------------------------------
# Recurse into the src directory
#-------------------------------
-include_directories(${CMAKE_CURRENT_SOURCE_DIR}/src)
+include_directories(BEFORE ${CMAKE_CURRENT_SOURCE_DIR}/src)
add_subdirectory(src)
@@ -461,27 +505,43 @@ function(add_mpi_test name num_mpi_proc path)
set_property(TEST ${name} PROPERTY PASS_REGULAR_EXPRESSION "Test passed.")
endfunction(add_mpi_test)
+function(add_fault_tolerant_mpi_test name num_mpi_proc path)
+ if ( ((N LESS num_mpi_proc) OR (N EQUAL 0)) )
+ message(STATUS "Test ${name} is oversubscribed: ${num_mpi_proc} ranks requested with ${N} system processor available.")
+ if ( openmpi )
+ if ( N LESS 2 )
+ set( num_mpi_proc 2 )
+ set (test_parameters --oversubscribe)
+ else()
+ set ( num_mpi_proc ${N} )
+ endif()
+ message( STATUS "Open-MPI detected, over-riding oversubscribed test, ${name}, with ${num_mpi_proc} ranks." )
+ endif()
+ endif()
+ set(test_parameters ${test_parameters} ${MPIEXEC_NUMPROC_FLAG} ${num_mpi_proc} -disable-auto-cleanup )
+ add_test(NAME ${name} COMMAND ${MPIEXEC} ${test_parameters} "${path}")
+ set_property(TEST ${name} PROPERTY PASS_REGULAR_EXPRESSION "Test passed.")
+endfunction(add_fault_tolerant_mpi_test)
+
set(tests_root ${CMAKE_CURRENT_BINARY_DIR}/src/tests)
if(opencoarrays_aware_compiler)
+ if (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER})
+ message ( STATUS "Running Developer tests is enabled." )
+ endif()
# Unit tests targeting each libcaf_mpi function, argument, and branch of code
add_mpi_test(initialize_mpi 2 ${tests_root}/unit/init_register/initialize_mpi)
add_mpi_test(register 2 ${tests_root}/unit/init_register/register)
add_mpi_test(register_vector 2 ${tests_root}/unit/init_register/register_vector)
add_mpi_test(register_alloc_vector 2 ${tests_root}/unit/init_register/register_alloc_vector)
add_mpi_test(allocate_as_barrier 2 ${tests_root}/unit/init_register/allocate_as_barrier)
- add_mpi_test(allocate_as_barrier_proc 32 ${tests_root}/unit/init_register/allocate_as_barrier_proc)
+ add_mpi_test(allocate_as_barrier_proc 8 ${tests_root}/unit/init_register/allocate_as_barrier_proc)
if (gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7))
add_mpi_test(register_alloc_comp_1 2 ${tests_root}/unit/init_register/register_alloc_comp_1)
add_mpi_test(register_alloc_comp_2 2 ${tests_root}/unit/init_register/register_alloc_comp_2)
add_mpi_test(register_alloc_comp_3 2 ${tests_root}/unit/init_register/register_alloc_comp_3)
- if (RUN_DEVELOPER_TESTS)
- add_mpi_test(async_comp_alloc 6 ${tests_root}/unit/init_register/async_comp_alloc)
- # Timeout async_comp_alloc test after 3 seconds to progess past the known failure
- set_property(TEST async_comp_alloc PROPERTY TIMEOUT_AFTER_MATCH 3 "known failure")
- set_property(TEST async_comp_alloc PROPERTY TIMEOUT 6) # in the event old CMake is being used
- endif()
+ add_mpi_test(async_comp_alloc 6 ${tests_root}/unit/init_register/async_comp_alloc)
endif()
add_mpi_test(get_array 2 ${tests_root}/unit/send-get/get_array)
add_mpi_test(get_self 2 ${tests_root}/unit/send-get/get_self)
@@ -494,16 +554,16 @@ if(opencoarrays_aware_compiler)
add_mpi_test(co_broadcast 4 ${tests_root}/unit/collectives/co_broadcast_test)
add_mpi_test(co_min 4 ${tests_root}/unit/collectives/co_min_test)
add_mpi_test(co_max 4 ${tests_root}/unit/collectives/co_max_test)
- add_mpi_test(syncall 32 ${tests_root}/unit/sync/syncall)
- add_mpi_test(syncimages 32 ${tests_root}/unit/sync/syncimages)
- add_mpi_test(syncimages2 32 ${tests_root}/unit/sync/syncimages2)
+ add_mpi_test(syncall 8 ${tests_root}/unit/sync/syncall)
+ add_mpi_test(syncimages 8 ${tests_root}/unit/sync/syncimages)
+ add_mpi_test(syncimages2 8 ${tests_root}/unit/sync/syncimages2)
add_mpi_test(duplicate_syncimages 8 ${tests_root}/unit/sync/duplicate_syncimages)
add_mpi_test(co_reduce 4 ${tests_root}/unit/collectives/co_reduce_test)
add_mpi_test(co_reduce_res_im 4 ${tests_root}/unit/collectives/co_reduce_res_im)
- add_mpi_test(syncimages_status 32 ${tests_root}/unit/sync/syncimages_status)
+ add_mpi_test(syncimages_status 8 ${tests_root}/unit/sync/syncimages_status)
add_mpi_test(sync_ring_abort_np3 3 ${tests_root}/unit/sync/sync_image_ring_abort_on_stopped_image)
add_mpi_test(sync_ring_abort_np7 7 ${tests_root}/unit/sync/sync_image_ring_abort_on_stopped_image)
- add_mpi_test(simpleatomics 32 ${tests_root}/unit/simple/atomics)
+ add_mpi_test(simpleatomics 8 ${tests_root}/unit/simple/atomics)
# possible logic error in the following test
# add_mpi_test(increment_my_neighbor 32 ${tests_root}/unit/simple/increment_my_neighbor)
@@ -518,7 +578,7 @@ if(opencoarrays_aware_compiler)
# GFortran PR 78505 only fixed on trunk/gcc 7
add_mpi_test(source-alloc-no-sync 8 ${tests_root}/regression/reported/source-alloc-sync)
endif()
- if (RUN_DEVELOPER_TESTS)
+ if (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER})
add_mpi_test(convert-before-put 3 ${tests_root}/regression/reported/convert-before-put)
endif()
add_mpi_test(event-post 3 ${tests_root}/regression/reported/event-post)
@@ -526,8 +586,27 @@ if(opencoarrays_aware_compiler)
add_mpi_test(co_reduce-factorial-int8 4 ${tests_root}/regression/reported/co_reduce-factorial-int8)
add_mpi_test(co_reduce-factorial-int64 4 ${tests_root}/regression/reported/co_reduce-factorial-int64)
add_mpi_test(co_reduce_string 4 ${tests_root}/unit/collectives/co_reduce_string)
- # remove this before merging into master
-# set_property(TEST co_reduce-factorial PROPERTY WILL_FAIL TRUE)
+
+ # IMAGE FAIL tests
+ if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7)
+ add_mpi_test(image_status_test_1 4 ${tests_root}/unit/fail_images/image_status_test_1)
+ if(CAF_ENABLE_FAILED_IMAGES)
+ # No other way to check that image_fail_test_1 passes.
+ if ((NOT $ENV{TRAVIS}) OR (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER}))
+ add_fault_tolerant_mpi_test(image_fail_test_1 4 ${tests_root}/unit/fail_images/image_fail_test_1)
+ set_property(TEST image_fail_test_1 PROPERTY FAIL_REGULAR_EXPRESSION "Test failed")
+ set_property(TEST image_fail_test_1 PROPERTY PASS_REGULAR_EXPRESSION "Test passed")
+ add_fault_tolerant_mpi_test(image_fail_and_sync_test_1 4 ${tests_root}/unit/fail_images/image_fail_and_sync_test_1)
+ add_fault_tolerant_mpi_test(image_fail_and_sync_test_2 4 ${tests_root}/unit/fail_images/image_fail_and_sync_test_2)
+
+ add_fault_tolerant_mpi_test(image_fail_and_sync_test_3 4 ${tests_root}/unit/fail_images/image_fail_and_sync_test_3)
+ add_fault_tolerant_mpi_test(image_fail_and_status_test_1 4 ${tests_root}/unit/fail_images/image_fail_and_status_test_1)
+ add_fault_tolerant_mpi_test(image_fail_and_failed_images_test_1 4 ${tests_root}/unit/fail_images/image_fail_and_failed_images_test_1)
+ add_fault_tolerant_mpi_test(image_fail_and_stopped_images_test_1 4 ${tests_root}/unit/fail_images/image_fail_and_stopped_images_test_1)
+ add_fault_tolerant_mpi_test(image_fail_and_get_test_1 4 ${tests_root}/unit/fail_images/image_fail_and_get_test_1)
+ endif()
+ endif()
+ endif()
else()
add_test(co_sum_extension ${tests_root}/unit/extensions/test-co_sum-extension.sh)
set_property(TEST co_sum_extension PROPERTY PASS_REGULAR_EXPRESSION "Test passed.")
diff --git a/INSTALL.md b/INSTALL.md
index fb06375..0d19dbf 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -391,6 +391,7 @@ export gcc_install_path=/desired/installation/destination
[URLs]: #
+[linuxbrew]: http://linuxbrew.sh
[APT package]: https://qa.debian.org/popcon.php?package=open-coarrays
[HPCLinux]: http://www.paratools.com/hpclinux/
[Brewfile]: https://github.com/sourceryinstitute/OpenCoarrays/blob/master/Brewfile
diff --git a/cmake/AddInstallationScriptTest.cmake b/cmake/AddInstallationScriptTest.cmake
index b470680..ecf764b 100644
--- a/cmake/AddInstallationScriptTest.cmake
+++ b/cmake/AddInstallationScriptTest.cmake
@@ -1,15 +1,12 @@
macro(add_installation_script_test name path)
# Copy the source to the binary tree
- configure_file(
- ${CMAKE_CURRENT_SOURCE_DIR}/${path}/${name}
- ${CMAKE_CURRENT_BINARY_DIR}/${path}/${name}
- COPYONLY
+ file( COPY "${CMAKE_CURRENT_SOURCE_DIR}/${path}/${name}" DESTINATION "${CMAKE_CURRENT_BINARY_DIR}/${path}"
+ FILE_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
+ DIRECTORY_PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
)
- configure_file(
- ${CMAKE_CURRENT_SOURCE_DIR}/${path}/${name}-usage
- ${CMAKE_CURRENT_BINARY_DIR}/${path}/${name}-usage
- COPYONLY
+ file( COPY "${CMAKE_CURRENT_SOURCE_DIR}/${path}/${name}-usage" DESTINATION "${CMAKE_CURRENT_BINARY_DIR}/${path}"
+ FILE_PERMISSIONS OWNER_READ OWNER_WRITE GROUP_READ WORLD_READ
)
add_test(NAME test-${name} COMMAND "${CMAKE_BINARY_DIR}/${path}/${name}")
set_property(TEST test-${name} PROPERTY WORKING_DIRECTORY "${CMAKE_BINARY_DIR}/${path}")
diff --git a/install.sh b/install.sh
index ba57592..719146e 100755
--- a/install.sh
+++ b/install.sh
@@ -240,8 +240,11 @@ source $opencoarrays_src_dir/prerequisites/install-functions/report_results.sh
if [[ "${arg_v}" == "${__flag_present}" || "${arg_V}" == "opencoarrays" ]]; then
- # Print script copyright if invoked with -v, -V, or --version argument
- opencoarrays_version=$(sed -n 's/\([0-9]\{1,\}\(\.[0-9]\{1,\}\)\{1,\}\)/\1/p' "${opencoarrays_src_dir%/}/.VERSION")
+ # Print script copyright & version if invoked with -v, -V, or
+ # --version argument git attributes handle .VERSION, making it more
+ # robust, but fallback version is still manually included. Search
+ # for the first version string we encounter and extract it using sed:
+ opencoarrays_version=$(sed -n '/[0-9]\{1,\}\(\.[0-9]\{1,\}\)\{1,\}/{s/^\([^.]*\)\([0-9]\{1,\}\(\.[0-9]\{1,\}\)\{1,\}\)\(.*\)/\2/p;q;}' "${opencoarrays_src_dir%/}/.VERSION")
if [[ "${arg_v}" == "${__flag_present}" ]]; then
echo "OpenCoarrays ${opencoarrays_version}"
echo ""
diff --git a/prerequisites/check_version.sh b/prerequisites/check_version.sh
index 7a7dffe..515d91f 100755
--- a/prerequisites/check_version.sh
+++ b/prerequisites/check_version.sh
@@ -81,8 +81,11 @@ elif [[ $1 == '--list' || $1 == '-l' ]]; then
exit 40
elif [[ $1 == '-v' || $1 == '-V' || $1 == '--version' ]]; then
- # Print script copyright if invoked with -v, -V, or --version argument
- opencoarrays_version=$(sed -n 's/\([0-9]\{1,\}\(\.[0-9]\{1,\}\)\{1,\}\)/\1/p' ../.VERSION)
+ # Print script copyright if invoked with -v, -V, or --version
+ # argument Extract version from .VERSION file. Git automatically
+ # inserts various things when performing git archive, so ensure we
+ # extract just the first version string
+ opencoarrays_version=$(sed -n '/[0-9]\{1,\}\(\.[0-9]\{1,\}\)\{1,\}/{s/^\([^.]*\)\([0-9]\{1,\}\(\.[0-9]\{1,\}\)\{1,\}\)\(.*\)/\2/p;q;}' ../.VERSION)
echo "opencoarrays $opencoarrays_version"
echo ""
echo "OpenCoarrays prerequisite version verifier"
diff --git a/prerequisites/install-functions/report_results.sh b/prerequisites/install-functions/report_results.sh
index b917379..0d1b620 100644
--- a/prerequisites/install-functions/report_results.sh
+++ b/prerequisites/install-functions/report_results.sh
@@ -1,21 +1,18 @@
# shellcheck shell=bash disable=SC2154,SC2129,SC2148
report_results()
{
- type_FC=`type ${FC}`
- fully_qualified_FC="/${type_FC#*/}"
+ fully_qualified_FC="$(type -P "${FC}")"
if [[ ${fully_qualified_FC} != *gfortran* ]]; then
emergency "report_results.sh: non-gfortran compiler: \${fully_qualified_FC}=${fully_qualified_FC}"
- fi
+ fi
# Set path_to_FC fully-qualified gfortran location
- compiler_install_root="${fully_qualified_FC%%bin/gfortran*}"
+ compiler_install_root="${fully_qualified_FC%bin/gfortran*}"
- type_MPIFC=`type ${MPIFC}`
- fully_qualified_MPIFC="/${type_MPIFC#*/}"
- mpi_install_root="${fully_qualified_MPIFC%%bin/mpif90*}"
+ fully_qualified_MPIFC="$(type -P "${MPIFC}")"
+ mpi_install_root="${fully_qualified_MPIFC%bin/mpif90*}"
- type_CMAKE=`type ${CMAKE}`
- fully_qualified_CMAKE="/${type_CMAKE#*/}"
- cmake_install_path="${fully_qualified_CMAKE%%/cmake*}"
+ fully_qualified_CMAKE="$(type -P "${CMAKE}")"
+ cmake_install_path="${fully_qualified_CMAKE%/cmake*}"
# Report installation success or failure and record locations for software stack:
if [[ -x "${install_path%/}/bin/caf" && -x "${install_path%/}/bin/cafrun" ]]; then
@@ -35,51 +32,51 @@ report_results()
${SUDO:-} rm setup.csh
fi
# Prepend the OpenCoarrays license to the setup.sh script:
- while IFS='' read -r line || [[ -n "$line" ]]; do
- echo "# $line" >> setup.sh
+ while IFS='' read -r line || [[ -n "${line}" ]]; do
+ echo "# ${line}" >> setup.sh
done < "${opencoarrays_src_dir}/LICENSE"
- while IFS='' read -r line || [[ -n "$line" ]]; do
- echo "# $line" >> setup.csh
+ while IFS='' read -r line || [[ -n "${line}" ]]; do
+ echo "# ${line}" >> setup.csh
done < "${opencoarrays_src_dir}/LICENSE"
echo "# " | tee -a setup.csh setup.sh
echo "# Execute this script via the following command: " | tee -a setup.csh setup.sh
echo "# source ${install_path%/}/setup.sh " | tee -a setup.csh setup.sh
echo " " | tee -a setup.csh setup.sh
- if [[ -x "$cmake_install_path/cmake" ]]; then
+ if [[ -x "${cmake_install_path}/cmake" ]]; then
echo "# Prepend the CMake path to the PATH environment variable:" | tee -a setup.sh setup.csh
- echo "if [[ -z \"\$PATH\" ]]; then " >> setup.sh
+ echo "if [[ -z \"\${PATH}\" ]]; then " >> setup.sh
echo " export PATH=\"${cmake_install_path%/}/\" " >> setup.sh
echo "else " >> setup.sh
- echo " export PATH=\"${cmake_install_path%/}/\":\$PATH " >> setup.sh
+ echo " export PATH=\"${cmake_install_path%/}/\":\${PATH} " >> setup.sh
echo "fi " >> setup.sh
echo "set path = (\"${cmake_install_path%/}\"/\"\$path\") " >> setup.csh
fi
- if [[ -x "$fully_qualified_FC" ]]; then
+ if [[ -x "${fully_qualified_FC}" ]]; then
echo "# Prepend the compiler path to the PATH environment variable:" | tee -a setup.sh setup.csh
- echo "if [[ -z \"\$PATH\" ]]; then " >> setup.sh
+ echo "if [[ -z \"\${PATH}\" ]]; then " >> setup.sh
echo " export PATH=\"${compiler_install_root%/}/bin\" " >> setup.sh
echo "else " >> setup.sh
- echo " export PATH=\"${compiler_install_root%/}/bin:\$PATH\" " >> setup.sh
+ echo " export PATH=\"${compiler_install_root%/}/bin:\${PATH}\" " >> setup.sh
echo "fi " >> setup.sh
echo "set path = (\"${compiler_install_root%/}\"/bin \"\$path\") " >> setup.csh
fi
if [[ -d "${compiler_install_root%/}/lib" || -d "${compiler_install_root%/}/lib64" ]]; then
echo "# Prepend the compiler library paths to the LD_LIBRARY_PATH environment variable:" | tee -a setup.sh setup.csh
compiler_lib_paths="${compiler_install_root%/}/lib64/:${compiler_install_root%/}/lib"
- echo "if [[ -z \"\$LD_LIBRARY_PATH\" ]]; then " >> setup.sh
+ echo "if [[ -z \"\${LD_LIBRARY_PATH}\" ]]; then " >> setup.sh
echo " export LD_LIBRARY_PATH=\"${compiler_lib_paths%/}\" " >> setup.sh
echo "else " >> setup.sh
- echo " export LD_LIBRARY_PATH=\"${compiler_lib_paths%/}:\$LD_LIBRARY_PATH\" " >> setup.sh
+ echo " export LD_LIBRARY_PATH=\"${compiler_lib_paths%/}:\${LD_LIBRARY_PATH}\" " >> setup.sh
echo "fi " >> setup.sh
echo "set LD_LIBRARY_PATH = (\"${compiler_lib_paths%/}\"/bin \"\$LD_LIBRARY_PATH\") " >> setup.csh
fi
echo " " >> setup.sh
- if [[ -x "$mpi_install_root/bin/mpif90" ]]; then
+ if [[ -x "${mpi_install_root}/bin/mpif90" ]]; then
echo "# Prepend the MPI path to the PATH environment variable:" | tee -a setup.sh setup.csh
- echo "if [[ -z \"\$PATH\" ]]; then " >> setup.sh
+ echo "if [[ -z \"\${PATH}\" ]]; then " >> setup.sh
echo " export PATH=\"${mpi_install_root%/}/bin\" " >> setup.sh
echo "else " >> setup.sh
- echo " export PATH=\"${mpi_install_root%/}/bin\":\$PATH " >> setup.sh
+ echo " export PATH=\"${mpi_install_root%/}/bin\":\${PATH} " >> setup.sh
echo "fi " >> setup.sh
echo "set path = (\"${mpi_install_root%/}\"/bin \"\$path\") " >> setup.csh
fi
@@ -91,52 +88,52 @@ report_results()
# the system versions of these packages are present and in the user's path or that the
# user doesn't need them at all (e.g. there was no need to build gfortran from source).
flex_install_path=$("${build_script}" -P flex)
- if [[ -x "$flex_install_path/bin/flex" ]]; then
+ if [[ -x "${flex_install_path}/bin/flex" ]]; then
echo "# Prepend the flex path to the PATH environment variable:" | tee -a setup.sh setup.csh
- echo "if [[ -z \"\$PATH\" ]]; then " >> setup.sh
- echo " export PATH=\"$flex_install_path/bin\" " >> setup.sh
+ echo "if [[ -z \"\${PATH}\" ]]; then " >> setup.sh
+ echo " export PATH=\"${flex_install_path}/bin\" " >> setup.sh
echo "else " >> setup.sh
- echo " export PATH=\"$flex_install_path/bin\":\$PATH " >> setup.sh
+ echo " export PATH=\"${flex_install_path}/bin\":\${PATH} " >> setup.sh
echo "set path = (\"$flex_install_path\"/bin \"\$path\") " >> setup.csh
echo "fi " >> setup.sh
fi
bison_install_path=$("${build_script}" -P bison)
- if [[ -x "$bison_install_path/bin/yacc" ]]; then
+ if [[ -x "${bison_install_path}/bin/yacc" ]]; then
echo "# Prepend the bison path to the PATH environment variable:" | tee -a setup.sh setup.csh
- echo "if [[ -z \"\$PATH\" ]]; then " >> setup.sh
- echo " export PATH=\"$bison_install_path/bin\" " >> setup.sh
+ echo "if [[ -z \"\${PATH}\" ]]; then " >> setup.sh
+ echo " export PATH=\"${bison_install_path}/bin\" " >> setup.sh
echo "else " >> setup.sh
- echo " export PATH=\"$bison_install_path/bin\":\$PATH " >> setup.sh
+ echo " export PATH=\"${bison_install_path}/bin\":\${PATH} " >> setup.sh
echo "fi " >> setup.sh
echo "set path = (\"$bison_install_path\"/bin \"\$path\") " >> setup.csh
fi
m4_install_path=$("${build_script}" -P m4)
- if [[ -x "$m4_install_path/bin/m4" ]]; then
+ if [[ -x "${m4_install_path}/bin/m4" ]]; then
echo "# Prepend the m4 path to the PATH environment variable:" | tee -a setup.sh setup.csh
- echo "if [[ -z \"\$PATH\" ]]; then " >> setup.sh
- echo " export PATH=\"$m4_install_path/bin\" " >> setup.sh
+ echo "if [[ -z \"\${PATH}\" ]]; then " >> setup.sh
+ echo " export PATH=\"${m4_install_path}/bin\" " >> setup.sh
echo "else " >> setup.sh
- echo " export PATH=\"$m4_install_path/bin\":\$PATH " >> setup.sh
+ echo " export PATH=\"${m4_install_path}/bin\":\${PATH} " >> setup.sh
echo "fi " >> setup.sh
echo "set path = (\"$m4_install_path\"/bin \"\$path\") " >> setup.csh
fi
opencoarrays_install_path="${install_path}"
- if [[ -x "$opencoarrays_install_path/bin/caf" ]]; then
+ if [[ -x "${opencoarrays_install_path}/bin/caf" ]]; then
echo "# Prepend the OpenCoarrays path to the PATH environment variable:" | tee -a setup.sh setup.csh
- echo "if [[ -z \"\$PATH\" ]]; then " >> setup.sh
+ echo "if [[ -z \"\${PATH}\" ]]; then " >> setup.sh
echo " export PATH=\"${opencoarrays_install_path%/}/bin\" " >> setup.sh
echo "else " >> setup.sh
- echo " export PATH=\"${opencoarrays_install_path%/}/bin\":\$PATH " >> setup.sh
+ echo " export PATH=\"${opencoarrays_install_path%/}/bin\":\${PATH} " >> setup.sh
echo "fi " >> setup.sh
echo "set path = (\"${opencoarrays_install_path%/}\"/bin \"\$path\") " >> setup.csh
fi
- if ${SUDO:-} mv setup.sh "$opencoarrays_install_path"; then
- setup_sh_location=$opencoarrays_install_path
+ if ${SUDO:-} mv setup.sh "${opencoarrays_install_path}"; then
+ setup_sh_location=${opencoarrays_install_path}
else
setup_sh_location=${PWD}
fi
- if ${SUDO:-} mv setup.csh "$opencoarrays_install_path"; then
- setup_csh_location=$opencoarrays_install_path
+ if ${SUDO:-} mv setup.csh "${opencoarrays_install_path}"; then
+ setup_csh_location=${opencoarrays_install_path}
else
setup_csh_location=${PWD}
fi
@@ -156,10 +153,10 @@ report_results()
echo "OpenCoarrays compiler wrapper (caf), program launcher (cafrun), or prerequisite"
echo "package installer (build), or these programs are not in the following, expected"
echo "location:"
- echo "$install_path/bin."
+ echo "${install_path}/bin."
echo "Please review the following file for more information:"
- echo "$install_path/$installation_record"
- echo "and submit an bug report at https://github.com/sourceryinstitute/opencoarrays/issues"
+ echo "${install_path}/${installation_record}"
+ echo "and submit an bug report at https://github.com/sourceryinstitute/opencoarrays/issues/new"
echo "[exit 100]"
exit 100
diff --git a/src/libcaf.h b/src/libcaf.h
index 166c618..3bf9aa5 100644
--- a/src/libcaf.h
+++ b/src/libcaf.h
@@ -63,6 +63,7 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */
#define STAT_LOCKED_OTHER_IMAGE 2
#define STAT_DUP_SYNC_IMAGES 3
#define STAT_STOPPED_IMAGE 6000
+#define STAT_FAILED_IMAGE 6001
/* Describes what type of array we are registerring. Keep in sync with
gcc/fortran/trans.h. */
@@ -88,11 +89,15 @@ typedef enum caf_deregister_t {
caf_deregister_t;
typedef void* caf_token_t;
-
+#ifdef GCC_GE_7
+/** Add a dummy type representing teams in coarrays. */
+typedef void * caf_team_t;
+#endif
/* Linked list of static coarrays registered. */
typedef struct caf_static_t {
caf_token_t token;
+ caf_token_t stopped_token;
struct caf_static_t *prev;
}
caf_static_t;
@@ -228,13 +233,15 @@ void PREFIX (deregister) (caf_token_t *, int *, char *, int);
#endif
void PREFIX (caf_get) (caf_token_t, size_t, int, gfc_descriptor_t *,
- caf_vector_t *, gfc_descriptor_t *, int, int, int);
+ caf_vector_t *, gfc_descriptor_t *, int, int, bool, int *);
void PREFIX (caf_send) (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, bool,
+ int *);
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);
+ gfc_descriptor_t *, caf_vector_t *, int, int, bool,
+ int *);
#ifdef GCC_GE_7
void PREFIX(get_by_ref) (caf_token_t, int,
@@ -263,9 +270,16 @@ void PREFIX (sync_all) (int *, char *, int);
void PREFIX (sync_images) (int, int[], int *, char *, int);
void PREFIX (sync_memory) (int *, char *, int);
+void PREFIX (stop_str) (const char *, int32_t) __attribute__ ((noreturn));
+void PREFIX (stop) (int32_t) __attribute__ ((noreturn));
void PREFIX (error_stop_str) (const char *, int32_t)
__attribute__ ((noreturn));
void PREFIX (error_stop) (int32_t) __attribute__ ((noreturn));
+void PREFIX (fail_image) (void) __attribute__ ((noreturn));
+
+int PREFIX (image_status) (int);
+void PREFIX (failed_images) (gfc_descriptor_t *, int, int *);
+void PREFIX (stopped_images) (gfc_descriptor_t *, int, int *);
void PREFIX (atomic_define) (caf_token_t, size_t, int, void *, int *, int, int);
void PREFIX (atomic_ref) (caf_token_t, size_t, int, void *, int *, int, int);
diff --git a/src/mpi/CMakeLists.txt b/src/mpi/CMakeLists.txt
index 6f4490b..fa37b4b 100644
--- a/src/mpi/CMakeLists.txt
+++ b/src/mpi/CMakeLists.txt
@@ -28,6 +28,67 @@ if(CAF_EXPOSE_INIT_FINALIZE)
add_definitions(-DEXPOSE_INIT_FINALIZE)
endif()
+include(CheckIncludeFile)
+CHECK_INCLUDE_FILE("alloca.h" HAVE_ALLOCA)
+if(NOT HAVE_ALLOCA)
+ add_definitions(-DALLOCA_MISSING)
+ message(WARNING "Could not find <alloca.h>. Assuming functionality is provided elsewhere.")
+endif()
+
+#----------------------------------------------------------------------
+# Test if MPI implementation provides features needed for failed images
+#----------------------------------------------------------------------
+set(NEEDED_SYMBOLS MPIX_ERR_PROC_FAILED;MPIX_ERR_REVOKED;MPIX_Comm_failure_ack;MPIX_Comm_failure_get_acked;MPIX_Comm_shrink;MPIX_Comm_agree)
+set(MPI_HAS_FAULT_TOL_EXT YES)
+set(old_cmake_required_includes "${CMAKE_REQUIRED_INCLUDES}")
+if(CMAKE_REQUIRED_INCLUDES)
+ set(CMAKE_REQUIRED_INCLUDES ${CMAKE_REQUIRED_INCLUDES};${MPI_C_INCLUDE_PATH})
+else()
+ set(CMAKE_REQUIRED_INCLUDES ${MPI_C_INCLUDE_PATH})
+endif()
+set(old_cmake_required_flags "${CMAKE_REQUIRED_FLAGS}")
+if(CMAKE_REQUIRED_FLAGS)
+ set(CMAKE_REQUIRED_FLAGS ${CMAKE_REQUIRED_FLAGS};${MPI_C_COMPILE_FLAGS};${MPI_C_LINK_FLAGS})
+else()
+ set(CMAKE_REQUIRED_FLAGS ${MPI_C_COMPILE_FLAGS};${MPI_C_LINK_FLAGS})
+endif()
+set(old_cmake_required_libraries "${CMAKE_REQUIRED_LIBRARIES}")
+if(CMAKE_REQUIRED_LIBRARIES)
+ set(CMAKE_REQUIRED_LIBRARIES ${CMAKE_REQUIRED_LIBRARIES};${MPI_C_LIBRARIES})
+else()
+ set(CMAKE_REQUIRED_LIBRARIES ${MPI_C_LIBRARIES})
+endif()
+
+set(MPI_HEADERS mpi.h)
+CHECK_INCLUDE_FILE("mpi-ext.h" HAVE_MPI_EXT)
+if(HAVE_MPI_EXT)
+ add_definitions(-DHAVE_MPI_EXT_H)
+ set(MPI_HEADERS ${MPI_HEADERS};mpi-ext.h)
+endif()
+include(CheckSymbolExists)
+foreach(symbol ${NEEDED_SYMBOLS})
+ CHECK_SYMBOL_EXISTS(${symbol} ${MPI_HEADERS} HAVE_${symbol})
+ if(NOT HAVE_${symbol})
+ message( STATUS "\${HAVE_${symbol}} = ${HAVE_${symbol}}")
+ message( WARNING "Disabling Failed Image support due to lack of support in the current MPI implementation.")
+ set(MPI_HAS_FAULT_TOL_EXT NO)
+ break() # no need to keep looking
+ endif()
+endforeach(symbol)
+set(CMAKE_REQUIRED_INCLUDES ${old_cmake_required_includes})
+set(CMAKE_REQUIRED_FLAGS ${old_cmake_required_flags})
+set(CMAKE_REQUIRED_LIBRARIES ${old_cmake_required_libraries})
+
+if(MPI_HAS_FAULT_TOL_EXT)
+ option(CAF_ENABLE_FAILED_IMAGES "Enable failed images support" TRUE)
+else()
+ set(CAF_ENABLE_FAILED_IMAGES FALSE CACHE BOOL "Enable failed images support" FORCE)
+endif()
+
+if(CAF_ENABLE_FAILED_IMAGES)
+ add_definitions(-DUSE_FAILED_IMAGES)
+endif()
+
# Determine whether and how to include OpenCoarrays module based on if the Fortran MPI compiler:
# - workds
# - is compatible with the fortran compiler used to build the MPI implementation
@@ -76,14 +137,14 @@ set(exe_dir ${CMAKE_BINARY_DIR}/bin_staging)
set(compiler_wrapper ${exe_dir}/caf)
install(
FILES "${compiler_wrapper}"
- PERMISSIONS WORLD_EXECUTE WORLD_READ OWNER_EXECUTE OWNER_READ GROUP_EXECUTE GROUP_READ
+ PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
DESTINATION "${CMAKE_INSTALL_BINDIR}"
)
file(READ ${CMAKE_CURRENT_SOURCE_DIR}/../extensions/caf-head CAF_HEADER)
file(WRITE "${compiler_wrapper}" "${CAF_HEADER}\n")
file(APPEND "${compiler_wrapper}" "caf_mod_dir=\"${CMAKE_INSTALL_FULL_INCLUDEDIR}/mod\"\n")
file(APPEND "${compiler_wrapper}" "caf_lib_dir=\"${CMAKE_INSTALL_FULL_LIBDIR}\"\n")
-file(APPEND "${compiler_wrapper}" "caf_version=${PROJECT_VERSION}\n")
+file(APPEND "${compiler_wrapper}" "caf_version=${full_git_describe}\n")
if(gfortran_compiler)
file(APPEND "${compiler_wrapper}" "link_args='-fcoarray=lib -lcaf_mpi'\n")
elseif(portland_group_compiler)
@@ -109,12 +170,12 @@ file(APPEND "${compiler_wrapper}" "${FOOTER}")
set(caf_launcher ${exe_dir}/cafrun)
install(
FILES "${caf_launcher}"
- PERMISSIONS WORLD_EXECUTE WORLD_READ OWNER_EXECUTE OWNER_READ GROUP_EXECUTE GROUP_READ
+ PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
DESTINATION "${CMAKE_INSTALL_BINDIR}"
)
file(READ ${CMAKE_CURRENT_SOURCE_DIR}/../extensions/cafrun-head CAFRUN_HEADER)
file(WRITE "${caf_launcher}" "${CAFRUN_HEADER}\n")
-file(APPEND "${caf_launcher}" "caf_version=${PROJECT_VERSION}\n")
+file(APPEND "${caf_launcher}" "caf_version=${full_git_describe}\n")
file(APPEND "${caf_launcher}" "CAFRUN=${MPIEXEC}\n")
file(READ ${CMAKE_CURRENT_SOURCE_DIR}/../extensions/cafrun-foot FOOTER)
diff --git a/src/mpi/mpi_caf.c b/src/mpi/mpi_caf.c
index a0f496f..8704212 100644
--- a/src/mpi/mpi_caf.c
+++ b/src/mpi/mpi_caf.c
@@ -37,10 +37,20 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */
#include <stdlib.h>
#include <string.h> /* For memcpy. */
#include <stdarg.h> /* For variadic arguments. */
-#include <alloca.h>
+#ifndef ALLOCA_MISSING
+#include <alloca.h> /* Assume functionality provided elsewhere if missing */
+#endif
#include <unistd.h>
#include <mpi.h>
#include <pthread.h>
+#include <signal.h> /* For raise */
+
+#ifdef HAVE_MPI_EXT_H
+#include <mpi-ext.h>
+#endif
+#ifdef USE_FAILED_IMAGES
+ #define WITH_FAILED_IMAGES 1
+#endif
#include "libcaf.h"
@@ -48,7 +58,22 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */
/* #define GFC_CAF_CHECK 1 */
+#ifndef EXTRA_DEBUG_OUTPUT
+#define dprint(...)
+#else
+#define dprint(args...) fprintf (stderr, args)
+#endif
+
#ifdef GCC_GE_7
+enum flags_t {
+ /** Set when this token has memory associated to it. */
+ FLAG_ASSOCIATED = 1,
+ /** Set when the memory associated to this token is not owned by the
+ mpi-library, i.e., the mpi-library does not free the memory. This happens for
+ asynchronously allocated memory, which is attached using MPI_Win_attach. */
+ FLAG_MEM_NOT_OWNED = 2,
+};
+
/** The caf-token of the mpi-library.
Objects of this data structure are owned by the library and are treated as a
@@ -76,6 +101,12 @@ typedef struct mpi_caf_token_t
window gives access to the descriptor on remote images. When the object is
scalar, then this is NULL. */
MPI_Win *desc;
+ /** Flags specifying the state of this token. For a description of available
+ flags see the flags_t. */
+ unsigned *flags;
+ /** This window allows access the local flags member of the associated
+ token. */
+ MPI_Win flags_win;
} mpi_caf_token_t;
#define TOKEN(X) &(((mpi_caf_token_t *) (X))->memptr)
#else
@@ -83,7 +114,12 @@ typedef MPI_Win *mpi_caf_token_t;
#define TOKEN(X) ((mpi_caf_token_t) (X))
#endif
-static void error_stop (int error) __attribute__ ((noreturn));
+/* Forward declaration of prototype. */
+
+static void terminate_internal (int stat_code, int exit_code)
+ __attribute__ ((noreturn));
+static void sync_images_internal (int count, int images[], int *stat,
+ char *errmsg, int errmsg_len, bool internal);
/* Global variables. */
static int caf_this_image;
@@ -94,12 +130,12 @@ static int caf_is_finalized = 0;
MPI_Info mpi_info_same_size;
#endif // MPI_VERSION
-/*Sync image part*/
+/* Variables needed for syncing images. */
-static int *orders;
static int *images_full;
MPI_Request *sync_handles;
static int *arrived;
+static const int MPI_TAG_CAF_SYNC_IMAGES = 424242;
/* Pending puts */
#if defined(NONBLOCKING_PUT) && !defined(CAF_MPI_LOCK_UNLOCK)
@@ -137,6 +173,39 @@ char err_buffer[MPI_MAX_ERROR_STRING];
MPI_COMM_WORLD for interoperability purposes. */
MPI_Comm CAF_COMM_WORLD;
+#ifdef WITH_FAILED_IMAGES
+/* The stati of the other images. image_stati is an array of size
+ * caf_num_images at the beginning the status of each image is noted here
+ * where the index is the image number minus one. */
+int *image_stati;
+
+/* This gives the number of all images that are known to have failed. */
+int num_images_failed = 0;
+
+/* This is the number of all images that are known to have stopped. */
+int num_images_stopped = 0;
+
+/* The async. request-handle to all participating images. */
+MPI_Request alive_request;
+
+/* This dummy is used for the alive request. Its content is arbitrary and
+ * never read. Its just a memory location where one could put something,
+ * which is never done. */
+int alive_dummy;
+
+/* The mpi error-handler object associate to CAF_COMM_WORLD. */
+MPI_Errhandler failed_stopped_CAF_COMM_WORLD_mpi_errorhandler;
+
+/* The monitor comm for detecting failed images. We can not attach the monitor
+ * to CAF_COMM_WORLD or the messages send by sync images would be caught by
+ * the monitor. */
+MPI_Comm alive_comm;
+
+/* Set when entering a sync_images_internal, to prevent the error handler from
+ * eating our messages. */
+bool no_stopped_images_check_in_errhandler = 0;
+#endif
+
/* For MPI interoperability, allow external initialization
(and thus finalization) of MPI. */
bool caf_owns_mpi = false;
@@ -243,7 +312,10 @@ void helperFunction()
}
}
#endif
+
+
/* Keep in sync with single.c. */
+
static void
caf_runtime_error (const char *message, ...)
{
@@ -262,31 +334,244 @@ caf_runtime_error (const char *message, ...)
exit (EXIT_FAILURE);
}
-/* FIXME: CMake chokes on the "inline" keyword below. If we can detect that CMake is */
-/* being used, we could add something of the form "#ifdef _CMAKE" to remove the */
-/* keyword only when building with CMake */
-/* inline */ void locking_atomic_op(MPI_Win win, int *value, int newval,
- int compare, int image_index, int index)
+/* Forward declaration of the feature unsupported message for failed images
+ * functions. */
+static void
+unsupported_fail_images_message(const char * functionname);
+
+/* Forward declaration of the feature unimplemented message for allocatable
+ * components. */
+static void
+unimplemented_alloc_comps_message(const char * functionname);
+
+static void
+locking_atomic_op(MPI_Win win, int *value, int newval,
+ int compare, int image_index, int index)
+{
+ CAF_Win_lock (MPI_LOCK_EXCLUSIVE, image_index-1, win);
+ MPI_Compare_and_swap (&newval,&compare,value, MPI_INT,image_index-1,
+ index*sizeof(int), win);
+ CAF_Win_unlock (image_index-1, win);
+}
+
+
+/* Define a helper to check whether the image at the given index is healthy,
+ * i.e., it hasn't failed. */
+#ifdef WITH_FAILED_IMAGES
+#define check_image_health(image_index, stat) \
+ if (image_stati[image_index - 1] == STAT_FAILED_IMAGE) \
+ { \
+ if (stat == NULL) terminate_internal (STAT_FAILED_IMAGE, 0); \
+ *stat = STAT_FAILED_IMAGE; \
+ return; \
+ }
+#else
+#define check_image_health(image_index, stat)
+#endif
+
+#ifdef WITH_FAILED_IMAGES
+/** Handle failed image's errors and try to recover the remaining process to
+ * allow the user to detect an image fail and exit gracefully. */
+static void
+failed_stopped_errorhandler_function (MPI_Comm* pcomm, int* perr, ...)
{
- CAF_Win_lock (MPI_LOCK_EXCLUSIVE, image_index-1, win);
- MPI_Compare_and_swap (&newval,&compare,value, MPI_INT,image_index-1,
- index*sizeof(int), win);
- CAF_Win_unlock (image_index-1, win);
+ MPI_Comm comm, shrunk, newcomm;
+ int num_failed_in_group, i, err;
+ MPI_Group comm_world_group, failed_group;
+ int *ranks_of_failed_in_comm_world, *ranks_failed;
+ int ns, srank, crank, rc, flag, drank, ierr, newrank;
+ bool stopped = false;
+
+ comm = *pcomm;
+
+ MPI_Error_class (*perr, &err);
+ if (err != MPIX_ERR_PROC_FAILED && err != MPIX_ERR_REVOKED)
+ {
+ /* We can handle PROC_FAILED and REVOKED ones only. */
+ char errstr[MPI_MAX_ERROR_STRING];
+ int errlen;
+ MPI_Error_string (err, errstr, &errlen);
+ /* We can't use caf_runtime_error here, because that would exit, which
+ * means only the one process will stop, but we need to stop MPI
+ * completely, which can be done by calling MPI_Abort(). */
+ fprintf (stderr, "Fortran runtime error on image #%d:\nMPI error: '%s'.\n",
+ caf_this_image, errstr);
+ MPI_Abort (*pcomm, err);
+ }
+
+ dprint ("%d/%d: %s (error = %d)\n", caf_this_image, caf_num_images, __FUNCTION__, err);
+
+ MPIX_Comm_failure_ack (comm);
+ MPIX_Comm_failure_get_acked (comm, &failed_group);
+ MPI_Group_size (failed_group, &num_failed_in_group);
+
+ dprint ("%d/%d: %s: %d images failed.\n", caf_this_image, caf_num_images, __FUNCTION__, num_failed_in_group);
+ if (num_failed_in_group <= 0)
+ {
+ *perr = MPI_SUCCESS;
+ return;
+ }
+ if (num_failed_in_group > caf_num_images)
+ {
+ *perr = MPI_SUCCESS;
+ return;
+ }
+
+ MPI_Comm_group (comm, &comm_world_group);
+ ranks_of_failed_in_comm_world = (int *) alloca (sizeof (int)
+ * num_failed_in_group);
+ ranks_failed = (int *) alloca (sizeof (int) * num_failed_in_group);
+ for (i = 0; i < num_failed_in_group; ++i)
+ ranks_failed[i] = i;
+ /* Now translate the ranks of the failed images into communicator world. */
+ MPI_Group_translate_ranks (failed_group, num_failed_in_group, ranks_failed,
+ comm_world_group, ranks_of_failed_in_comm_world);
+
+ num_images_failed += num_failed_in_group;
+
+ if (!no_stopped_images_check_in_errhandler)
+ {
+ int buffer, flag;
+ MPI_Request req;
+ MPI_Status request_status;
+ dprint ("%d/%d: Checking for stopped images.\n", caf_this_image,
+ caf_num_images);
+ ierr = MPI_Irecv (&buffer, 1, MPI_INT, MPI_ANY_SOURCE, MPI_TAG_CAF_SYNC_IMAGES,
+ CAF_COMM_WORLD, &req);
+ if (ierr == MPI_SUCCESS)
+ {
+ ierr = MPI_Test (&req, &flag, &request_status);
+ if (flag)
+ {
+ // Received a result
+ if (buffer == STAT_STOPPED_IMAGE)
+ {
+ dprint ("%d/%d: Image #%d found stopped.\n",
+ caf_this_image, caf_num_images, request_status.MPI_SOURCE);
+ stopped = true;
+ if (image_stati[request_status.MPI_SOURCE] == 0)
+ ++num_images_stopped;
+ image_stati[request_status.MPI_SOURCE] = STAT_STOPPED_IMAGE;
+ }
+ }
+ else
+ {
+ dprint ("%d/%d: No stopped images found.\n",
+ caf_this_image, caf_num_images);
+ MPI_Cancel (&req);
+ }
+ }
+ else
+ {
+ int err;
+ MPI_Error_class (ierr, &err);
+ dprint ("%d/%d: Error on checking for stopped images %d.\n",
+ caf_this_image, caf_num_images, err);
+ }
+ }
+
+ /* TODO: Consider whether removing the failed image from images_full will be
+ * necessary. This is more or less politics. */
+ for (i = 0; i < num_failed_in_group; ++i)
+ {
+ if (ranks_of_failed_in_comm_world[i] >= 0
+ && ranks_of_failed_in_comm_world[i] < caf_num_images)
+ {
+ if (image_stati[ranks_of_failed_in_comm_world[i]] == 0)
+ image_stati[ranks_of_failed_in_comm_world[i]] = STAT_FAILED_IMAGE;
+ }
+ else
+ {
+ dprint ("%d/%d: Rank of failed image %d out of range of images 0..%d.\n",
+ caf_this_image, caf_num_images, ranks_of_failed_in_comm_world[i],
+ caf_num_images);
+ }
+ }
+
+redo:
+ dprint ("%d/%d: %s: Before shrink. \n", caf_this_image, caf_num_images, __FUNCTION__);
+ ierr = MPIX_Comm_shrink (*pcomm, &shrunk);
+ dprint ("%d/%d: %s: After shrink, rc = %d.\n", caf_this_image, caf_num_images, __FUNCTION__, ierr);
+ MPI_Comm_set_errhandler (shrunk, failed_stopped_CAF_COMM_WORLD_mpi_errorhandler);
+ MPI_Comm_size (shrunk, &ns);
+ MPI_Comm_rank (shrunk, &srank);
+
+ MPI_Comm_rank (*pcomm, &crank);
+
+ dprint ("%d/%d: %s: After getting ranks, ns = %d, srank = %d, crank = %d.\n",
+ caf_this_image, caf_num_images, __FUNCTION__, ns, srank, crank);
+
+ /* Split does the magic: removing spare processes and reordering ranks
+ * so that all surviving processes remain at their former place */
+ rc = MPI_Comm_split (shrunk, crank < 0 ? MPI_UNDEFINED : 1, crank, &newcomm);
+ MPI_Comm_rank (newcomm, &newrank);
+ dprint ("%d/%d: %s: After split, rc = %d, rank = %d.\n", caf_this_image, caf_num_images, __FUNCTION__, rc, newrank);
+ flag = (rc == MPI_SUCCESS);
+ /* Split or some of the communications above may have failed if
+ * new failures have disrupted the process: we need to
+ * make sure we succeeded at all ranks, or retry until it works. */
+ flag = MPIX_Comm_agree (newcomm, &flag);
+ dprint ("%d/%d: %s: After agree, flag = %d.\n", caf_this_image, caf_num_images, __FUNCTION__, flag);
+
+ MPI_Comm_rank (newcomm, &drank);
+ dprint ("%d/%d: %s: After rank, drank = %d.\n", caf_this_image, caf_num_images, __FUNCTION__, drank);
+
+ MPI_Comm_free (&shrunk);
+ if (MPI_SUCCESS != flag) {
+ if (MPI_SUCCESS == rc)
+ MPI_Comm_free (&newcomm);
+ goto redo;
+ }
+
+ {
+ int cmpres;
+ ierr = MPI_Comm_compare (*pcomm, CAF_COMM_WORLD, &cmpres);
+ dprint ("%d/%d: %s: Comm_compare(*comm, CAF_COMM_WORLD, res = %d) = %d.\n", caf_this_image,
+ caf_num_images, __FUNCTION__, cmpres, ierr);
+ ierr = MPI_Comm_compare (*pcomm, alive_comm, &cmpres);
+ dprint ("%d/%d: %s: Comm_compare(*comm, alive_comm, res = %d) = %d.\n", caf_this_image,
+ caf_num_images, __FUNCTION__, cmpres, ierr);
+ if (cmpres == MPI_CONGRUENT)
+ {
+ MPI_Win_detach (*stat_tok, &img_status);
+ dprint ("%d/%d: %s: detached win img_status.\n", caf_this_image, caf_num_images, __FUNCTION__);
+ MPI_Win_free (stat_tok);
+ dprint ("%d/%d: %s: freed win img_status.\n", caf_this_image, caf_num_images, __FUNCTION__);
+ MPI_Win_create (&img_status, sizeof (int), 1, mpi_info_same_size, newcomm,
+ stat_tok);
+ dprint ("%d/%d: %s: (re-)created win img_status.\n", caf_this_image, caf_num_images, __FUNCTION__);
+ CAF_Win_lock_all (*stat_tok);
+ dprint ("%d/%d: %s: Win_lock_all on img_status.\n", caf_this_image, caf_num_images, __FUNCTION__);
+ }
+ }
+ /* Also free the old communicator before replacing it. */
+ MPI_Comm_free (pcomm);
+ *pcomm = newcomm;
+
+ *perr = stopped ? STAT_STOPPED_IMAGE : STAT_FAILED_IMAGE;
}
+#endif
void mutex_lock(MPI_Win win, int image_index, int index, int *stat,
int *acquired_lock, char *errmsg, int errmsg_len)
{
const char msg[] = "Already locked";
#if MPI_VERSION >= 3
- int value=1, compare = 0, newval = caf_this_image, i = 1;
+ int value = 0, compare = 0, newval = caf_this_image, ierr = 0, i = 0;
+#ifdef WITH_FAILED_IMAGES
+ int flag, check_failure = 100, zero = 0;
+#endif
if(stat != NULL)
*stat = 0;
- locking_atomic_op(win, &value, newval, compare, image_index, index);
+#ifdef WITH_FAILED_IMAGES
+ MPI_Test(&alive_request, &flag, MPI_STATUS_IGNORE);
+#endif
+
+ locking_atomic_op (win, &value, newval, compare, image_index, index);
- if(value == caf_this_image && image_index == caf_this_image)
+ if (value == caf_this_image && image_index == caf_this_image)
goto stat_error;
if(acquired_lock != NULL)
@@ -298,25 +583,50 @@ void mutex_lock(MPI_Win win, int image_index, int index, int *stat,
return;
}
- while(value != 0)
+ while (value != 0)
{
+ ++i;
+#ifdef WITH_FAILED_IMAGES
+ if (i == check_failure)
+ {
+ i = 1;
+ MPI_Test (&alive_request, &flag, MPI_STATUS_IGNORE);
+ }
+#endif
+
locking_atomic_op(win, &value, newval, compare, image_index, index);
- usleep(caf_this_image*i);
- i++;
+#ifdef WITH_FAILED_IMAGES
+ if (image_stati[value] == STAT_FAILED_IMAGE)
+ {
+ CAF_Win_lock (MPI_LOCK_EXCLUSIVE, image_index - 1, win);
+ /* MPI_Fetch_and_op(&zero, &newval, MPI_INT, image_index - 1, index * sizeof(int), MPI_REPLACE, win); */
+ MPI_Compare_and_swap (&zero, &value, &newval, MPI_INT, image_index - 1, index * sizeof (int), win);
+ CAF_Win_unlock (image_index - 1, win);
+ break;
+ }
+#else
+ usleep(caf_this_image * i);
+#endif
}
+ if (stat)
+ *stat = ierr;
+ else if (ierr == STAT_FAILED_IMAGE)
+ terminate_internal (ierr, 0);
+
return;
stat_error:
- if(errmsg != NULL)
+ if (errmsg != NULL)
{
memset(errmsg,' ',errmsg_len);
memcpy(errmsg, msg, MIN(errmsg_len,strlen(msg)));
}
+
if(stat != NULL)
*stat = 99;
else
- error_stop(99);
+ terminate_internal(99, 1);
#else // MPI_VERSION
#warning Locking for MPI-2 is not implemented
printf ("Locking for MPI-2 is not supported, please update your MPI implementation\n");
@@ -330,17 +640,26 @@ void mutex_unlock(MPI_Win win, int image_index, int index, int *stat,
if(stat != NULL)
*stat = 0;
#if MPI_VERSION >= 3
- int value=1, compare = 1, newval = 0;
+ int value=1, ierr = 0, newval = 0;
+#ifdef WITH_FAILED_IMAGES
+ int flag;
- /* locking_atomic_op(win, &value, newval, compare, image_index, index); */
+ MPI_Test(&alive_request, &flag, MPI_STATUS_IGNORE);
+#endif
CAF_Win_lock (MPI_LOCK_EXCLUSIVE, image_index-1, win);
MPI_Fetch_and_op(&newval, &value, MPI_INT, image_index-1, index*sizeof(int), MPI_REPLACE, win);
CAF_Win_unlock (image_index-1, win);
- if(value == 0)
- goto stat_error;
+ /* Temporarily commented */
+ /* if(value == 0) */
+ /* goto stat_error; */
+ if(stat)
+ *stat = ierr;
+ else if(ierr == STAT_FAILED_IMAGE)
+ terminate_internal (ierr, 0);
+
return;
stat_error:
@@ -352,7 +671,7 @@ stat_error:
if(stat != NULL)
*stat = 99;
else
- error_stop(99);
+ terminate_internal(99, 1);
#else // MPI_VERSION
#warning Locking for MPI-2 is not implemented
printf ("Locking for MPI-2 is not supported, please update your MPI implementation\n");
@@ -363,21 +682,20 @@ stat_error:
GASNet initialization happened before. */
void
-#ifdef COMPILER_SUPPORTS_CAF_INTRINSICS
-_gfortran_caf_init (int *argc, char ***argv)
-#else
PREFIX (init) (int *argc, char ***argv)
-#endif
{
+#ifdef WITH_FAILED_IMAGES
+ int flag;
+#endif
if (caf_num_images == 0)
{
- int ierr = 0, i = 0, j = 0;
+ int ierr = 0, i = 0, j = 0, rc;
int is_init = 0, prior_thread_level = MPI_THREAD_SINGLE;
- MPI_Initialized(&is_init);
+ MPI_Initialized (&is_init);
if (is_init) {
- MPI_Query_thread(&prior_thread_level);
+ MPI_Query_thread (&prior_thread_level);
}
#ifdef HELPER
int prov_lev=0;
@@ -385,17 +703,17 @@ PREFIX (init) (int *argc, char ***argv)
prov_lev = prior_thread_level;
caf_owns_mpi = false;
} else {
- MPI_Init_thread(argc, argv, MPI_THREAD_MULTIPLE, &prov_lev);
+ MPI_Init_thread (argc, argv, MPI_THREAD_MULTIPLE, &prov_lev);
caf_owns_mpi = true;
}
- if(caf_this_image == 0 && MPI_THREAD_MULTIPLE != prov_lev)
+ if (caf_this_image == 0 && MPI_THREAD_MULTIPLE != prov_lev)
caf_runtime_error ("MPI_THREAD_MULTIPLE is not supported: %d", prov_lev);
#else
if (is_init) {
caf_owns_mpi = false;
} else {
- MPI_Init(argc, argv);
+ MPI_Init (argc, argv);
caf_owns_mpi = true;
}
#endif
@@ -404,69 +722,137 @@ PREFIX (init) (int *argc, char ***argv)
/* Duplicate MPI_COMM_WORLD so that no CAF internal functions
use it - this is critical for MPI-interoperability. */
- MPI_Comm_dup(MPI_COMM_WORLD, &CAF_COMM_WORLD);
+ rc = MPI_Comm_dup (MPI_COMM_WORLD, &CAF_COMM_WORLD);
+#ifdef WITH_FAILED_IMAGES
+ flag = (MPI_SUCCESS == rc);
+ rc = MPIX_Comm_agree (MPI_COMM_WORLD, &flag);
+ if (rc != MPI_SUCCESS) {
+ dprint ("%d/%d: %s: MPIX_Comm_agree(flag = %d) = %d.\n",
+ caf_this_image, caf_num_images, __FUNCTION__, flag, rc);
+ fflush (stderr);
+ MPI_Abort (MPI_COMM_WORLD, 10000);
+ }
+ MPI_Barrier (MPI_COMM_WORLD);
+#endif
- MPI_Comm_size(CAF_COMM_WORLD, &caf_num_images);
- MPI_Comm_rank(CAF_COMM_WORLD, &caf_this_image);
+ MPI_Comm_size (CAF_COMM_WORLD, &caf_num_images);
+ MPI_Comm_rank (CAF_COMM_WORLD, &caf_this_image);
- caf_this_image++;
+ ++caf_this_image;
caf_is_finalized = 0;
+ /* BEGIN SYNC IMAGE preparation
+ * Prepare memory for syncing images. */
images_full = (int *) calloc (caf_num_images-1, sizeof (int));
-
- for (i = 1; i <= caf_num_images; ++i)
+ for (i = 1, j = 0; i <= caf_num_images; ++i)
if (i != caf_this_image)
- {
- images_full[j] = i;
- j++;
- }
+ images_full[j++] = i;
- orders = calloc (caf_num_images, sizeof (int));
arrived = calloc (caf_num_images, sizeof (int));
-
- sync_handles = malloc(caf_num_images * sizeof(MPI_Request));
-
- stat_tok = malloc (sizeof(MPI_Win));
+ sync_handles = malloc (caf_num_images * sizeof (MPI_Request));
+ /* END SYNC IMAGE preparation. */
+
+ stat_tok = malloc (sizeof (MPI_Win));
+
+#ifdef WITH_FAILED_IMAGES
+ MPI_Comm_dup (MPI_COMM_WORLD, &alive_comm);
+ /* Handling of failed/stopped images is done by setting an error handler
+ * on a asynchronous request to each other image. For a failing image
+ * the request will trigger the call of the error handler thus allowing
+ * each other image to handle the failed/stopped image. */
+ MPI_Comm_create_errhandler (failed_stopped_errorhandler_function,
+ &failed_stopped_CAF_COMM_WORLD_mpi_errorhandler);
+ MPI_Comm_set_errhandler (CAF_COMM_WORLD,
+ failed_stopped_CAF_COMM_WORLD_mpi_errorhandler);
+ MPI_Comm_set_errhandler (alive_comm,
+ failed_stopped_CAF_COMM_WORLD_mpi_errorhandler);
+ MPI_Comm_set_errhandler (MPI_COMM_WORLD, MPI_ERRORS_RETURN);
+
+ MPI_Irecv (&alive_dummy, 1, MPI_INT, MPI_ANY_SOURCE, MPI_ANY_TAG,
+ alive_comm, &alive_request);
+
+ image_stati = (int *) calloc (caf_num_images, sizeof (int));
+#endif
#if MPI_VERSION >= 3
MPI_Info_create (&mpi_info_same_size);
MPI_Info_set (mpi_info_same_size, "same_size", "true");
+
/* Setting img_status */
- MPI_Win_create(&img_status, sizeof(int), 1, mpi_info_same_size, CAF_COMM_WORLD, stat_tok);
+ MPI_Win_create (&img_status, sizeof(int), 1, mpi_info_same_size, CAF_COMM_WORLD, stat_tok);
CAF_Win_lock_all (*stat_tok);
#else
- MPI_Win_create(&img_status, sizeof(int), 1, MPI_INFO_NULL, CAF_COMM_WORLD, stat_tok);
+ MPI_Win_create (&img_status, sizeof(int), 1, MPI_INFO_NULL, CAF_COMM_WORLD, stat_tok);
#endif // MPI_VERSION
}
- /* MPI_Barrier(CAF_COMM_WORLD); */
}
-/* Forward declaration of sync_images. */
-void
-sync_images_internal (int count, int images[], int *stat, char *errmsg,
- int errmsg_len, bool internal);
-
-/* Finalize coarray program. */
+/* Internal finalize of coarray program. */
void
-#ifdef COMPILER_SUPPORTS_CAF_INTRINSICS
-_gfortran_caf_finalize (void)
-#else
-PREFIX (finalize) (void)
-#endif
+finalize_internal (int status_code)
{
+ dprint ("%d/%d: %s(status_code = %d)\n",
+ caf_this_image, caf_num_images, __FUNCTION__, status_code);
+
+#ifdef WITH_FAILED_IMAGES
+ no_stopped_images_check_in_errhandler = true;
+ MPI_Win_flush_all (*stat_tok);
+#endif
/* For future security enclose setting img_status in a lock. */
CAF_Win_lock (MPI_LOCK_EXCLUSIVE, caf_this_image - 1, *stat_tok);
- img_status = STAT_STOPPED_IMAGE; /* GFC_STAT_STOPPED_IMAGE = 6000 */
+ if (status_code == 0)
+ {
+ img_status = STAT_STOPPED_IMAGE;
+#ifdef WITH_FAILED_IMAGES
+ image_stati[caf_this_image - 1] = STAT_STOPPED_IMAGE;
+#endif
+ }
+ else
+ {
+ img_status = status_code;
+#ifdef WITH_FAILED_IMAGES
+ image_stati[caf_this_image - 1] = status_code;
+#endif
+ }
CAF_Win_unlock (caf_this_image - 1, *stat_tok);
- /* Announce to all other images, that this one is stopped. */
+ /* Announce to all other images, that this one has changed its execution
+ * status. */
for (int i = 0; i < caf_num_images - 1; ++i)
- MPI_Send (&img_status, 1, MPI_INT, images_full[i] - 1, 0, CAF_COMM_WORLD);
-
+ MPI_Send (&img_status, 1, MPI_INT, images_full[i] - 1,
+ MPI_TAG_CAF_SYNC_IMAGES, CAF_COMM_WORLD);
+
+#ifdef WITH_FAILED_IMAGES
+ /* Terminate the async request before revoking the comm, or we will get
+ * triggered by the errorhandler, which we don't want here anymore. */
+ MPI_Cancel (&alive_request);
+
+ if (status_code == 0) {
+ /* In finalization do not report stopped or failed images any more. */
+ MPI_Errhandler_set (CAF_COMM_WORLD, MPI_ERRORS_RETURN);
+ MPI_Errhandler_set (alive_comm, MPI_ERRORS_RETURN);
+ /* Only add a conventional barrier to prevent images from quitting to early,
+ * when this images is not failing. */
+ dprint ("%d/%d: %s: Before MPI_Barrier (CAF_COMM_WORLD)\n",
+ caf_this_image, caf_num_images, __FUNCTION__);
+ int ierr = MPI_Barrier (CAF_COMM_WORLD);
+ dprint ("%d/%d: %s: After MPI_Barrier (CAF_COMM_WORLD) = %d\n",
+ caf_this_image, caf_num_images, __FUNCTION__, ierr);
+ }
+ else
+ return;
+#else
/* Add a conventional barrier to prevent images from quitting to early. */
- MPI_Barrier (CAF_COMM_WORLD);
+ if (status_code == 0)
+ MPI_Barrier (CAF_COMM_WORLD);
+ else
+ /* Without failed images support, but a given status_code, we need to return
+ * to the caller, or we will hang in the following instead of terminating the
+ * program. */
+ return;
+#endif
while (caf_static_list != NULL)
{
@@ -483,55 +869,105 @@ PREFIX (finalize) (void)
{
prev = tmp_tot->prev;
p = TOKEN(tmp_tot->token);
+ dprint ("%d/%d: %s: Before CAF_Win_unlock_all (*p)\n",
+ caf_this_image, caf_num_images, __FUNCTION__);
CAF_Win_unlock_all (*p);
+ dprint ("%d/%d: %s: After CAF_Win_unlock_all (*p)\n",
+ caf_this_image, caf_num_images, __FUNCTION__);
#ifdef GCC_GE_7
/* Unregister the window to the descriptors when freeing the token. */
- if (((mpi_caf_token_t *)tmp_tot->token)->desc)
- {
- mpi_caf_token_t *mpi_token = (mpi_caf_token_t *)tmp_tot->token;
- CAF_Win_unlock_all(*(mpi_token->desc));
- MPI_Win_free (mpi_token->desc);
- free (mpi_token->desc);
- }
+ mpi_caf_token_t *mpi_token = (mpi_caf_token_t *)tmp_tot->token;
+ if (mpi_token->desc)
+ {
+ CAF_Win_unlock_all (*(mpi_token->desc));
+ MPI_Win_free (mpi_token->desc);
+ free (mpi_token->desc);
+ }
+ MPI_Win_free (p);
+ /* Free the memory only, when it was allocated by the caf-library. */
+ if ((*(mpi_token->flags) & FLAG_MEM_NOT_OWNED) > 0)
+ free (mpi_token->local_memptr);
+ /* Free the flags window only after accessing. */
+ CAF_Win_unlock_all (mpi_token->flags_win);
+ MPI_Win_free (&mpi_token->flags_win);
+ free (tmp_tot->token);
+#else // GCC_GE_7
+ MPI_Win_free (p);
#endif // GCC_GE_7
- MPI_Win_free(p);
- free(tmp_tot);
+ free (tmp_tot);
tmp_tot = prev;
}
#if MPI_VERSION >= 3
MPI_Info_free (&mpi_info_same_size);
#endif // MPI_VERSION
+#ifdef WITH_FAILED_IMAGES
+ if (status_code == 0)
+ {
+ dprint ("%d/%d: %s: before Win_unlock_all.\n",
+ caf_this_image, caf_num_images, __FUNCTION__);
+ CAF_Win_unlock_all (*stat_tok);
+ dprint ("%d/%d: %s: before Win_free(stat_tok)\n",
+ caf_this_image, caf_num_images, __FUNCTION__);
+ MPI_Win_free (stat_tok);
+ dprint ("%d/%d: %s: before Comm_free(CAF_COMM_WORLD)\n",
+ caf_this_image, caf_num_images, __FUNCTION__);
+ MPI_Comm_free (&CAF_COMM_WORLD);
+ MPI_Comm_free (&alive_comm);
+ dprint ("%d/%d: %s: after Comm_free(CAF_COMM_WORLD)\n",
+ caf_this_image, caf_num_images, __FUNCTION__);
+ }
+
+ MPI_Errhandler_free (&failed_stopped_CAF_COMM_WORLD_mpi_errorhandler);
+
+ /* Only call Finalize if CAF runtime Initialized MPI. */
+ if (caf_owns_mpi)
+ MPI_Finalize ();
+#else
+ MPI_Comm_free (&CAF_COMM_WORLD);
+
CAF_Win_unlock_all (*stat_tok);
MPI_Win_free (stat_tok);
- MPI_Comm_free(&CAF_COMM_WORLD);
/* Only call Finalize if CAF runtime Initialized MPI. */
- if (caf_owns_mpi) {
- MPI_Finalize();
- }
- pthread_mutex_lock(&lock_am);
+ if (caf_owns_mpi)
+ MPI_Finalize ();
+#endif
+
+ pthread_mutex_lock (&lock_am);
caf_is_finalized = 1;
- pthread_mutex_unlock(&lock_am);
+ pthread_mutex_unlock (&lock_am);
free (sync_handles);
+ dprint ("%d/%d: %s: Finalisation done!!!\n", caf_this_image, caf_num_images,
+ __FUNCTION__);
}
+/* Finalize coarray program. */
+
+void
+PREFIX (finalize) (void)
+{
+ finalize_internal (0);
+}
+
+/* TODO: This is interface is violating the F2015 standard, but not the gfortran
+ * API. Fix it (the fortran API). */
int
-PREFIX (this_image)(int distance __attribute__ ((unused)))
+PREFIX (this_image) (int distance __attribute__ ((unused)))
{
return caf_this_image;
}
-
+/* TODO: This is interface is violating the F2015 standard, but not the gfortran
+ * API. Fix it (the fortran API). */
int
-PREFIX (num_images)(int distance __attribute__ ((unused)),
- int failed __attribute__ ((unused)))
+PREFIX (num_images) (int distance __attribute__ ((unused)),
+ int failed __attribute__ ((unused)))
{
return caf_num_images;
}
-
#ifdef GCC_GE_7
/** Register an object with the coarray library creating a token where
necessary/requested.
@@ -550,7 +986,7 @@ PREFIX (register) (size_t size, caf_register_t type, caf_token_t *token,
int errmsg_len)
{
/* int ierr; */
- void *mem;
+ void *mem = NULL;
size_t actual_size;
int l_var=0, *init_array=NULL;
@@ -576,10 +1012,17 @@ PREFIX (register) (size_t size, caf_register_t type, caf_token_t *token,
/* The token has to be present, when COARRAY_ALLOC_ALLOCATE_ONLY is
specified. */
if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
- *token = malloc (sizeof (mpi_caf_token_t));
+ {
+ *token = malloc (sizeof (mpi_caf_token_t));
+ MPI_Win_allocate (sizeof(unsigned), 1, mpi_info_same_size, CAF_COMM_WORLD,
+ &((mpi_caf_token_t *)*token)->flags,
+ &((mpi_caf_token_t *)*token)->flags_win);
+ CAF_Win_lock_all (((mpi_caf_token_t *)*token)->flags_win);
+ *((mpi_caf_token_t *)*token)->flags = 0;
+ }
mpi_token = (mpi_caf_token_t *) *token;
- p = TOKEN(mpi_token);
+ p = TOKEN (mpi_token);
if ((type == CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY
|| type == CAF_REGTYPE_COARRAY_ALLOC
@@ -599,14 +1042,30 @@ PREFIX (register) (size_t size, caf_register_t type, caf_token_t *token,
mpi_token->desc = NULL;
#if MPI_VERSION >= 3
- if (type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
+ if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
{
- // Note, MPI_Win_allocate implicitly synchronizes.
- MPI_Win_allocate (actual_size, 1, MPI_INFO_NULL, CAF_COMM_WORLD, &mem, p);
+ int ierr = MPI_Win_create_dynamic (MPI_INFO_NULL, CAF_COMM_WORLD, p);
+ dprint ("%d/%d: Register win = %p, ierr= %d\n", caf_this_image, caf_num_images,
+ *p, ierr);
CAF_Win_lock_all (*p);
}
+ else if (type == CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
+ {
+ int ierr;
+ mem = malloc (actual_size);
+ CAF_Win_unlock_all (*p);
+ ierr = MPI_Win_attach (*p, mem, actual_size);
+ CAF_Win_lock_all (*p);
+ *(mpi_token->flags) |= (FLAG_ASSOCIATED | FLAG_MEM_NOT_OWNED);
+ dprint ("%d/%d: Attach mem %p to win = %p, ierr: %d, flags: %u\n",
+ caf_this_image, caf_num_images, mem, *p, ierr, *mpi_token->flags);
+ }
else
- mem = NULL;
+ {
+ MPI_Win_allocate (actual_size, 1, MPI_INFO_NULL, CAF_COMM_WORLD, &mem, p);
+ CAF_Win_lock_all (*p);
+ *(mpi_token->flags) = FLAG_ASSOCIATED;
+ }
#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, p);
@@ -672,20 +1131,14 @@ error:
}
}
#else // GCC_GE_7
-#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)
-#else
-void *
- PREFIX (register) (size_t size, caf_register_t type, caf_token_t *token,
- int *stat, char *errmsg, int errmsg_len)
-#endif
+PREFIX (register) (size_t size, caf_register_t type, caf_token_t *token,
+ int *stat, char *errmsg, int errmsg_len)
{
/* int ierr; */
void *mem;
size_t actual_size;
- int l_var=0, *init_array=NULL;
+ int l_var=0, *init_array = NULL;
if (unlikely (caf_is_finalized))
goto error;
@@ -698,6 +1151,10 @@ 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)
@@ -708,10 +1165,6 @@ void *
else
actual_size = size;
- /* Token contains only a list of pointers. */
- *token = malloc (sizeof(MPI_Win));
- MPI_Win *p = *token;
-
#if MPI_VERSION >= 3
MPI_Win_allocate(actual_size, 1, mpi_info_same_size, CAF_COMM_WORLD, &mem, p);
CAF_Win_lock_all (*p);
@@ -725,12 +1178,12 @@ void *
init_array = (int *)calloc(size, sizeof(int));
CAF_Win_lock(MPI_LOCK_EXCLUSIVE, caf_this_image-1, *p);
MPI_Put (init_array, size, MPI_INT, caf_this_image-1,
- 0, size, MPI_INT, *p);
- CAF_Win_unlock(caf_this_image-1, *p);
+ 0, size, MPI_INT, *p);
+ CAF_Win_unlock(caf_this_image - 1, *p);
free(init_array);
}
- PREFIX(sync_all) (NULL,NULL,0);
+ PREFIX(sync_all) (NULL, NULL, 0);
caf_static_t *tmp = malloc (sizeof (caf_static_t));
tmp->prev = caf_tot;
@@ -747,7 +1200,6 @@ void *
if (stat)
*stat = 0;
-
return mem;
error:
@@ -788,8 +1240,6 @@ void
PREFIX (deregister) (caf_token_t *token, int *stat, char *errmsg, int errmsg_len)
#endif
{
- /* int ierr; */
-
if (unlikely (caf_is_finalized))
{
const char msg[] = "Failed to deallocate coarray - "
@@ -811,46 +1261,79 @@ PREFIX (deregister) (caf_token_t *token, int *stat, char *errmsg, int errmsg_len
caf_runtime_error (msg);
}
- PREFIX (sync_all) (NULL, NULL, 0);
+#ifdef GCC_GE_7
+ if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+ {
+ /* Sync all images only, when deregistering the token. Just freeing the
+ * memory needs no sync. */
+#ifdef WITH_FAILED_IMAGES
+ MPI_Barrier (CAF_COMM_WORLD);
+#else
+ PREFIX (sync_all) (NULL, NULL, 0);
+#endif
+ }
+#endif
caf_static_t *tmp = caf_tot, *prev = caf_tot, *next=caf_tot;
MPI_Win *p;
- while(tmp)
+ while (tmp)
{
prev = tmp->prev;
- if(tmp->token == *token)
+ if (tmp->token == *token)
{
p = TOKEN(*token);
- CAF_Win_unlock_all(*p);
#ifdef GCC_GE_7
- mpi_caf_token_t *mpi_token = *(mpi_caf_token_t **)token;
- if (mpi_token->local_memptr)
- {
- MPI_Win_free(p);
- mpi_token->local_memptr = NULL;
- }
- if ((*(mpi_caf_token_t **)token)->desc
- && type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
- {
- CAF_Win_unlock_all(*(mpi_token->desc));
- MPI_Win_free (mpi_token->desc);
- free (mpi_token->desc);
- }
+ mpi_caf_token_t *mpi_token = *(mpi_caf_token_t **)token;
+ if (mpi_token->local_memptr)
+ {
+ if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+ {
+ /* Unlock only, when removing the window. */
+ CAF_Win_unlock_all (*p);
+ MPI_Win_free (p);
+ if ((*(mpi_token->flags) & FLAG_MEM_NOT_OWNED) > 0)
+ free (mpi_token->local_memptr);
+ }
+ else
+ {
+ MPI_Win_detach (*p, mpi_token->local_memptr);
+ /* Free the memory, when we have allocated it. */
+ if ((*(mpi_token->flags) & FLAG_MEM_NOT_OWNED) > 0)
+ free (mpi_token->local_memptr);
+ *(mpi_token->flags) = (*(mpi_token->flags) & ~FLAG_MEM_NOT_OWNED);
+ }
+ mpi_token->local_memptr = NULL;
+ /* Clear the flag, that memory is associated. */
+ *(mpi_token->flags) = (*(mpi_token->flags) & ~FLAG_ASSOCIATED);
+ }
+ if ((*(mpi_caf_token_t **)token)->desc
+ && type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+ {
+ CAF_Win_unlock_all(*(mpi_token->desc));
+ MPI_Win_free (mpi_token->desc);
+ free (mpi_token->desc);
+ }
+ if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
+ {
+ CAF_Win_unlock_all (mpi_token->flags_win);
+ MPI_Win_free (&mpi_token->flags_win);
+ }
#else
- MPI_Win_free(p);
+ CAF_Win_unlock_all (*p);
+ MPI_Win_free (p);
#endif
- if(prev)
+ if (prev)
next->prev = prev->prev;
else
next->prev = NULL;
- if(tmp == caf_tot)
+ if (tmp == caf_tot)
caf_tot = prev;
- free(tmp);
+ free (tmp);
break;
}
@@ -861,18 +1344,16 @@ PREFIX (deregister) (caf_token_t *token, int *stat, char *errmsg, int errmsg_len
if (stat)
*stat = 0;
- /* if (unlikely (ierr = ARMCI_Free ((*token)[caf_this_image-1]))) */
- /* caf_runtime_error ("ARMCI memory freeing failed: Error code %d", ierr); */
- //gasnet_exit(0);
-
free (*token);
}
void
-PREFIX (sync_memory) (int *stat, char *errmsg, int errmsg_len)
+PREFIX (sync_memory) (int *stat __attribute__ ((unused)),
+ char *errmsg __attribute__ ((unused)),
+ int errmsg_len __attribute__ ((unused)))
{
#if defined(NONBLOCKING_PUT) && !defined(CAF_MPI_LOCK_UNLOCK)
- explicit_flush();
+ explicit_flush ();
#endif
}
@@ -880,23 +1361,40 @@ PREFIX (sync_memory) (int *stat, char *errmsg, int errmsg_len)
void
PREFIX (sync_all) (int *stat, char *errmsg, int errmsg_len)
{
- int ierr=0;
+ int ierr = 0;
+ dprint ("%d/%d: Entering sync all.\n", caf_this_image, caf_num_images);
if (unlikely (caf_is_finalized))
ierr = STAT_STOPPED_IMAGE;
else
{
+ int mpi_err;
#if defined(NONBLOCKING_PUT) && !defined(CAF_MPI_LOCK_UNLOCK)
explicit_flush();
#endif
- MPI_Barrier(CAF_COMM_WORLD);
- ierr = 0;
+
+#ifdef WITH_FAILED_IMAGES
+ mpi_err = MPI_Barrier (alive_comm);
+#else
+ mpi_err = MPI_Barrier (CAF_COMM_WORLD);
+#endif
+ dprint ("%d/%d: %s: MPI_Barrier = %d.\n", caf_this_image, caf_num_images,
+ __FUNCTION__, mpi_err);
+ if (mpi_err == STAT_FAILED_IMAGE)
+ ierr = STAT_FAILED_IMAGE;
+ else if (mpi_err != 0)
+ MPI_Error_class (mpi_err, &ierr);
}
- if (stat)
+ if (stat != NULL)
*stat = ierr;
+#ifdef WITH_FAILED_IMAGES
+ else if (ierr == STAT_FAILED_IMAGE)
+ /* F2015 requests stat to be set for FAILED IMAGES, else error out. */
+ terminate_internal (ierr, 0);
+#endif
- if (ierr)
+ if (ierr != 0 && ierr != STAT_FAILED_IMAGE)
{
char *msg;
if (caf_is_finalized)
@@ -912,9 +1410,10 @@ PREFIX (sync_all) (int *stat, char *errmsg, int errmsg_len)
if (errmsg_len > len)
memset (&errmsg[len], ' ', errmsg_len-len);
}
- else
+ else if (stat == NULL)
caf_runtime_error (msg);
}
+ dprint ("%d/%d: Leaving sync all.\n", caf_this_image, caf_num_images);
}
/* token: The token of the array to be written to. */
@@ -924,42 +1423,41 @@ PREFIX (sync_all) (int *stat, char *errmsg, int errmsg_len)
/* size: The number of bytes to be transferred. */
/* asynchronous: Return before the data transfer has been complete */
-void selectType(int size, MPI_Datatype *dt)
+void selectType (int size, MPI_Datatype *dt)
{
int t_s;
- MPI_Type_size(MPI_INT, &t_s);
+ MPI_Type_size (MPI_INT, &t_s);
- if(t_s==size)
+ if (t_s == size)
{
- *dt=MPI_INT;
+ *dt = MPI_INT;
return;
}
- MPI_Type_size(MPI_DOUBLE, &t_s);
+ MPI_Type_size (MPI_DOUBLE, &t_s);
- if(t_s==size)
+ if (t_s == size)
{
- *dt=MPI_DOUBLE;
+ *dt = MPI_DOUBLE;
return;
}
- MPI_Type_size(MPI_COMPLEX, &t_s);
+ MPI_Type_size (MPI_COMPLEX, &t_s);
- if(t_s==size)
+ if (t_s == size)
{
- *dt=MPI_COMPLEX;
+ *dt = MPI_COMPLEX;
return;
}
- MPI_Type_size(MPI_DOUBLE_COMPLEX, &t_s);
+ MPI_Type_size (MPI_DOUBLE_COMPLEX, &t_s);
- if(t_s==size)
+ if (t_s == size)
{
- *dt=MPI_DOUBLE_COMPLEX;
+ *dt = MPI_DOUBLE_COMPLEX;
return;
}
-
}
void
@@ -969,7 +1467,7 @@ PREFIX (sendget) (caf_token_t token_s, size_t offset_s, int image_index_s,
caf_token_t token_g, size_t offset_g,
int image_index_g, gfc_descriptor_t *src ,
caf_vector_t *src_vector __attribute__ ((unused)),
- int src_kind, int dst_kind, bool mrt)
+ int src_kind, int dst_kind, bool mrt, int *stat)
{
int ierr = 0;
size_t i, size;
@@ -995,6 +1493,9 @@ PREFIX (sendget) (caf_token_t token_s, size_t offset_s, int image_index_s,
if (size == 0)
return;
+ check_image_health (image_index_s, stat);
+ check_image_health (image_index_g, stat);
+
if (rank == 0
|| (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
&& dst_kind == src_kind && GFC_DESCRIPTOR_RANK (src) != 0
@@ -1024,7 +1525,7 @@ PREFIX (sendget) (caf_token_t token_s, size_t offset_s, int image_index_s,
CAF_Win_unlock (image_index_s - 1, *p_s);
if (ierr != 0)
- error_stop (ierr);
+ terminate_internal (ierr, 0);
return;
free(tmp);
@@ -1090,7 +1591,7 @@ PREFIX (sendget) (caf_token_t token_s, size_t offset_s, int image_index_s,
if (ierr != 0)
{
- error_stop (ierr);
+ terminate_internal (ierr, 0);
return;
}
}
@@ -1099,6 +1600,7 @@ PREFIX (sendget) (caf_token_t token_s, size_t offset_s, int image_index_s,
}
+
/* Send array data from src to dest on a remote image. */
/* The last argument means may_require_temporary */
@@ -1107,12 +1609,12 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
gfc_descriptor_t *dest,
caf_vector_t *dst_vector __attribute__ ((unused)),
gfc_descriptor_t *src, int dst_kind, int src_kind,
- bool mrt)
+ bool mrt, int *stat)
{
/* FIXME: Implement vector subscripts, type conversion and check whether
string-kind conversions are permitted.
FIXME: Implement sendget as well. */
- int ierr = 0;
+ int ierr = 0, flag = 0;
size_t i, size;
int j;
/* int position, msg = 0; */
@@ -1137,6 +1639,8 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
if (size == 0)
return;
+ check_image_health(image_index, stat);
+
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
pad_str = alloca (dst_size - src_size);
@@ -1201,8 +1705,12 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
#endif // CAF_MPI_LOCK_UNLOCK
}
+#ifdef WITH_FAILED_IMAGES
+ check_image_health (image_index , stat);
+#else
if (ierr != 0)
- error_stop (ierr);
+ terminate_internal (ierr, 0);
+#endif
return;
}
else
@@ -1261,7 +1769,7 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
ptrdiff_t array_offset_sr = 0;
stride = 1;
extent = 1;
- tot_ext = 1;
+ tot_ext = 1;
for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
{
array_offset_sr += ((i / tot_ext)
@@ -1270,7 +1778,7 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
* src->dim[j]._stride;
extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
stride = src->dim[j]._stride;
- tot_ext *= extent;
+ tot_ext *= extent;
}
array_offset_sr += (i / tot_ext) * src->dim[rank-1]._stride;
@@ -1297,66 +1805,24 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
ierr = MPI_Put (sr, 1, dt_s, image_index-1, dst_offset, 1, dt_d, *p);
CAF_Win_unlock (image_index - 1, *p);
- if (ierr != 0)
- {
- error_stop (ierr);
- return;
- }
+#ifdef WITH_FAILED_IMAGES
+ check_image_health (image_index, stat);
+ if(!stat && ierr == STAT_FAILED_IMAGE)
+ error_stop (ierr);
+
+ if(stat)
+ *stat = ierr;
+#else
+ if (ierr != 0)
+ {
+ error_stop (ierr);
+ return;
+ }
+#endif
MPI_Type_free (&dt_s);
MPI_Type_free (&dt_d);
- /* msg = 2; */
- /* MPI_Pack(&msg, 1, MPI_INT, buff_am[caf_this_image], 1000, &position, CAF_COMM_WORLD); */
- /* MPI_Pack(&rank, 1, MPI_INT, buff_am[caf_this_image], 1000, &position, CAF_COMM_WORLD); */
-
- /* for(j=0;j<rank;j++) */
- /* { */
- /* MPI_Pack(&(dest->dim[j]._stride), 1, MPI_INT, buff_am[caf_this_image], 1000, &position, CAF_COMM_WORLD); */
- /* MPI_Pack(&(dest->dim[j].lower_bound), 1, MPI_INT, buff_am[caf_this_image], 1000, &position, CAF_COMM_WORLD); */
- /* MPI_Pack(&(dest->dim[j]._ubound), 1, MPI_INT, buff_am[caf_this_image], 1000, &position, CAF_COMM_WORLD); */
- /* } */
-
- /* MPI_Pack(&size, 1, MPI_INT, buff_am[caf_this_image], 1000, &position, CAF_COMM_WORLD); */
-
- /* /\* non-blocking send *\/ */
-
- /* MPI_Issend(buff_am[caf_this_image], position, MPI_PACKED, image_index-1, 1, CAF_COMM_WORLD, &reqdt); */
-
- /* msgbody = calloc(size, sizeof(char)); */
-
- /* ptrdiff_t array_offset_sr = 0; */
- /* ptrdiff_t stride = 1; */
- /* ptrdiff_t extent = 1; */
-
- /* for(i = 0; i < size; i++) */
- /* { */
- /* for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++) */
- /* { */
- /* array_offset_sr += ((i / (extent*stride)) */
- /* % (src->dim[j]._ubound */
- /* - src->dim[j].lower_bound + 1)) */
- /* * src->dim[j]._stride; */
- /* extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1); */
- /* stride = src->dim[j]._stride; */
- /* } */
-
- /* array_offset_sr += (i / extent) * src->dim[rank-1]._stride; */
-
- /* void *sr = (void *)((char *) src->base_addr */
- /* + array_offset_sr*GFC_DESCRIPTOR_SIZE (src)); */
-
- /* memmove (msgbody+p_mb, sr, GFC_DESCRIPTOR_SIZE (src)); */
-
- /* p_mb += GFC_DESCRIPTOR_SIZE (src); */
- /* } */
-
- /* MPI_Wait(&reqdt, &stadt); */
-
- /* MPI_Ssend(msgbody, size, MPI_BYTE, image_index-1, 1, CAF_COMM_WORLD); */
-
- /* free(msgbody); */
-
#else
if(caf_this_image == image_index && mrt)
{
@@ -1429,11 +1895,13 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
dst_offset, dst_size - src_size, MPI_BYTE, *p);
}
+#ifndef WITH_FAILED_IMAGES
if (ierr != 0)
{
- error_stop (ierr);
+ caf_runtime_error ("MPI Error: %d", ierr);
return;
}
+#endif
}
if(caf_this_image == image_index && mrt)
@@ -1468,6 +1936,8 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
}
CAF_Win_unlock (image_index - 1, *p);
#endif
+
+ check_image_health (image_index, stat);
}
}
@@ -1477,14 +1947,13 @@ PREFIX (send) (caf_token_t token, size_t offset, int image_index,
void
PREFIX (get) (caf_token_t token, size_t offset,
int image_index,
- gfc_descriptor_t *src ,
+ gfc_descriptor_t *src,
caf_vector_t *src_vector __attribute__ ((unused)),
gfc_descriptor_t *dest, int src_kind, int dst_kind,
- bool mrt)
+ bool mrt, int *stat)
{
size_t i, size;
- int ierr = 0;
- int j;
+ int ierr = 0, j;
MPI_Win *p = TOKEN(token);
int rank = GFC_DESCRIPTOR_RANK (src);
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
@@ -1506,6 +1975,8 @@ PREFIX (get) (caf_token_t token, size_t offset,
if (size == 0)
return;
+ check_image_health (image_index, stat);
+
if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
{
pad_str = alloca (dst_size - src_size);
@@ -1540,9 +2011,11 @@ PREFIX (get) (caf_token_t token, size_t offset,
memcpy ((char *) dest->base_addr + src_size, pad_str,
dst_size-src_size);
CAF_Win_unlock (image_index - 1, *p);
+
+ check_image_health (image_index, stat);
}
if (ierr != 0)
- error_stop (ierr);
+ terminate_internal (ierr, 0);
return;
}
@@ -1633,10 +2106,21 @@ PREFIX (get) (caf_token_t token, size_t offset,
CAF_Win_lock (MPI_LOCK_SHARED, image_index - 1, *p);
ierr = MPI_Get (dst, 1, dt_d, image_index-1, offset, 1, dt_s, *p);
+#ifdef WITH_FAILED_IMAGES
+ check_image_health (image_index, stat);
+
+ if(stat)
+ *stat = ierr;
+ else if(ierr == STAT_FAILED_IMAGE)
+ error_stop (ierr);
+#else
CAF_Win_unlock (image_index - 1, *p);
- if (ierr != 0)
+ if(stat)
+ *stat = ierr;
+ else if (ierr != 0)
error_stop (ierr);
+#endif
MPI_Type_free(&dt_s);
MPI_Type_free(&dt_d);
@@ -1710,7 +2194,7 @@ PREFIX (get) (caf_token_t token, size_t offset,
memcpy ((char *) dst + src_size, pad_str, dst_size-src_size);
}
if (ierr != 0)
- error_stop (ierr);
+ terminate_internal (ierr, 0);
}
if(caf_this_image == image_index && mrt)
@@ -2042,7 +2526,7 @@ convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
}
error:
- fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
+ fprintf (stderr, "libcaf_mpi 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;
@@ -2540,6 +3024,8 @@ _gfortran_caf_get_by_ref (caf_token_t token, int image_index,
if (stat)
*stat = 0;
+ check_image_health (image_index, stat);
+
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. */
@@ -2952,8 +3438,9 @@ PREFIX(send_by_ref) (caf_token_t token, int image_index,
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);
+ unimplemented_alloc_comps_message("caf_send_by_ref()");
+ // Make sure we exit
+ terminate_internal (1, 1);
}
@@ -2964,23 +3451,115 @@ PREFIX(sendget_by_ref) (caf_token_t dst_token, int dst_image_index,
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);
+ unimplemented_alloc_comps_message("caf_sendget_by_ref()");
+ // Make sure we exit
+ terminate_internal (1, 1);
}
-
int
PREFIX(is_present) (caf_token_t token, int image_index, caf_reference_t *refs)
{
- fprintf (stderr, "COARRAY ERROR: caf_is_present() not implemented yet ");
- error_stop (1);
+ const char unsupportedRefType[] = "Unsupported ref-type in caf_is_present().";
+ mpi_caf_token_t *mpi_token = (mpi_caf_token_t *)token;
+ size_t i;
+ 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;
+
+ GET_REMOTE_DESC (mpi_token, src, primary_src_desc_data, image_index - 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_FULL:
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ case CAF_ARR_REF_SINGLE:
+ 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_VECTOR:
+ case CAF_ARR_REF_RANGE:
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ /* Intentionally fall through, because these are not suported
+ * here. */
+ default:
+ caf_runtime_error (unsupportedRefType, NULL, NULL, 0);
+ return 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_FULL:
+ /* The memptr stays unchanged when ref'ing the first element
+ in a dimension. */
+ break;
+ case CAF_ARR_REF_SINGLE:
+ local_memptr += riter->u.a.dim[i].s.start
+ * riter->u.a.dim[i].s.stride
+ * riter->item_size;
+ break;
+ case CAF_ARR_REF_VECTOR:
+ case CAF_ARR_REF_RANGE:
+ case CAF_ARR_REF_OPEN_END:
+ case CAF_ARR_REF_OPEN_START:
+ default:
+ caf_runtime_error (unsupportedRefType, NULL, NULL, 0);
+ return false;
+ }
+ }
+ break;
+ default:
+ caf_runtime_error (unsupportedRefType, NULL, NULL, 0);
+ return false;
+ }
+ riter = riter->next;
+ }
+
+ unsigned remote_flags = 0U;
+ int ierr = MPI_Get (&remote_flags, sizeof (unsigned), MPI_BYTE,
+ image_index - 1, 0, sizeof (unsigned), MPI_BYTE,
+ mpi_token->flags_win);
+ dprint ("%d/%d: Got remote_flags[%d] for win %p to be: %u, ierr = %d\n",
+ caf_this_image, caf_num_images, image_index, mpi_token->flags_win,
+ remote_flags, ierr);
+ return (remote_flags & FLAG_ASSOCIATED) > 0;
}
#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. */
+ is not semantically equivalent to SYNC ALL. */
+
void
PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
int errmsg_len)
@@ -2988,17 +3567,25 @@ PREFIX (sync_images) (int count, int images[], int *stat, char *errmsg,
sync_images_internal (count, images, stat, errmsg, errmsg_len, false);
}
-void
+static void
sync_images_internal (int count, int images[], int *stat, char *errmsg,
int errmsg_len, bool internal)
{
int ierr = 0, i = 0, j = 0, int_zero = 0, done_count = 0;
MPI_Status s;
+#ifdef WITH_FAILED_IMAGES
+ no_stopped_images_check_in_errhandler = true;
+#endif
+ dprint ("%d/%d: Entering %s.\n", caf_this_image, caf_num_images, __FUNCTION__);
if (count == 0 || (count == 1 && images[0] == caf_this_image))
{
if (stat)
*stat = 0;
+#ifdef WITH_FAILED_IMAGES
+ no_stopped_images_check_in_errhandler = false;
+#endif
+ dprint ("%d/%d: Leaving %s early.\n", caf_this_image, caf_num_images, __FUNCTION__);
return;
}
@@ -3031,76 +3618,101 @@ sync_images_internal (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;
images = images_full;
}
- else
- {
- for (i = 0; i < count; ++i)
- ++orders[images[i] - 1];
- }
#if defined(NONBLOCKING_PUT) && !defined(CAF_MPI_LOCK_UNLOCK)
explicit_flush();
#endif
+#ifdef WITH_FAILED_IMAGES
+ {
+ int flag;
+ /* Provoke detecting process fails. */
+ MPI_Test (&alive_request, &flag, MPI_STATUS_IGNORE);
+ }
+#endif
/* A rather simple way to synchronice:
- - expect all images to sync with receiving an int,
- - on the other side, send all processes to sync with an int,
- - when the int received is STAT_STOPPED_IMAGE the return immediately,
- else wait until all images in the current set of images have send
- some data, i.e., synced.
-
- This approach as best as possible implements the syncing of different
- sets of images and figuring that an image has stopped. MPI does not
- provide any direct means of syncing non-coherent sets of images.
- The groups/communicators of MPI always need to be consistent, i.e.,
- have the same members on all images participating. This is
- contradictiory to the sync images statement, where syncing, e.g., in a
- ring pattern is possible.
-
- This implementation guarantees, that as long as no image is stopped
- an image only is allowed to continue, when all its images to sync to
- also have reached a sync images statement. This implementation makes
- no assumption when the image continues or in which order synced
- images continue. */
- 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, &sync_handles[i]);
- for(i = 0; i < count; ++i)
- MPI_Send (&int_zero, 1, MPI_INT, images[i] - 1, 0, CAF_COMM_WORLD);
+ - expect all images to sync with receiving an int,
+ - on the other side, send all processes to sync with an int,
+ - when the int received is STAT_STOPPED_IMAGE the return immediately,
+ else wait until all images in the current set of images have send
+ some data, i.e., synced.
+
+ This approach as best as possible implements the syncing of different
+ sets of images and figuring that an image has stopped. MPI does not
+ provide any direct means of syncing non-coherent sets of images.
+ The groups/communicators of MPI always need to be consistent, i.e.,
+ have the same members on all images participating. This is
+ contradictiory to the sync images statement, where syncing, e.g., in a
+ ring pattern is possible.
+
+ This implementation guarantees, that as long as no image is stopped
+ an image only is allowed to continue, when all its images to sync to
+ also have reached a sync images statement. This implementation makes
+ no assumption when the image continues or in which order synced
+ images continue. */
+ 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,
+ MPI_TAG_CAF_SYNC_IMAGES, CAF_COMM_WORLD, &sync_handles[i]);
+ for (i = 0; i < count; ++i)
+ MPI_Send (&int_zero, 1, MPI_INT, images[i] - 1, MPI_TAG_CAF_SYNC_IMAGES,
+ CAF_COMM_WORLD);
done_count = 0;
while (done_count < count)
- {
- ierr = MPI_Waitany (count, sync_handles, &i, &s);
- if (i != MPI_UNDEFINED)
- {
- ++done_count;
- if (ierr == MPI_SUCCESS && arrived[s.MPI_SOURCE] == STAT_STOPPED_IMAGE)
- {
- /* Possible future extension: Abort pending receives. At the
- moment the receives are discarded by the program
- termination. For the tested mpi-implementation this is ok.
- */
- ierr = STAT_STOPPED_IMAGE;
- break;
- }
- }
- else if (ierr != MPI_SUCCESS)
- /* Abort receives here, too, when implemented above. */
- break;
- }
+ {
+ ierr = MPI_Waitany (count, sync_handles, &i, &s);
+ if (ierr == MPI_SUCCESS && i != MPI_UNDEFINED)
+ {
+ ++done_count;
+ if (ierr == MPI_SUCCESS && arrived[s.MPI_SOURCE] == STAT_STOPPED_IMAGE)
+ {
+ /* Possible future extension: Abort pending receives. At the
+ moment the receives are discarded by the program
+ termination. For the tested mpi-implementation this is ok.
+ */
+ ierr = STAT_STOPPED_IMAGE;
+ break;
+ }
+ }
+ else if (ierr != MPI_SUCCESS)
+#ifdef WITH_FAILED_IMAGES
+ {
+ int err;
+ MPI_Error_class (ierr, &err);
+ if (err == MPIX_ERR_PROC_FAILED)
+ {
+ int flag;
+ dprint ("%d/%d: Image failed, provoking error handling.\n",
+ caf_this_image, caf_num_images);
+ ierr = STAT_FAILED_IMAGE;
+ /* Provoke detecting process fails. */
+ MPI_Test (&alive_request, &flag, MPI_STATUS_IGNORE);
+ }
+ break;
+ }
+#else
+ break;
+#endif
+ }
}
sync_images_err_chk:
+#ifdef WITH_FAILED_IMAGES
+ no_stopped_images_check_in_errhandler = false;
+#endif
+ dprint ("%d/%d: Leaving %s.\n", caf_this_image, caf_num_images, __FUNCTION__);
if (stat)
*stat = ierr;
+#ifdef WITH_FAILED_IMAGES
+ else if (ierr == STAT_FAILED_IMAGE)
+ terminate_internal (ierr, 0);
+#endif
- if (ierr && stat == NULL)
+ if (ierr != 0 && ierr != STAT_FAILED_IMAGE)
{
char *msg;
if (caf_is_finalized)
@@ -3116,7 +3728,7 @@ sync_images_err_chk:
if (errmsg_len > len)
memset (&errmsg[len], ' ', errmsg_len-len);
}
- else if (!internal)
+ else if (!internal && stat == NULL)
caf_runtime_error (msg);
}
}
@@ -3657,7 +4269,7 @@ PREFIX (atomic_define) (caf_token_t token, size_t offset,
if (stat)
*stat = ierr;
else if (ierr != 0)
- error_stop (ierr);
+ terminate_internal (ierr, 0);
return;
}
@@ -3693,7 +4305,7 @@ PREFIX(atomic_ref) (caf_token_t token, size_t offset,
if (stat)
*stat = ierr;
else if (ierr != 0)
- error_stop (ierr);
+ terminate_internal (ierr, 0);
return;
}
@@ -3731,7 +4343,7 @@ PREFIX(atomic_cas) (caf_token_t token, size_t offset,
if (stat)
*stat = ierr;
else if (ierr != 0)
- error_stop (ierr);
+ terminate_internal (ierr, 0);
return;
}
@@ -3787,7 +4399,7 @@ PREFIX (atomic_op) (int op, caf_token_t token ,
if (stat)
*stat = ierr;
else if (ierr != 0)
- error_stop (ierr);
+ terminate_internal (ierr, 0);
return;
}
@@ -3799,7 +4411,7 @@ PREFIX (event_post) (caf_token_t token, size_t index,
int image_index, int *stat,
char *errmsg, int errmsg_len)
{
- int image, value=1, ierr=0;
+ int image, value = 1, ierr = 0,flag;
MPI_Win *p = TOKEN(token);
const char msg[] = "Error on event post";
@@ -3819,6 +4431,12 @@ PREFIX (event_post) (caf_token_t token, size_t index,
#warning Events for MPI-2 are not implemented
printf ("Events for MPI-2 are not supported, please update your MPI implementation\n");
#endif // MPI_VERSION
+
+ check_image_health (image_index, stat);
+
+ if(!stat && ierr == STAT_FAILED_IMAGE)
+ terminate_internal (ierr, 0);
+
if(ierr != MPI_SUCCESS)
{
if(stat != NULL)
@@ -3873,6 +4491,12 @@ PREFIX (event_wait) (caf_token_t token, size_t index,
CAF_Win_lock (MPI_LOCK_EXCLUSIVE, image, *p);
ierr = MPI_Fetch_and_op(&newval, &old, MPI_INT, image, index*sizeof(int), MPI_SUM, *p);
CAF_Win_unlock (image, *p);
+
+ check_image_health (image, stat);
+
+ if(!stat && ierr == STAT_FAILED_IMAGE)
+ terminate_internal (ierr, 0);
+
if(ierr != MPI_SUCCESS)
{
if(stat != NULL)
@@ -3912,28 +4536,39 @@ PREFIX (event_query) (caf_token_t token, size_t index,
*stat = ierr;
}
-/* ERROR STOP the other images. */
+
+/* Internal function to execute the part that is common to all (error) stop
+ * functions. */
static void
-error_stop (int error)
+terminate_internal (int stat_code, int exit_code)
{
- /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
- /* FIXME: Do some more effort than just gasnet_exit(). */
- MPI_Abort(CAF_COMM_WORLD, error);
+ dprint ("%d/%d: terminate_internal (stat_code = %d, exit_code = %d).\n",
+ caf_this_image, caf_num_images, stat_code, exit_code);
+ finalize_internal (stat_code);
- /* Should be unreachable, but to make sure also call exit. */
- exit (error);
+#ifndef WITH_FAILED_IMAGES
+ MPI_Abort(MPI_COMM_WORLD, exit_code);
+#endif
+ exit (exit_code);
}
+
/* STOP function for integer arguments. */
+
void
PREFIX (stop_numeric) (int32_t stop_code)
{
fprintf (stderr, "STOP %d\n", stop_code);
- PREFIX (finalize) ();
+
+ /* Stopping includes taking down the runtime regularly and returning the
+ * stop_code. */
+ terminate_internal (STAT_STOPPED_IMAGE, stop_code);
}
+
/* STOP function for string arguments. */
+
void
PREFIX (stop_str) (const char *string, int32_t len)
{
@@ -3942,9 +4577,11 @@ PREFIX (stop_str) (const char *string, int32_t len)
fputc (*(string++), stderr);
fputs ("\n", stderr);
- PREFIX (finalize) ();
+ /* Stopping includes taking down the runtime regularly. */
+ terminate_internal (STAT_STOPPED_IMAGE, 0);
}
+
/* ERROR STOP function for string arguments. */
void
@@ -3955,7 +4592,7 @@ PREFIX (error_stop_str) (const char *string, int32_t len)
fputc (*(string++), stderr);
fputs ("\n", stderr);
- error_stop (1);
+ terminate_internal (STAT_STOPPED_IMAGE, 1);
}
@@ -3965,5 +4602,203 @@ void
PREFIX (error_stop) (int32_t error)
{
fprintf (stderr, "ERROR STOP %d\n", error);
- error_stop (error);
+
+ terminate_internal (STAT_STOPPED_IMAGE, error);
+}
+
+
+/* FAIL IMAGE statement. */
+
+void
+PREFIX (fail_image) (void)
+{
+ fputs ("IMAGE FAILED!\n", stderr);
+
+ raise(SIGKILL);
+ /* A failing image is expected to take down the runtime regularly. */
+ terminate_internal (STAT_FAILED_IMAGE, 0);
+}
+
+int
+PREFIX (image_status) (int image)
+{
+#ifdef GFC_CAF_CHECK
+ if (image < 1 || image > caf_num_images)
+ {
+ char errmsg[60];
+ sprintf (errmsg, "Image #%d out of bounds of images 1..%d.", image,
+ caf_num_images);
+ caf_runtime_error (errmsg);
+ }
+#endif
+#ifdef WITH_FAILED_IMAGES
+ if (image_stati[image - 1] == 0)
+ {
+ int status, ierr;
+ /* Check that we are fine before doing anything.
+ *
+ * Do an MPI-operation to learn about failed/stopped images, that have
+ * not been detected yet. */
+ ierr = MPI_Test (&alive_request, &status, MPI_STATUSES_IGNORE);
+ MPI_Error_class (ierr, &status);
+ if (ierr == MPI_SUCCESS)
+ {
+ CAF_Win_lock (MPI_LOCK_SHARED, image - 1, *stat_tok);
+ ierr = MPI_Get (&status, 1, MPI_INT, image - 1, 0, 1, MPI_INT, *stat_tok);
+ dprint ("%d/%d: Image status of image #%d is: %d\n", caf_this_image,
+ caf_num_images, image, status);
+ CAF_Win_unlock (image - 1, *stat_tok);
+ image_stati[image - 1] = status;
+ }
+ else if (status == MPIX_ERR_PROC_FAILED)
+ image_stati[image - 1] = STAT_FAILED_IMAGE;
+ else
+ {
+ const int strcap = 200;
+ char errmsg[strcap];
+ int slen, supplied_len;
+ sprintf (errmsg, "Image status for image #%d returned mpi error: ",
+ image);
+ slen = strlen (errmsg);
+ supplied_len = strcap - slen;
+ MPI_Error_string (status, &errmsg[slen], &supplied_len);
+ caf_runtime_error (errmsg);
+ }
+ }
+ return image_stati[image - 1];
+#else
+ unsupported_fail_images_message ("IMAGE_STATUS()");
+#endif
+
+ return 0;
+}
+
+void
+PREFIX (failed_images) (gfc_descriptor_t *array, int team __attribute__ ((unused)),
+ int * kind)
+{
+ int local_kind = kind ? *kind : 4; /* GFC_DEFAULT_INTEGER_KIND = 4*/
+
+#ifdef WITH_FAILED_IMAGES
+ void *mem = calloc (num_images_failed, local_kind);
+ array->base_addr = mem;
+ for (int i = 0; i < caf_num_images; ++i)
+ {
+ if (image_stati[i] == STAT_FAILED_IMAGE)
+ {
+ switch (local_kind)
+ {
+ case 1:
+ *(int8_t *)mem = i + 1;
+ break;
+ case 2:
+ *(int16_t *)mem = i + 1;
+ break;
+ case 4:
+ *(int32_t *)mem = i + 1;
+ break;
+ case 8:
+ *(int64_t *)mem = i + 1;
+ break;
+#ifdef HAVE_GFC_INTEGER_16
+ case 16:
+ *(int128t *)mem = i + 1;
+ break;
+#endif
+ default:
+ caf_runtime_error("Unsupported integer kind %1 in caf_failed_images.", local_kind);
+ }
+ mem += local_kind;
+ }
+ }
+ array->dim[0]._ubound = num_images_failed-1;
+#else
+ unsupported_fail_images_message ("FAILED_IMAGES()");
+ array->dim[0]._ubound = -1;
+ array->base_addr = NULL;
+#endif
+ array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
+ | (local_kind << GFC_DTYPE_SIZE_SHIFT));
+ array->dim[0].lower_bound = 0;
+ array->dim[0]._stride = 1;
+ array->offset = 0;
+}
+
+void
+PREFIX (stopped_images) (gfc_descriptor_t *array, int team __attribute__ ((unused)),
+ int * kind)
+{
+ int local_kind = kind ? *kind : 4; /* GFC_DEFAULT_INTEGER_KIND = 4*/
+
+#ifdef WITH_FAILED_IMAGES
+ void *mem = calloc (num_images_stopped, local_kind);
+ array->base_addr = mem;
+ for (int i = 0; i < caf_num_images; ++i)
+ {
+ if (image_stati[i])
+ {
+ switch (local_kind)
+ {
+ case 1:
+ *(int8_t *)mem = i + 1;
+ break;
+ case 2:
+ *(int16_t *)mem = i + 1;
+ break;
+ case 4:
+ *(int32_t *)mem = i + 1;
+ break;
+ case 8:
+ *(int64_t *)mem = i + 1;
+ break;
+#ifdef HAVE_GFC_INTEGER_16
+ case 16:
+ *(int128t *)mem = i + 1;
+ break;
+#endif
+ default:
+ caf_runtime_error("Unsupported integer kind %1 in caf_stopped_images.", local_kind);
+ }
+ mem += local_kind;
+ }
+ }
+ array->dim[0]._ubound = num_images_stopped - 1;
+#else
+ unsupported_fail_images_message ("STOPPED_IMAGES()");
+ array->dim[0]._ubound = -1;
+ array->base_addr = NULL;
+#endif
+ array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
+ | (local_kind << GFC_DTYPE_SIZE_SHIFT));
+ array->dim[0].lower_bound = 0;
+ array->dim[0]._stride = 1;
+ array->offset = 0;
+}
+
+/* Give a descriptive message when failed images support is not available. */
+void
+unsupported_fail_images_message (const char * functionname)
+{
+ fprintf (stderr, "*** caf_mpi-lib runtime message on image %d:\n"
+ "*** The failed images feature '%s' of Fortran 2015 standard\n"
+ "*** is not available in this build. You need a compiler with failed images\n"
+ "*** support activated and compile OpenCoarrays with failed images support.\n",
+ caf_this_image, functionname);
+#ifdef STOP_ON_UNSUPPORTED
+ exit (EXIT_FAILURE);
+#endif
+}
+
+/* Give a descriptive message when support for an allocatable components feature
+ * is not available. */
+void
+unimplemented_alloc_comps_message (const char * functionname)
+{
+ fprintf (stderr, "*** caf_mpi-lib runtime message on image %d:\n"
+ "*** The allocatable components feature '%s' of Fortran 2008 standard\n"
+ "*** is not yet supported by OpenCoarrays.\n",
+ caf_this_image, functionname);
+#ifdef STOP_ON_UNSUPPORTED
+ exit (EXIT_FAILURE);
+#endif
}
diff --git a/src/tests/installation/installation-scripts.sh b/src/tests/installation/installation-scripts.sh
index 177f9ce..e4567ce 100755
--- a/src/tests/installation/installation-scripts.sh
+++ b/src/tests/installation/installation-scripts.sh
@@ -81,12 +81,23 @@
set -o errtrace
+if [[ "${BASH_SOURCE[0]}" != "${0}" ]]; then
+ # shellcheck disable=SC2154
+ if [[ "${__usage+x}" ]]; then
+ __b3bp_tmp_source_idx=1
+ fi
+fi
+
+# Set magic variables for current file, directory, os, etc.
+__dir="$(cd "$(dirname "${BASH_SOURCE[${__b3bp_tmp_source_idx:-0}]}")" && pwd)"
+__file="${__dir}/$(basename "${BASH_SOURCE[${__b3bp_tmp_source_idx:-0}]}")"
+
# requires `set -o errtrace`
__b3bp_err_report() {
- local error_code
- error_code=${?}
- error "Error in ${__file} in function ${1} on line ${2}"
- exit ${error_code}
+ local error_code
+ error_code=${?}
+ error "Error in ${__file} in function ${1} on line ${2}"
+ exit ${error_code}
}
# Uncomment the following line for always providing an error backtrace
trap '__b3bp_err_report "${FUNCNAME:-.}" ${LINENO}' ERR
@@ -103,8 +114,8 @@ if [[ ! -f "${B3B_USE_CASE:-}/bootstrap.sh" ]]; then
echo "Please set B3B_USE_CASE to the bash3boilerplate use-case directory path."
exit 2
else
- # shellcheck source=../../../prerequisites/use-case/bootstrap.sh
- source "${B3B_USE_CASE}/bootstrap.sh" "$@"
+ # shellcheck source=../../../prerequisites/use-case/bootstrap.sh
+ source "${B3B_USE_CASE}/bootstrap.sh" "$@"
fi
### End of boilerplate -- start user edits below #########################
@@ -113,12 +124,11 @@ export __flag_present=1
# Set up a function to call when receiving an EXIT signal to do some cleanup. Remove if
# not needed. Other signals can be trapped too, like SIGINT and SIGTERM.
-function cleanup_before_exit () {
+function cleanup_before_exit() {
info "Cleaning up. Done"
}
trap cleanup_before_exit EXIT # The signal is specified here. Could be SIGINT, SIGTERM etc.
-
pushd "${OPENCOARRAYS_SRC_DIR}"/src/tests/installation
# shellcheck source=../../../prerequisites/stack.sh
diff --git a/src/tests/installation/test-stack.sh b/src/tests/installation/test-stack.sh
old mode 100644
new mode 100755
index 09ae41b..3a90b91
--- a/src/tests/installation/test-stack.sh
+++ b/src/tests/installation/test-stack.sh
@@ -1,139 +1,136 @@
-functions_exist()
-{
- : "${1?'Missing function name list'}"
+# shellcheck shell=bash
+functions_exist() {
+ : "${1?'Missing function name list'}"
- for function_name
- do
- if [[ "`type -t $function_name`" != "function" ]]; then
+ for function_name; do
+ if [[ "$(type -t "${function_name}")" != "function" ]]; then
emergency "function ${function_name} does not exist"
- fi
- done
+ fi
+ done
}
-detect_missing_variable_name()
-{
- : "${1?'detect_missing_variable name: Missing function name'}"
+detect_missing_variable_name() {
+ : "${1?'detect_missing_variable name: Missing function name'}"
- stack_new __dummy_stack
+ stack_new __dummy_stack
- for function_name
- do
- expected_error="Missing variable name in ${function_name}"
- error_message="$($function_name _dummy_stack_name 2>&1 > /dev/null)" || true
- error_message="${error_message##*: }" # grab text after final colon/space sequence
- if [[ "${error_message}" != ${expected_error} ]]; then
- emergency "$function_name failed to detect '${expected_error}'"
- fi
+ for function_name; do
+ expected_error="Missing variable name in ${function_name}"
+ error_message="$(${function_name} _dummy_stack_name 2>&1 >/dev/null)" || true
+ error_message="${error_message##*: }" # grab text after final colon/space sequence
+ if [[ "${error_message}" != "${expected_error}" ]]; then
+ emergency "${function_name} failed to detect '${expected_error}'"
+ fi
done
- stack_destroy __dummy_stack
+ stack_destroy __dummy_stack
}
-detect_missing_stack_name()
-{
- : "${1?'detect_missing_name: Missing function name'}"
-
- expected_error="Missing stack name"
- debug "detect_missing_stack_name: \${expected_error}=${expected_error}"
-
- for function_name
- do
- debug "detect_missing_stack_name: executing \"\$($function_name 2>&1 > /dev/null)\" || true"
- error_message="$($function_name 2>&1 > /dev/null)" || true
- error_message="${error_message##*: }" # grab text after final colon/space sequence
- debug "detect_missing_stack_name: \${error_message}=${error_message}"
- if [[ "${error_message}" != ${expected_error} ]]; then
- emergency "$function_name failed to detect '${expected_error}'"
- fi
- done
+detect_missing_stack_name() {
+ : "${1?'detect_missing_name: Missing function name'}"
+
+ expected_error="Missing stack name"
+ debug "detect_missing_stack_name: \${expected_error}=${expected_error}"
+
+ for function_name; do
+ debug "detect_missing_stack_name: executing \"\$(${function_name} 2>&1 > /dev/null)\" || true"
+ error_message="$(${function_name} 2>&1 >/dev/null)" || true
+ error_message="${error_message##*: }" # grab text after final colon/space sequence
+ debug "detect_missing_stack_name: \${error_message}=${error_message}"
+ if [[ "${error_message}" != "${expected_error}" ]]; then
+ emergency "${function_name} failed to detect '${expected_error}'"
+ fi
+ done
}
-detect_no_such_stack()
-{
- : "${1?'detect_no_such_name: Missing function name'}"
-
- stack_name="__nonexistent_stack"
- expected_error="No such stack -- "
- debug "detect_no_such_stack: \${expected_error}=${expected_error}"
-
- dummy_variable=""
-
- for function_name
- do
- debug "detect_no_such_stack: executing \"\$($function_name $stack_name dummy_variable 2>&1 > /dev/null)\" || true"
- error_message="$($function_name $stack_name dummy_variable 2>&1 > /dev/null)" || true
- missing_stack="${error_message##${expected_error}}" # grab text after final colon/space sequence
- debug "detect_no_such_stack: \${missing_stack}=${missing_stack}"
- if [[ "${missing_stack}" != ${stack_name} ]]; then
- emergency "$function_name failed to detect missing '${stack_name}'"
- fi
- done
+detect_no_such_stack() {
+ : "${1?'detect_no_such_name: Missing function name'}"
+
+ stack_name="__nonexistent_stack"
+ expected_error="No such stack -- "
+ debug "detect_no_such_stack: \${expected_error}=${expected_error}"
+
+ # shellcheck disable=SC2034
+ dummy_variable=""
+
+ for function_name; do
+ debug "detect_no_such_stack: executing \"\$(${function_name} ${stack_name} dummy_variable 2>&1 > /dev/null)\" || true"
+ error_message="$(${function_name} ${stack_name} dummy_variable 2>&1 >/dev/null)" || true
+ missing_stack="${error_message##${expected_error}}" # grab text after final colon/space sequence
+ debug "detect_no_such_stack: \${missing_stack}=${missing_stack}"
+ if [[ "${missing_stack}" != "${stack_name}" ]]; then
+ emergency "${function_name} failed to detect missing '${stack_name}'"
+ fi
+ done
}
-detect_duplicate_stack_creation()
-{
- : "${1?'detect_duplicate_stack_creation: Missing function name'}"
-
- stack_name="__dummy_stack"
- stack_new "${stack_name}"
-
- expected_error="Stack already exists -- "
- debug "detect_duplicate_stack_creation: \${expected_error}=${expected_error}"
- function_name="stack_new"
-
- debug "detect_duplicate_stack_creation: executing \"\$($function_name $stack_name 2>&1 > /dev/null)\" || true"
- error_message="$($function_name $stack_name dummy_variable 2>&1 > /dev/null)" || true
- duplicate_stack="${error_message##${expected_error}}" # grab text after final colon/space sequence
- debug "detect_no_such_stack: \${duplicate_stack}=${duplicate_stack}"
- if [[ "${duplicate_stack}" != ${stack_name} ]]; then
- emergency "$function_name failed to detect duplicate '${stack_name}'"
- fi
- stack_destroy ${stack_name}
+detect_duplicate_stack_creation() {
+ : "${1?'detect_duplicate_stack_creation: Missing function name'}"
+
+ stack_name="__dummy_stack"
+ stack_new "${stack_name}"
+
+ expected_error="Stack already exists -- "
+ debug "detect_duplicate_stack_creation: \${expected_error}=${expected_error}"
+ function_name="stack_new"
+
+ debug "detect_duplicate_stack_creation: executing \"\$(${function_name} ${stack_name} 2>&1 > /dev/null)\" || true"
+ error_message="$(${function_name} ${stack_name} dummy_variable 2>&1 >/dev/null)" || true
+ duplicate_stack="${error_message##${expected_error}}" # grab text after final colon/space sequence
+ debug "detect_no_such_stack: \${duplicate_stack}=${duplicate_stack}"
+ if [[ "${duplicate_stack}" != "${stack_name}" ]]; then
+ emergency "${function_name} failed to detect duplicate '${stack_name}'"
+ fi
+ stack_destroy ${stack_name}
}
-verify_stack_size_changes()
-{
+verify_stack_size_changes() {
stack_new foobar
stack_size foobar __foobar_size
expected_size=0
- if [[ "${__foobar_size}" != "${expected_size}" ]]; then
+ # shellcheck disable=SC2154
+ if [[ "${__foobar_size}" != "${expected_size}" ]]; then
emergency "verify_stack_size_changes: size=${__foobar_size} (expected ${expected_size})"
fi
stack_push foobar kernel
stack_size foobar __foobar_new_size
- (( expected_size += 1 ))
- if [[ "${__foobar_new_size}" != "${expected_size}" ]]; then
+ ((expected_size += 1))
+ # shellcheck disable=SC2154
+ if [[ "${__foobar_new_size}" != "${expected_size}" ]]; then
emergency "verify_stack_size_changes: size=${__foobar_new_size} (expected 1)"
fi
stack_peek foobar tmp
- if [[ "${tmp}" != "kernel" ]]; then
+ # shellcheck disable=SC2154
+ if [[ "${tmp}" != "kernel" ]]; then
emergency "verify_stack_size_changes: peeked item ('${tmp}') mismatch with pushed item ('kernel')"
fi
stack_size foobar __should_be_unchanged
- if [[ "${__should_be_unchanged}" != "${expected_size}" ]]; then
+ # shellcheck disable=SC2154
+ if [[ "${__should_be_unchanged}" != "${expected_size}" ]]; then
emergency "verify_stack_size_changes: size=${__should_be_unchanged} (expected ${expected_size})"
fi
stack_pop foobar popped
- if [[ "${popped}" != "kernel" ]]; then
+ # shellcheck disable=SC2154
+ if [[ "${popped}" != "kernel" ]]; then
emergency "verify_stack_size_changes: popped item ('${popped}') mismatch with pushed item ('kernel')"
fi
- (( expected_size -= 1 )) || true
+ ((expected_size -= 1)) || true
stack_size foobar __final_size
- if [[ "${__final_size}" != "${expected_size}" ]]; then
+ # shellcheck disable=SC2154
+ if [[ "${__final_size}" != "${expected_size}" ]]; then
emergency "verify_stack_size_changes: size=${__final_size} (expected ${expected_size})"
fi
}
-test_stack()
-{
+test_stack() {
# Verify availability of expected functions:
functions_exist \
stack_new stack_exists stack_print stack_push stack_peek stack_pop stack_size stack_destroy
-
+
# Verify that each named function detects missing stack-name arguments:
detect_missing_stack_name \
stack_new stack_exists stack_print stack_push stack_peek stack_pop stack_size stack_destroy
@@ -148,7 +145,7 @@ test_stack()
# Verify that duplicate creation generates the expected error:
detect_duplicate_stack_creation \
- stack_new
+ stack_new
# Verify that push, peek, and pop yield correct size changes or lack thereof:
verify_stack_size_changes
diff --git a/src/tests/unit/CMakeLists.txt b/src/tests/unit/CMakeLists.txt
index 017d983..015ce11 100644
--- a/src/tests/unit/CMakeLists.txt
+++ b/src/tests/unit/CMakeLists.txt
@@ -4,6 +4,9 @@ if (${opencoarrays_aware_compiler})
add_subdirectory(init_register)
add_subdirectory(collectives)
add_subdirectory(sync)
+ if(NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7)
+ add_subdirectory(fail_images)
+ endif()
else()
add_subdirectory(extensions)
endif()
diff --git a/src/tests/unit/extensions/CMakeLists.txt b/src/tests/unit/extensions/CMakeLists.txt
index 452c0c2..7f09bf1 100644
--- a/src/tests/unit/extensions/CMakeLists.txt
+++ b/src/tests/unit/extensions/CMakeLists.txt
@@ -31,7 +31,7 @@ function(generate_test_script base_name num_images)
endif()
file(APPEND "${harness}" "${CMAKE_INSTALL_PREFIX}/bin/cafrun -np ${num_images} ./${executable}\n")
file( INSTALL "${harness}"
- PERMISSIONS WORLD_EXECUTE WORLD_READ OWNER_EXECUTE OWNER_READ GROUP_EXECUTE GROUP_READ
+ PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE
DESTINATION ${CMAKE_CURRENT_BINARY_DIR}
)
diff --git a/src/tests/unit/fail_images/CMakeLists.txt b/src/tests/unit/fail_images/CMakeLists.txt
new file mode 100644
index 0000000..0bc5d01
--- /dev/null
+++ b/src/tests/unit/fail_images/CMakeLists.txt
@@ -0,0 +1,27 @@
+add_executable(image_fail_test_1 image_fail_test_1.f90)
+target_link_libraries(image_fail_test_1 OpenCoarrays)
+
+add_executable(image_status_test_1 image_status_test_1.f90)
+target_link_libraries(image_status_test_1 OpenCoarrays)
+
+add_executable(image_fail_and_sync_test_1 image_fail_and_sync_test_1.f90)
+target_link_libraries(image_fail_and_sync_test_1 OpenCoarrays)
+
+add_executable(image_fail_and_sync_test_2 image_fail_and_sync_test_2.f90)
+target_link_libraries(image_fail_and_sync_test_2 OpenCoarrays)
+
+add_executable(image_fail_and_sync_test_3 image_fail_and_sync_test_3.f90)
+target_link_libraries(image_fail_and_sync_test_3 OpenCoarrays)
+
+add_executable(image_fail_and_status_test_1 image_fail_and_status_test_1.f90)
+target_link_libraries(image_fail_and_status_test_1 OpenCoarrays)
+
+add_executable(image_fail_and_get_test_1 image_fail_and_get_test_1.f90)
+target_link_libraries(image_fail_and_get_test_1 OpenCoarrays)
+
+add_executable(image_fail_and_failed_images_test_1 image_fail_and_failed_images_test_1.f90)
+target_link_libraries(image_fail_and_failed_images_test_1 OpenCoarrays)
+
+add_executable(image_fail_and_stopped_images_test_1 image_fail_and_stopped_images_test_1.f90)
+target_link_libraries(image_fail_and_stopped_images_test_1 OpenCoarrays)
+
diff --git a/src/tests/unit/fail_images/image_fail_and_failed_images_test_1.f90 b/src/tests/unit/fail_images/image_fail_and_failed_images_test_1.f90
new file mode 100644
index 0000000..73093e8
--- /dev/null
+++ b/src/tests/unit/fail_images/image_fail_and_failed_images_test_1.f90
@@ -0,0 +1,31 @@
+! Check that after an image has failed the failed_images function returns the
+! correct indices.
+! Image two is to fail, all others to continue.
+
+program image_fail_and_failed_images_test_1
+ use iso_fortran_env , only : STAT_FAILED_IMAGE
+ implicit none
+ integer :: i, stat
+ integer, allocatable :: fimages(:)
+
+ associate(np => num_images(), me => this_image())
+ if (np < 3) error stop "I need at least 3 images to function."
+ do i= 1, np
+ if (image_status(i) /= 0) error stop "image_status(i) should not fail"
+ end do
+
+ ! Need a sync here to make sure all images are started and to prevent image fail
+ ! is not already detected in above image_status(i).
+ sync all
+ if (me == 2) fail image
+ sync all (STAT=stat)
+
+ fimages = failed_images()
+ if (size(fimages) /= 1) error stop "failed_images()'s size should be one."
+ if (fimages(1) /= 2) error stop "The second image should have failed."
+
+ if (me == 1) print *,"Test passed."
+ end associate
+
+end program image_fail_and_failed_images_test_1
+
diff --git a/src/tests/unit/fail_images/image_fail_and_get_test_1.f90 b/src/tests/unit/fail_images/image_fail_and_get_test_1.f90
new file mode 100644
index 0000000..8672f37
--- /dev/null
+++ b/src/tests/unit/fail_images/image_fail_and_get_test_1.f90
@@ -0,0 +1,32 @@
+! Check that after an image has failed a get to other images is still possible.
+! Image two is to fail, all others to continue.
+
+program image_fail_and_get_test_1
+ use iso_fortran_env , only : STAT_FAILED_IMAGE
+ implicit none
+ integer :: i, stat
+ integer, save :: share[*]
+
+ associate(np => num_images(), me => this_image())
+ if (np < 3) error stop "I need at least 3 images to function."
+
+ share = 37
+
+ sync all
+ if (me == 2) fail image
+ sync all (STAT=stat)
+
+ print *, "Checking shared value."
+ do i= 1, np
+ if (i /= 2 .AND. i /= me) then
+ if (share[i, STAT=stat] /= 37) error stop "Expected to get value from images alive."
+ print *, me, "Stat of #", i, " is:", stat
+ end if
+ end do
+
+ sync all(STAT=stat)
+ if (me == 1) print *,"Test passed."
+ end associate
+
+end program image_fail_and_get_test_1
+
diff --git a/src/tests/unit/fail_images/image_fail_and_status_test_1.f90 b/src/tests/unit/fail_images/image_fail_and_status_test_1.f90
new file mode 100644
index 0000000..917b5a9
--- /dev/null
+++ b/src/tests/unit/fail_images/image_fail_and_status_test_1.f90
@@ -0,0 +1,33 @@
+! Check that the status of a failed image is retrieved correctly.
+! Image two is to fail, all others to continue.
+
+program image_fail_and_status_test_1
+ use iso_fortran_env , only : STAT_FAILED_IMAGE, STAT_STOPPED_IMAGE
+ implicit none
+ integer :: i, stat
+
+ associate(np => num_images(), me => this_image())
+ if (np < 3) error stop "I need at least 3 images to function."
+ do i= 1, np
+ if (image_status(i) /= 0) error stop "image_status(i) should not fail"
+ end do
+
+ ! Need to sync here or above image_status might catch a fail already.
+ sync all
+ if (me == 2) fail image
+ sync all (STAT=stat)
+ ! Check that all images returning from the sync report the failure of an image
+ print *,"sync all (STAT=", stat, ")"
+ if (stat /= STAT_FAILED_IMAGE) error stop "Expected sync all (STAT == STAT_FAILED_IMAGE)."
+
+ do i= 1, np
+ stat = image_status(i)
+ if (i /= 2 .AND. stat /= 0 .AND. stat /= STAT_STOPPED_IMAGE) error stop "image_status(i) should not fail"
+ if (i == 2 .AND. stat /= STAT_FAILED_IMAGE) error stop "image_status(2) should report fail"
+ end do
+
+ if (me == 1) print *,"Test passed."
+ end associate
+
+end program image_fail_and_status_test_1
+
diff --git a/src/tests/unit/fail_images/image_fail_and_stopped_images_test_1.f90 b/src/tests/unit/fail_images/image_fail_and_stopped_images_test_1.f90
new file mode 100644
index 0000000..3980d61
--- /dev/null
+++ b/src/tests/unit/fail_images/image_fail_and_stopped_images_test_1.f90
@@ -0,0 +1,30 @@
+! Check that letting images exit the stopped_images function returns the
+! correct indices.
+! Image two is to stop, all others to continue.
+
+program image_fail_and_stopped_images_test_1
+ implicit none
+ integer :: i, stat
+ integer, allocatable :: simages(:)
+
+ associate(np => num_images(), me => this_image())
+ if (np < 3) error stop "I need at least 3 images to function."
+
+ ! Need a sync here to make sure all images are started and to prevent image fail
+ ! is not already detected in above image_status(i).
+ sync all
+ if (me == 2) stop 0
+ sync all (STAT=stat)
+
+ simages = stopped_images()
+ if (size(simages) /= 1) error stop "stopped_images()'s size should be one."
+ if (simages(1) /= 2) then
+ print *, me, "stopped image: ", simages(1)
+ error stop "The second image should have stopped."
+ end if
+
+ if (me == 1) print *,"Test passed."
+ end associate
+
+end program image_fail_and_stopped_images_test_1
+
diff --git a/src/tests/unit/fail_images/image_fail_and_sync_test_1.f90 b/src/tests/unit/fail_images/image_fail_and_sync_test_1.f90
new file mode 100644
index 0000000..fb80d86
--- /dev/null
+++ b/src/tests/unit/fail_images/image_fail_and_sync_test_1.f90
@@ -0,0 +1,27 @@
+! Check that after an image has failed a sync all ends correctly.
+! Image two is to fail, all others to continue.
+
+program image_fail_and_sync_test_1
+ use iso_fortran_env , only : STAT_FAILED_IMAGE
+ implicit none
+ integer :: i, syncAllStat
+
+ associate(np => num_images(), me => this_image())
+ if (np < 3) error stop "I need at least 3 images to function."
+ do i= 1, np
+ if (image_status(i) /= 0) error stop "image_status(i) should not fail"
+ end do
+
+ ! Need a sync here to make sure all images are started and to prevent image fail
+ ! is not already detected in above image_status(i).
+ sync all
+ if (me == 2) fail image
+ sync all (STAT=syncAllStat)
+ ! Check that all images returning from the sync report the failure of an image
+ if (syncAllStat /= STAT_FAILED_IMAGE) error stop "Expected sync all (STAT == STAT_FAILED_IMAGE)."
+
+ if (me == 1) print *,"Test passed."
+ end associate
+
+end program image_fail_and_sync_test_1
+
diff --git a/src/tests/unit/fail_images/image_fail_and_sync_test_2.f90 b/src/tests/unit/fail_images/image_fail_and_sync_test_2.f90
new file mode 100644
index 0000000..44dc932
--- /dev/null
+++ b/src/tests/unit/fail_images/image_fail_and_sync_test_2.f90
@@ -0,0 +1,25 @@
+! Check that after an image has failed a sync images ends correctly.
+! Image two is to fail, all others to continue.
+
+program image_fail_and_sync_test_2
+ use iso_fortran_env , only : STAT_FAILED_IMAGE
+ implicit none
+ integer :: i, syncAllStat
+
+ associate(np => num_images(), me => this_image())
+ if (np < 3) error stop "I need at least 3 images to function."
+ do i= 1, np
+ if (image_status(i) /= 0) error stop "image_status(i) should not fail"
+ end do
+
+ sync all
+ if (me == 2) fail image
+ sync images (*, STAT=syncAllStat)
+ ! Check that all images returning from the sync report the failure of an image
+ if (syncAllStat /= STAT_FAILED_IMAGE) error stop "Expected sync all (STAT == STAT_FAILED_IMAGE)."
+
+ if (me == 1) print *,"Test passed."
+ end associate
+
+end program image_fail_and_sync_test_2
+
diff --git a/src/tests/unit/fail_images/image_fail_and_sync_test_3.f90 b/src/tests/unit/fail_images/image_fail_and_sync_test_3.f90
new file mode 100644
index 0000000..2cc92dd
--- /dev/null
+++ b/src/tests/unit/fail_images/image_fail_and_sync_test_3.f90
@@ -0,0 +1,24 @@
+! Check that after an image has failed a sync images ends correctly.
+! Image two is to fail, all others to continue.
+
+program image_fail_and_sync_test_3
+ use iso_fortran_env , only : STAT_FAILED_IMAGE
+ implicit none
+ integer :: i, syncAllStat
+
+ associate(np => num_images(), me => this_image())
+ if (np < 3) error stop "I need at least 3 images to function."
+ do i= 1, np
+ if (image_status(i) /= 0) error stop "image_status(i) should not fail"
+ end do
+
+ sync all
+ if (me == 2) fail image
+ sync all(STAT=syncAllStat)
+ if (image_status(2) /= STAT_FAILED_IMAGE) error stop "Expected STAT_FAILED_IMAGE for image 2."
+
+ if (me == 1) print *,"Test passed."
+ end associate
+
+end program image_fail_and_sync_test_3
+
diff --git a/src/tests/unit/fail_images/image_fail_test_1.f90 b/src/tests/unit/fail_images/image_fail_test_1.f90
new file mode 100644
index 0000000..544ea0c
--- /dev/null
+++ b/src/tests/unit/fail_images/image_fail_test_1.f90
@@ -0,0 +1,21 @@
+! Check that failing an image works.
+! Image two is to fail, all others to continue.
+
+program image_fail_test_1
+ use iso_fortran_env , only : STAT_FAILED_IMAGE
+ implicit none
+ integer :: i, syncAllStat
+
+ associate(np => num_images(), me => this_image())
+ if (np < 3) error stop "I need at least 3 images to function."
+
+ if (me == 2) fail image
+
+ if (me == 2) print *, "Test failed."
+
+ sync all (STAT=syncAllStat)
+ if (me == 1) print *, "Test passed."
+ end associate
+
+end program image_fail_test_1
+
diff --git a/src/tests/unit/fail_images/image_status_test_1.f90 b/src/tests/unit/fail_images/image_status_test_1.f90
new file mode 100644
index 0000000..e6cf521
--- /dev/null
+++ b/src/tests/unit/fail_images/image_status_test_1.f90
@@ -0,0 +1,18 @@
+! Check the status of all images. Error only, when one unexpectedly failed.
+
+program test_image_status_1
+ use iso_fortran_env , only : STAT_STOPPED_IMAGE
+ implicit none
+ integer :: i
+
+ associate(np => num_images(), me => this_image())
+ do i= 1, np
+ if (image_status(i) /= 0) error stop "image_status(i) should not fail"
+ end do
+
+ sync all
+ if (me == 1) print *,"Test passed."
+ end associate
+
+end program test_image_status_1
+
diff --git a/src/tests/unit/init_register/async_comp_alloc.f90 b/src/tests/unit/init_register/async_comp_alloc.f90
index 8895684..a3fd73c 100644
--- a/src/tests/unit/init_register/async_comp_alloc.f90
+++ b/src/tests/unit/init_register/async_comp_alloc.f90
@@ -60,11 +60,9 @@ program async_comp_alloc
call assert(allocation_status == success, "allocated(obj)")
call assert(.not. allocated(obj%i) , ".not. allocated(obj%i)")
- if (me==1) print *,"known failure -- ctest will timeout (see https://github.com/sourceryinstitute/opencoarrays/issues/260)."
-
block
integer :: allocating_image, test_image
- character(len=8) :: image_number
+ character(len=20) :: image_number
loop_over_all_image_numbers: do allocating_image = 1, np
!! Check that all allocations have been performed up to allocating_image and
@@ -98,8 +96,10 @@ program async_comp_alloc
call assert( obj%i == me , "obj%i == this_image()")
sync all
end if
+ sync all
end do loop_over_all_image_numbers
end block
+ if (me == 1) print *, "Test passed."
end associate
contains
subroutine assert(assertion,description,stat)
diff --git a/src/tests/unit/sync/syncimages_status.f90 b/src/tests/unit/sync/syncimages_status.f90
index a90e6d9..36f302c 100644
--- a/src/tests/unit/sync/syncimages_status.f90
+++ b/src/tests/unit/sync/syncimages_status.f90
@@ -18,4 +18,5 @@ program sync_images_stat
if(me == 2) print *, 'Test passed.'
end if
+ ! Image 1 implicitly synchronizes as part of normal termination
end program sync_images_stat
--
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