From b7fc3ff1faea469ae87a19da06e2f648305da4ac Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Wed, 8 Feb 2017 09:25:05 +0100 Subject: [PATCH 1/2] Add value- and char-array support to co_reduce functions. Add support for recude-functions with value parameters. Add support for char-arrays as arguments to reduce-functions. Rename co_reduce_1 to internal_co_reduce to get a better naming. Create mpi-datatype to transport the char-array length. Fixes #172. --- CMakeLists.txt | 5 +- src/libcaf.h | 7 + src/mpi/mpi_caf.c | 155 +++++++++++++----- src/tests/regression/reported/CMakeLists.txt | 6 + .../issue-172-wrong-co_reduce-int64.f90 | 65 ++++++++ .../issue-172-wrong-co_reduce-int8.f90 | 65 ++++++++ src/tests/unit/collectives/CMakeLists.txt | 3 + .../unit/collectives/co_reduce_string.f90 | 78 +++++++++ 8 files changed, 346 insertions(+), 38 deletions(-) create mode 100644 src/tests/regression/reported/issue-172-wrong-co_reduce-int64.f90 create mode 100644 src/tests/regression/reported/issue-172-wrong-co_reduce-int8.f90 create mode 100644 src/tests/unit/collectives/co_reduce_string.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index f30f5e18f..ebd59baf4 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -442,8 +442,11 @@ if(opencoarrays_aware_compiler) add_mpi_test(convert-before-put 3 ${tests_root}/regression/reported/convert-before-put) add_mpi_test(event-post 3 ${tests_root}/regression/reported/event-post) add_mpi_test(co_reduce-factorial 4 ${tests_root}/regression/reported/co_reduce-factorial) + 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) +# set_property(TEST co_reduce-factorial PROPERTY WILL_FAIL TRUE) 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/src/libcaf.h b/src/libcaf.h index b9bb86b8a..166c618a3 100644 --- a/src/libcaf.h +++ b/src/libcaf.h @@ -197,6 +197,13 @@ typedef struct caf_reference_t { #endif +/* The following defines give the bits in the opr_flags argument to CO_REDUCE. + Keep in sync with the libgfortran.h file of gcc/fortran. */ +#define GFC_CAF_BYREF (1<<0) +#define GFC_CAF_HIDDENLEN (1<<1) +#define GFC_CAF_ARG_VALUE (1<<2) +#define GFC_CAF_ARG_DESC (1<<3) + /* Common auxiliary functions: caf_auxiliary.c. */ bool PREFIX (is_contiguous) (gfc_descriptor_t *); diff --git a/src/mpi/mpi_caf.c b/src/mpi/mpi_caf.c index 3e340d162..11edd4d52 100644 --- a/src/mpi/mpi_caf.c +++ b/src/mpi/mpi_caf.c @@ -141,10 +141,17 @@ MPI_Comm CAF_COMM_WORLD; (and thus finalization) of MPI. */ bool caf_owns_mpi = false; -/* Foo function pointers for coreduce */ -int (*foo_int32_t)(void *, void *); -float (*foo_float)(void *, void *); -double (*foo_double)(void *, void *); +/* Foo function pointers for coreduce. + The handles when arguments are passed by reference. */ +int (*int32_t_by_reference)(void *, void *); +float (*float_by_reference)(void *, void *); +double (*double_by_reference)(void *, void *); +/* Strings are always passed by reference. */ +void (*char_by_reference)(void *, int, void *, void *, int, int); +/* The handles when arguments are passed by value. */ +int (*int32_t_by_value)(int32_t, int32_t); +float (*float_by_value)(float, float); +double (*double_by_value)(double, double); /* Define shortcuts for Win_lock and _unlock depending on whether the primitives are available in the MPI implementation. When they are not available the @@ -3125,17 +3132,29 @@ name (datatype *invec, datatype *inoutvec, int *len, \ operator; \ } -#define FOOFUNC(TYPE) foo_ ## TYPE +#define REFERENCE_FUNC(TYPE) TYPE ## _by_reference +#define VALUE_FUNC(TYPE) TYPE ## _by_value #define GEN_COREDUCE(name, dt) \ static void \ -name (void *invec, void *inoutvec, int *len, \ +name##_by_reference_adapter (void *invec, void *inoutvec, int *len, \ MPI_Datatype *datatype) \ { \ int i; \ for(i=0;i<*len;i++) \ { \ - *((dt*)inoutvec) = (dt)(FOOFUNC(dt)((dt *)invec,(dt *)inoutvec)); \ + *((dt*)inoutvec) = (dt)(REFERENCE_FUNC(dt)((dt *)invec, (dt *)inoutvec)); \ + invec+=sizeof(dt); inoutvec+=sizeof(dt); \ + } \ +} \ +static void \ +name##_by_value_adapter (void *invec, void *inoutvec, int *len, \ + MPI_Datatype *datatype) \ +{ \ + int i; \ + for(i=0;i<*len;i++) \ + { \ + *((dt*)inoutvec) = (dt)(VALUE_FUNC(dt)(*(dt *)invec, *(dt *)inoutvec)); \ invec+=sizeof(dt); inoutvec+=sizeof(dt); \ } \ } @@ -3144,6 +3163,22 @@ GEN_COREDUCE (redux_int32, int32_t) GEN_COREDUCE (redux_real32, float) GEN_COREDUCE (redux_real64, double) +static void \ +redux_char_by_reference_adapter (void *invec, void *inoutvec, int *len, + MPI_Datatype *datatype) +{ + long int string_len; + MPI_Type_extent(*datatype, &string_len); + for(int i = 0; i < *len; i++) + { + /* The length of the result is fixed, i.e., no deferred string length is + * allowed there. */ + REFERENCE_FUNC(char)((char *)inoutvec, string_len, (char *)invec, (char *)inoutvec, string_len, string_len); + invec += sizeof(char) * string_len; + inoutvec += sizeof(char) * string_len; + } +} + #ifndef MPI_INTEGER1 GEN_REDUCTION (do_sum_int1, int8_t, inoutvec[i] += invec[i]) GEN_REDUCTION (do_min_int1, int8_t, @@ -3198,7 +3233,7 @@ GEN_REDUCTION (do_max_complex10, _Complex __float128, static MPI_Datatype -get_MPI_datatype (gfc_descriptor_t *desc) +get_MPI_datatype (gfc_descriptor_t *desc, int char_len) { /* FIXME: Better check whether the sizes are okay and supported; MPI3 adds more types, e.g. MPI_INTEGER1. */ @@ -3255,7 +3290,14 @@ get_MPI_datatype (gfc_descriptor_t *desc) GFC_DTYPE_TYPE_SIZE == GFC_TYPE_CHARACTER + 64*strlen */ if ( (GFC_DTYPE_TYPE_SIZE(desc)-GFC_DTYPE_CHARACTER)%64==0 ) - return MPI_CHARACTER; + { + MPI_Datatype string; + if (char_len == 0) + char_len = GFC_DESCRIPTOR_SIZE (desc); + MPI_Type_contiguous(char_len, MPI_CHARACTER, &string); + MPI_Type_commit(&string); + return string; + } caf_runtime_error ("Unsupported data type in collective: %ld\n",GFC_DTYPE_TYPE_SIZE (desc)); return 0; @@ -3263,14 +3305,14 @@ get_MPI_datatype (gfc_descriptor_t *desc) static void -co_reduce_1 (MPI_Op op, gfc_descriptor_t *source, int result_image, int *stat, - char *errmsg, int src_len __attribute__ ((unused)), int errmsg_len) +internal_co_reduce (MPI_Op op, gfc_descriptor_t *source, int result_image, int *stat, + char *errmsg, int src_len, int errmsg_len) { size_t i, size; int j, ierr; int rank = GFC_DESCRIPTOR_RANK (source); - MPI_Datatype datatype = get_MPI_datatype (source); + MPI_Datatype datatype = get_MPI_datatype (source, src_len); size = 1; for (j = 0; j < rank; j++) @@ -3285,17 +3327,17 @@ co_reduce_1 (MPI_Op op, gfc_descriptor_t *source, int result_image, int *stat, if (rank == 0 || PREFIX (is_contiguous) (source)) { if (result_image == 0) - ierr = MPI_Allreduce (MPI_IN_PLACE, source->base_addr, size, datatype, + ierr = MPI_Allreduce (MPI_IN_PLACE, source->base_addr, size, datatype, op, CAF_COMM_WORLD); else if (result_image == caf_this_image) - ierr = MPI_Reduce (MPI_IN_PLACE, source->base_addr, size, datatype, op, + ierr = MPI_Reduce (MPI_IN_PLACE, source->base_addr, size, datatype, op, result_image-1, CAF_COMM_WORLD); else - ierr = MPI_Reduce (source->base_addr, NULL, size, datatype, op, + ierr = MPI_Reduce (source->base_addr, NULL, size, datatype, op, result_image-1, CAF_COMM_WORLD); if (ierr) goto error; - return; + goto co_reduce_cleanup; } for (i = 0; i < size; i++) @@ -3316,18 +3358,21 @@ co_reduce_1 (MPI_Op op, gfc_descriptor_t *source, int result_image, int *stat, void *sr = (void *)((char *) source->base_addr + array_offset_sr*GFC_DESCRIPTOR_SIZE (source)); if (result_image == 0) - ierr = MPI_Allreduce (MPI_IN_PLACE, sr, 1, datatype, op, + ierr = MPI_Allreduce (MPI_IN_PLACE, sr, 1, datatype, op, CAF_COMM_WORLD); else if (result_image == caf_this_image) - ierr = MPI_Reduce (MPI_IN_PLACE, sr, 1, datatype, op, + ierr = MPI_Reduce (MPI_IN_PLACE, sr, 1, datatype, op, result_image-1, CAF_COMM_WORLD); else - ierr = MPI_Reduce (sr, NULL, 1, datatype, op, result_image-1, + ierr = MPI_Reduce (sr, NULL, 1, datatype, op, result_image-1, CAF_COMM_WORLD); if (ierr) goto error; } +co_reduce_cleanup: + if (GFC_DESCRIPTOR_TYPE (source) == BT_CHARACTER) + MPI_Type_free (&datatype); if (stat) *stat = 0; return; @@ -3360,7 +3405,7 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e int j, ierr; int rank = GFC_DESCRIPTOR_RANK (a); - MPI_Datatype datatype = get_MPI_datatype (a); + MPI_Datatype datatype = get_MPI_datatype (a, 0); size = 1; for (j = 0; j < rank; j++) @@ -3375,7 +3420,7 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e if (rank == 0) { if (datatype != MPI_CHARACTER) - ierr = MPI_Bcast(a->base_addr, size, datatype, source_image-1, CAF_COMM_WORLD); + ierr = MPI_Bcast(a->base_addr, size, datatype, source_image-1, CAF_COMM_WORLD); else { int a_length; @@ -3386,7 +3431,7 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e if (ierr) goto error; /* Broadcast the string itself */ - ierr = MPI_Bcast(a->base_addr, a_length, datatype, source_image-1, CAF_COMM_WORLD); + ierr = MPI_Bcast(a->base_addr, a_length, datatype, source_image-1, CAF_COMM_WORLD); } if (ierr) @@ -3445,47 +3490,83 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e memset (&errmsg[len], '\0', errmsg_len - len); } +/** The front-end function for co_reduce functionality. It sets up the MPI_Op + * for use in MPI_*Reduce functions. */ void PREFIX (co_reduce) (gfc_descriptor_t *a, void *(*opr) (void *, void *), int opr_flags, int result_image, int *stat, char *errmsg, int a_len, int errmsg_len) { MPI_Op op; - if(GFC_DESCRIPTOR_TYPE(a) == BT_INTEGER) + /* Integers and logicals can be treated the same. */ + if(GFC_DESCRIPTOR_TYPE(a) == BT_INTEGER + || GFC_DESCRIPTOR_TYPE(a) == BT_LOGICAL) { - foo_int32_t = (typeof(foo_int32_t))opr; - MPI_Op_create(redux_int32, 1, &op); + /* When the ARG_VALUE opr_flag is set, then the user-function expects its + * arguments to be passed by value. */ + if ((opr_flags & GFC_CAF_ARG_VALUE) > 0) + { + int32_t_by_value = (typeof (VALUE_FUNC(int32_t)))opr; + MPI_Op_create(redux_int32_by_value_adapter, 1, &op); + } + else + { + int32_t_by_reference = (typeof (REFERENCE_FUNC(int32_t)))opr; + MPI_Op_create(redux_int32_by_reference_adapter, 1, &op); + } } + /* Treat reals/doubles. */ else if(GFC_DESCRIPTOR_TYPE(a) == BT_REAL) { + /* When the ARG_VALUE opr_flag is set, then the user-function expects its + * arguments to be passed by value. */ if(GFC_DESCRIPTOR_SIZE(a) == sizeof(float)) { - foo_float = (typeof(foo_float))opr; - MPI_Op_create(redux_real32, 1, &op); + if ((opr_flags & GFC_CAF_ARG_VALUE) > 0) + { + float_by_value = (typeof (VALUE_FUNC(float)))opr; + MPI_Op_create(redux_real32_by_value_adapter, 1, &op); + } + else + { + float_by_reference = (typeof (REFERENCE_FUNC(float)))opr; + MPI_Op_create(redux_real32_by_reference_adapter, 1, &op); + } } else - { - foo_double = (typeof(foo_double))opr; - MPI_Op_create(redux_real64, 1, &op); + { + /* When the ARG_VALUE opr_flag is set, then the user-function expects its + * arguments to be passed by value. */ + if ((opr_flags & GFC_CAF_ARG_VALUE) > 0) + { + double_by_value = (typeof (VALUE_FUNC(double)))opr; + MPI_Op_create(redux_real64_by_value_adapter, 1, &op); + } + else + { + double_by_reference = (typeof (REFERENCE_FUNC(double)))opr; + MPI_Op_create(redux_real64_by_reference_adapter, 1, &op); + } } } - else if(GFC_DESCRIPTOR_TYPE(a) == BT_LOGICAL) + else if (GFC_DESCRIPTOR_TYPE(a) == BT_CHARACTER) { - foo_int32_t = (typeof(foo_int32_t))opr; - MPI_Op_create(redux_int32, 1, &op); + /* Char array functions always pass by reference. */ + char_by_reference = (typeof (REFERENCE_FUNC(char)))opr; + MPI_Op_create(redux_char_by_reference_adapter, 1, &op); } else { caf_runtime_error ("Data type not yet supported for co_reduce\n"); } - co_reduce_1 (op, a, result_image, stat, errmsg, 0, errmsg_len); + internal_co_reduce (op, a, result_image, stat, errmsg, a_len, errmsg_len); } void PREFIX (co_sum) (gfc_descriptor_t *a, int result_image, int *stat, char *errmsg, int errmsg_len) { - co_reduce_1 (MPI_SUM, a, result_image, stat, errmsg, 0, errmsg_len); + internal_co_reduce (MPI_SUM, a, result_image, stat, errmsg, 0, errmsg_len); } @@ -3493,7 +3574,7 @@ void PREFIX (co_min) (gfc_descriptor_t *a, int result_image, int *stat, char *errmsg, int src_len, int errmsg_len) { - co_reduce_1 (MPI_MIN, a, result_image, stat, errmsg, src_len, errmsg_len); + internal_co_reduce (MPI_MIN, a, result_image, stat, errmsg, src_len, errmsg_len); } @@ -3501,7 +3582,7 @@ void PREFIX (co_max) (gfc_descriptor_t *a, int result_image, int *stat, char *errmsg, int src_len, int errmsg_len) { - co_reduce_1 (MPI_MAX, a, result_image, stat, errmsg, src_len, errmsg_len); + internal_co_reduce (MPI_MAX, a, result_image, stat, errmsg, src_len, errmsg_len); } diff --git a/src/tests/regression/reported/CMakeLists.txt b/src/tests/regression/reported/CMakeLists.txt index a454a10a4..77972359f 100644 --- a/src/tests/regression/reported/CMakeLists.txt +++ b/src/tests/regression/reported/CMakeLists.txt @@ -1,6 +1,12 @@ add_executable(co_reduce-factorial issue-172-wrong-co_reduce.f90) target_link_libraries(co_reduce-factorial OpenCoarrays) +add_executable(co_reduce-factorial-int8 issue-172-wrong-co_reduce-int8.f90) +target_link_libraries(co_reduce-factorial-int8 OpenCoarrays) + +add_executable(co_reduce-factorial-int64 issue-172-wrong-co_reduce-int64.f90) +target_link_libraries(co_reduce-factorial-int64 OpenCoarrays) + add_executable(source-alloc-sync issue-243-source-allocation-no-sync.f90) target_link_libraries(source-alloc-sync OpenCoarrays) diff --git a/src/tests/regression/reported/issue-172-wrong-co_reduce-int64.f90 b/src/tests/regression/reported/issue-172-wrong-co_reduce-int64.f90 new file mode 100644 index 000000000..30f36aa4f --- /dev/null +++ b/src/tests/regression/reported/issue-172-wrong-co_reduce-int64.f90 @@ -0,0 +1,65 @@ +program co_reduce_factorial_int64 + !! author: Daniel Topa & Izaak Beekman + !! category: regression + !! + !! [issue #172](https://github.com/sourceryinstitute/opencoarrays/issues/172) + !! wherein co-reduce gets junk in the first image when binary + !! operator's (pure function) arguments have `value` attribute + !! instead of `intent(in)` + + implicit none + integer(kind=8) :: value[ * ] !! Each image stores their image number here + integer :: k + integer(kind=8) :: np + value = this_image ( ) + np = num_images ( ) + call co_reduce ( value, result_image = 1, operator = myProd ) + !! value[k /= 1] undefined, value[ k == 1 ] should equal $n!$ where $n$ is `num_images()` + if ( this_image ( ) == 1 ) then + write ( * , '( "Number of images = ", g0 )' ) num_images ( ) + do k = 1, num_images ( ) + write ( * , '( 2( a, i0 ) )' ) 'value [ ', k, ' ] is ', value [ k ] + write ( * , '(a)' ) 'since RESULT_IMAGE is present, value on other images is undefined by the standard' + end do + write ( * , '( "Product value = ", g0 )' ) value !! should print num_images() factorial + write ( * , 100 ) + if ( value == factorial( np ) ) then + write ( * , '(a)' ) 'Test passed.' + else + write ( * , '(a, I0)') 'Answer should have been num_images()! = ', factorial( np ) + error stop 'Wrong answer for n! using co_reduce' + end if + end if +100 format ( "Expected value = num_images()!", /, " 2! = 2, 3! = 6, 4! = 24, ..." ) + +contains + + pure function myProd ( a, b ) result ( rslt ) + !! Product function to be used in `co_reduce` reduction for + !! computing factorials. When `value` attribute is changed to + !! `intent(in)` tests pass, and expected behavior is observed. + integer(kind=8), value :: a, b + !! multiply two inputs together. If we change `value` to + !! `intent(in)` the test passes and the issue goes away and + !! according to C1276 of F2008: + !! + !! > C1276 The specification-part of a pure function subprogram + !! > shall specify that all its nonpointer dummy data objects have + !! > the INTENT (IN) or the VALUE attribute. + !! + !! Thanks to @LadaF for pointing this out. + integer(kind=8) :: rslt !! product of a*b + rslt = a * b + end function + + pure function factorial ( n ) result ( rslt ) + !! Compute $n!$ + integer(kind=8), intent(in) :: n + integer(kind=8) :: rslt + integer :: i + rslt = 1 + do i = 1, n + rslt = rslt*i + end do + end function +end program diff --git a/src/tests/regression/reported/issue-172-wrong-co_reduce-int8.f90 b/src/tests/regression/reported/issue-172-wrong-co_reduce-int8.f90 new file mode 100644 index 000000000..6599f46c6 --- /dev/null +++ b/src/tests/regression/reported/issue-172-wrong-co_reduce-int8.f90 @@ -0,0 +1,65 @@ +program co_reduce_factorial_int8 + !! author: Daniel Topa & Izaak Beekman + !! category: regression + !! + !! [issue #172](https://github.com/sourceryinstitute/opencoarrays/issues/172) + !! wherein co-reduce gets junk in the first image when binary + !! operator's (pure function) arguments have `value` attribute + !! instead of `intent(in)` + + implicit none + integer(kind=1) :: value[ * ] !! Each image stores their image number here + integer :: k + integer(kind=1) :: np + np = num_images ( ) + value = this_image ( ) + call co_reduce ( value, result_image = 1, operator = myProd ) + !! value[k /= 1] undefined, value[ k == 1 ] should equal $n!$ where $n$ is `num_images()` + if ( this_image ( ) == 1 ) then + write ( * , '( "Number of images = ", g0 )' ) num_images ( ) + do k = 1, num_images ( ) + write ( * , '( 2( a, i0 ) )' ) 'value [ ', k, ' ] is ', value [ k ] + write ( * , '(a)' ) 'since RESULT_IMAGE is present, value on other images is undefined by the standard' + end do + write ( * , '( "Product value = ", g0 )' ) value !! should print num_images() factorial + write ( * , 100 ) + if ( value == factorial( np ) ) then + write ( * , '(a)' ) 'Test passed.' + else + write ( * , '(a, I0)') 'Answer should have been num_images()! = ', factorial( np ) + error stop 'Wrong answer for n! using co_reduce' + end if + end if +100 format ( "Expected value = num_images()!", /, " 2! = 2, 3! = 6, 4! = 24, ..." ) + +contains + + pure function myProd ( a, b ) result ( rslt ) + !! Product function to be used in `co_reduce` reduction for + !! computing factorials. When `value` attribute is changed to + !! `intent(in)` tests pass, and expected behavior is observed. + integer(kind=1), value :: a, b + !! multiply two inputs together. If we change `value` to + !! `intent(in)` the test passes and the issue goes away and + !! according to C1276 of F2008: + !! + !! > C1276 The specification-part of a pure function subprogram + !! > shall specify that all its nonpointer dummy data objects have + !! > the INTENT (IN) or the VALUE attribute. + !! + !! Thanks to @LadaF for pointing this out. + integer(kind=1) :: rslt !! product of a*b + rslt = a * b + end function + + pure function factorial ( n ) result ( rslt ) + !! Compute $n!$ + integer(kind=1), intent(in) :: n + integer(kind=1) :: rslt + integer :: i + rslt = 1 + do i = 1, n + rslt = rslt*i + end do + end function +end program diff --git a/src/tests/unit/collectives/CMakeLists.txt b/src/tests/unit/collectives/CMakeLists.txt index 568452dda..d565cf69a 100644 --- a/src/tests/unit/collectives/CMakeLists.txt +++ b/src/tests/unit/collectives/CMakeLists.txt @@ -15,3 +15,6 @@ target_link_libraries(co_reduce_test OpenCoarrays) add_executable(co_reduce_res_im co_reduce_res_im.f90) target_link_libraries(co_reduce_res_im OpenCoarrays) + +add_executable(co_reduce_string co_reduce_string.f90) +target_link_libraries(co_reduce_string OpenCoarrays) diff --git a/src/tests/unit/collectives/co_reduce_string.f90 b/src/tests/unit/collectives/co_reduce_string.f90 new file mode 100644 index 000000000..c3d0b9f26 --- /dev/null +++ b/src/tests/unit/collectives/co_reduce_string.f90 @@ -0,0 +1,78 @@ +! Implement a usecase for co_reduce on char arrays. +! +! Copyright (c) 2012-2017, Sourcery, Inc. +! All rights reserved. +! +! Unit tests for co_min: verify parallel, collective minimum +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! * Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! * Neither the name of Sourcery, Inc., nor the +! names of any other contributors may be used to endorse or promote products +! derived from this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +! DISCLAIMED. IN NO EVENT SHALL SOURCERY, INC., BE LIABLE +! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +! ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +program co_reduce_strings + + implicit none + + integer, parameter :: numstrings = 10, strlen = 6 + character(len=strlen), dimension(:), allocatable :: strarr[:] + character(len=strlen) :: expect + integer :: i + + ! Construct the strings by postfixing foo by a number. + associate (me => this_image()) + allocate(strarr(numstrings)[*]) + do i = 1, numstrings + write(strarr(i), "('foo'I02)") i * me + end do + ! Collectively reduce the maximum string. + call co_reduce(strarr, strmax) + end associate + + ! No sync should be needed here, because the collective (reduce_all) + ! implicitly synchronizes. + associate (np => num_images()) + do i = 1, np + write (expect, "('foo'I02)") i * np + if (strarr(i) /= expect) then + ! On errror print what we got and what we expected. + print *, "Got: ", strarr(i), ", expected: ", expect + error stop "Didn't get expected string." + end if + end do + end associate +contains + + !! Compare two strings and return the maximum one. In a co_reduce no deferred- + !! length strings are allowed, therefore fixed length had to be used. + !! For identical strings the LHS is returned. + pure function strmax(lhs, rhs) result(maxstr) bind(C,name="strmax") + character(len=strlen), intent(in) :: lhs,rhs + character(len=strlen) :: maxstr + + if (lhs > rhs) then + maxstr = lhs + else + maxstr = rhs + end if + end function + +end program co_reduce_strings + From 973cacf0c68df405a16409227c9dc41b705de6de Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Wed, 8 Feb 2017 18:30:09 +0100 Subject: [PATCH 2/2] Improved cleanup of co_broadcast. Fixed co_reduce_string testcase. --- src/mpi/mpi_caf.c | 7 ++++++- src/tests/unit/collectives/co_reduce_string.f90 | 2 ++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/src/mpi/mpi_caf.c b/src/mpi/mpi_caf.c index 11edd4d52..a0f496fae 100644 --- a/src/mpi/mpi_caf.c +++ b/src/mpi/mpi_caf.c @@ -3436,7 +3436,7 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e if (ierr) goto error; - return; + goto co_broadcast_exit; } else if (datatype == MPI_CHARACTER) /* rank !=0 */ { @@ -3467,6 +3467,11 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e goto error; } +co_broadcast_exit: + if (stat) + *stat = 0; + if (GFC_DESCRIPTOR_TYPE(a) == BT_CHARACTER) + MPI_Type_free(&datatype); return; error: diff --git a/src/tests/unit/collectives/co_reduce_string.f90 b/src/tests/unit/collectives/co_reduce_string.f90 index c3d0b9f26..ad094f92a 100644 --- a/src/tests/unit/collectives/co_reduce_string.f90 +++ b/src/tests/unit/collectives/co_reduce_string.f90 @@ -58,6 +58,8 @@ program co_reduce_strings end if end do end associate + sync all + if (this_image() == 1) print *, "Test passed." contains !! Compare two strings and return the maximum one. In a co_reduce no deferred-