diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 19 | ||||
| -rw-r--r-- | gcc/fortran/check.c | 82 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 18 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 3 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.texi | 60 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 37 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 1 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray/collectives_3.f90 | 136 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_collectives_10.f90 | 11 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_collectives_11.f90 | 15 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 | 26 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 | 62 | ||||
| -rw-r--r-- | libgfortran/ChangeLog | 5 | ||||
| -rw-r--r-- | libgfortran/caf/libcaf.h | 10 | ||||
| -rw-r--r-- | libgfortran/caf/single.c | 14 |
18 files changed, 479 insertions, 36 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 214e101..8a781ad 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,22 @@ +2014-09-25 Tobias Burnus <burnus@net-b.de> + + * check.c (check_co_collective): Renamed from check_co_minmaxsum, + handle co_reduce. + (gfc_check_co_minmax, gfc_check_co_sum): Update call. + (gfc_check_co_broadcast, gfc_check_co_reduce): New. + * gfortran.h (gfc_isym_id): Add GFC_ISYM_CO_BROADCAST and + GFC_ISYM_CO_REDUCE. + * intrinsic.c (add_subroutines): Add co_reduce and co_broadcast. + * intrinsic.h (gfc_check_co_broadcast, gfc_check_co_reduce): Add + proto types. + * intrinsic.texi (CO_BROADCAST): Add. + * trans.h (gfor_fndecl_co_broadcast): New. + * trans-decl.c (gfor_fndecl_co_broadcast): Ditto. + (gfc_build_builtin_function_decls): Add decl for it, + * trans-intrinsic.c (conv_co_collective): Renamed from + conv_co_minmaxsum. Handle co_reduce. + (gfc_conv_intrinsic_subroutine): Handle co_reduce. + 2014-09-23 Jakub Jelinek <jakub@redhat.com> PR fortran/63331 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 531fe86..0a08c73 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1414,8 +1414,8 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) static bool -check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, - gfc_expr *errmsg) +check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat, + gfc_expr *errmsg, bool co_reduce) { if (!variable_check (a, 0, false)) return false; @@ -1424,6 +1424,7 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, "INTENT(INOUT)")) return false; + /* Fortran 2008, 12.5.2.4, paragraph 18. */ if (gfc_has_vector_subscript (a)) { gfc_error ("Argument 'A' with INTENT(INOUT) at %L of the intrinsic " @@ -1432,21 +1433,21 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, return false; } - if (result_image != NULL) + if (image_idx != NULL) { - if (!type_check (result_image, 1, BT_INTEGER)) + if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER)) return false; - if (!scalar_check (result_image, 1)) + if (!scalar_check (image_idx, co_reduce ? 2 : 1)) return false; } if (stat != NULL) { - if (!type_check (stat, 2, BT_INTEGER)) + if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER)) return false; - if (!scalar_check (stat, 2)) + if (!scalar_check (stat, co_reduce ? 3 : 2)) return false; - if (!variable_check (stat, 2, false)) + if (!variable_check (stat, co_reduce ? 3 : 2, false)) return false; if (stat->ts.kind != 4) { @@ -1458,11 +1459,11 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, if (errmsg != NULL) { - if (!type_check (errmsg, 3, BT_CHARACTER)) + if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER)) return false; - if (!scalar_check (errmsg, 3)) + if (!scalar_check (errmsg, co_reduce ? 4 : 3)) return false; - if (!variable_check (errmsg, 3, false)) + if (!variable_check (errmsg, co_reduce ? 4 : 3, false)) return false; if (errmsg->ts.kind != 1) { @@ -1484,6 +1485,61 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, bool +gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat, + gfc_expr *errmsg) +{ + if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp) + { + gfc_error ("Support for the A argument at %L which is polymorphic A " + "argument or has allocatable components is not yet " + "implemented", &a->where); + return false; + } + return check_co_collective (a, source_image, stat, errmsg, false); +} + + +bool +gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image, + gfc_expr *stat, gfc_expr *errmsg) +{ + symbol_attribute attr; + + if (a->ts.type == BT_CLASS) + { + gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic", + &a->where); + return false; + } + + if (gfc_expr_attr (a).alloc_comp) + { + gfc_error ("Support for the A argument at %L with allocatable components" + " is not yet implemented", &a->where); + return false; + } + + attr = gfc_expr_attr (op); + if (!attr.pure || !attr.function) + { + gfc_error ("OPERATOR argument at %L must be a PURE function", + &op->where); + return false; + } + + if (!check_co_collective (a, result_image, stat, errmsg, true)) + return false; + + /* FIXME: After J3/WG5 has decided what they actually exactly want, more + checks such as same-argument checks have to be added, implemented and + intrinsic.texi upated. */ + + gfc_error("CO_REDUCE at %L is not yet implemented", &a->where); + return false; +} + + +bool gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, gfc_expr *errmsg) { @@ -1496,7 +1552,7 @@ gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, &a->where); return false; } - return check_co_minmaxsum (a, result_image, stat, errmsg); + return check_co_collective (a, result_image, stat, errmsg, false); } @@ -1506,7 +1562,7 @@ gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat, { if (!numeric_check (a, 0)) return false; - return check_co_minmaxsum (a, result_image, stat, errmsg); + return check_co_collective (a, result_image, stat, errmsg, false); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b208a89..f1c78cc 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -369,8 +369,10 @@ enum gfc_isym_id GFC_ISYM_CHDIR, GFC_ISYM_CHMOD, GFC_ISYM_CMPLX, + GFC_ISYM_CO_BROADCAST, GFC_ISYM_CO_MAX, GFC_ISYM_CO_MIN, + GFC_ISYM_CO_REDUCE, GFC_ISYM_CO_SUM, GFC_ISYM_COMMAND_ARGUMENT_COUNT, GFC_ISYM_COMPILER_OPTIONS, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 1ad1e69..9bc9b3c 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3294,6 +3294,14 @@ add_subroutines (void) make_from_module(); /* Coarray collectives. */ + add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_co_broadcast, NULL, NULL, + a, BT_REAL, dr, REQUIRED, INTENT_INOUT, + "source_image", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT); + add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2008_TS, gfc_check_co_minmax, NULL, NULL, @@ -3318,6 +3326,16 @@ add_subroutines (void) stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT); + add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_co_reduce, NULL, NULL, + a, BT_REAL, dr, REQUIRED, INTENT_INOUT, + "operator", BT_INTEGER, di, REQUIRED, INTENT_IN, + result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, + errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT); + + /* The following subroutine is internally used for coarray libray functions. "make_from_module" makes it inaccessible for external users. */ add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 9437171..a6342e7 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -53,8 +53,11 @@ bool gfc_check_chdir (gfc_expr *); bool gfc_check_chmod (gfc_expr *, gfc_expr *); bool gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_complex (gfc_expr *, gfc_expr *); +bool gfc_check_co_broadcast (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_co_minmax (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_co_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_co_reduce (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *); bool gfc_check_count (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ctime (gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 48713a6..4d884d7 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -95,6 +95,7 @@ Some basic guidelines for editing this document: * @code{CHDIR}: CHDIR, Change working directory * @code{CHMOD}: CHMOD, Change access permissions of files * @code{CMPLX}: CMPLX, Complex conversion function +* @code{CO_BROADCAST}: CO_BROADCAST, Copy a value to all images the current set of images * @code{CO_MAX}: CO_MAX, Maximal value on the current set of images * @code{CO_MIN}: CO_MIN, Minimal value on the current set of images * @code{CO_SUM}: CO_SUM, Sum of values on the current set of images @@ -3291,6 +3292,59 @@ end program test_cmplx +@node CO_BROADCAST +@section @code{CO_BROADCAST} --- Copy a value to all images the current set of images +@fnindex CO_BROADCAST +@cindex Collectives, value broadcasting + +@table @asis +@item @emph{Description}: +@code{CO_BROADCAST} copies the value of argument @var{A} on the image with +image index @code{SOURCE_IMAGE} to all images in the current team. @var{A} +becomes defined as if by intrinsic assignment. If the execution was +successful and @var{STAT} is present, it is assigned the value zero. If the +execution failed, @var{STAT} gets assigned a nonzero value and, if present, +@var{ERRMSG} gets assigned a value describing the occurred error. + +@item @emph{Standard}: +Technical Specification (TS) 18508 or later + +@item @emph{Class}: +Collective subroutine + +@item @emph{Syntax}: +@code{CALL CO_BROADCAST(A, SOURCE_IMAGE [, STAT, ERRMSG])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{A} @tab INTENT(INOUT) argument; shall have the same +dynamic type and type paramters on all images of the current team. If it +is an array, it shall have the same shape on all images. +@item @var{SOURCE_IMAGE} @tab (optional) a scalar integer expression. +It shall have the same the same value on all images and refer to an +image of the current team. +@item @var{STAT} @tab (optional) a scalar integer variable +@item @var{ERRMSG} @tab (optional) a scalar character variable +@end multitable + +@item @emph{Example}: +@smallexample +program test + integer :: val(3) + if (this_image() == 1) then + val = [1, 5, 3] + end if + call co_broadcast (val, source_image=1) + print *, this_image, ":", val +end program test +@end smallexample + +@item @emph{See also}: +@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_SUM} +@end table + + + @node CO_MAX @section @code{CO_MAX} --- Maximal value on the current set of images @fnindex CO_MAX @@ -3340,7 +3394,7 @@ end program test @end smallexample @item @emph{See also}: -@ref{CO_MIN}, @ref{CO_SUM} +@ref{CO_MIN}, @ref{CO_SUM}, @ref{CO_BROADCAST} @end table @@ -3394,7 +3448,7 @@ end program test @end smallexample @item @emph{See also}: -@ref{CO_MAX}, @ref{CO_SUM} +@ref{CO_MAX}, @ref{CO_SUM}, @ref{CO_BROADCAST} @end table @@ -3448,7 +3502,7 @@ end program test @end smallexample @item @emph{See also}: -@ref{CO_MAX}, @ref{CO_MIN} +@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_BROADCAST} @end table diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 10dfc9f..7184504 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -145,6 +145,7 @@ tree gfor_fndecl_caf_atomic_cas; tree gfor_fndecl_caf_atomic_op; tree gfor_fndecl_caf_lock; tree gfor_fndecl_caf_unlock; +tree gfor_fndecl_co_broadcast; tree gfor_fndecl_co_max; tree gfor_fndecl_co_min; tree gfor_fndecl_co_sum; @@ -3424,6 +3425,11 @@ gfc_build_builtin_function_decls (void) void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, pint_type, pchar_type_node, integer_type_node); + gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("caf_co_broadcast")), "W.WW", + void_type_node, 5, pvoid_type_node, integer_type_node, + pint_type, pchar_type_node, integer_type_node); + gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_co_max")), "W.WW", void_type_node, 6, pvoid_type_node, integer_type_node, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 5507946..0a3315d 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8173,7 +8173,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, static tree -conv_co_minmaxsum (gfc_code *code) +conv_co_collective (gfc_code *code) { gfc_se argse; stmtblock_t block, post_block; @@ -8263,16 +8263,26 @@ conv_co_minmaxsum (gfc_code *code) } /* Generate the function call. */ - if (code->resolved_isym->id == GFC_ISYM_CO_MAX) - fndecl = gfor_fndecl_co_max; - else if (code->resolved_isym->id == GFC_ISYM_CO_MIN) - fndecl = gfor_fndecl_co_min; - else if (code->resolved_isym->id == GFC_ISYM_CO_SUM) - fndecl = gfor_fndecl_co_sum; - else - gcc_unreachable (); + switch (code->resolved_isym->id) + { + case GFC_ISYM_CO_BROADCAST: + fndecl = gfor_fndecl_co_broadcast; + break; + case GFC_ISYM_CO_MAX: + fndecl = gfor_fndecl_co_max; + break; + case GFC_ISYM_CO_MIN: + fndecl = gfor_fndecl_co_min; + break; + case GFC_ISYM_CO_SUM: + fndecl = gfor_fndecl_co_sum; + break; + default: + gcc_unreachable (); + } - if (code->resolved_isym->id == GFC_ISYM_CO_SUM) + if (code->resolved_isym->id == GFC_ISYM_CO_SUM + || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST) fndecl = build_call_expr_loc (input_location, fndecl, 5, array, image_index, stat, errmsg, errmsg_len); else @@ -8281,7 +8291,6 @@ conv_co_minmaxsum (gfc_code *code) gfc_add_expr_to_block (&block, fndecl); gfc_add_block_to_block (&block, &post_block); - /* Add CALL to CO_SUM/MIN/MAX: array descriptor, vector descriptor, stat, errmsg, strlen, errmsglen */ return gfc_finish_block (&block); } @@ -8992,10 +9001,14 @@ gfc_conv_intrinsic_subroutine (gfc_code *code) res = conv_caf_send (code); break; + case GFC_ISYM_CO_REDUCE: + gcc_unreachable (); + break; + case GFC_ISYM_CO_BROADCAST: case GFC_ISYM_CO_MIN: case GFC_ISYM_CO_MAX: case GFC_ISYM_CO_SUM: - res = conv_co_minmaxsum (code); + res = conv_co_collective (code); break; case GFC_ISYM_SYSTEM_CLOCK: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 70c794b..03136e6 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -727,6 +727,7 @@ extern GTY(()) tree gfor_fndecl_caf_atomic_cas; extern GTY(()) tree gfor_fndecl_caf_atomic_op; extern GTY(()) tree gfor_fndecl_caf_lock; extern GTY(()) tree gfor_fndecl_caf_unlock; +extern GTY(()) tree gfor_fndecl_co_broadcast; extern GTY(()) tree gfor_fndecl_co_max; extern GTY(()) tree gfor_fndecl_co_min; extern GTY(()) tree gfor_fndecl_co_sum; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0c3e082..ef8faa3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2014-09-25 Tobias Burnus <burnus@net-b.de> + + * gfortran.dg/coarray/collectives_3.f90: New. + * gfortran.dg/coarray_collectives_9.f90: New. + * gfortran.dg/coarray_collectives_10.f90: New. + * gfortran.dg/coarray_collectives_11.f90: New. + * gfortran.dg/coarray_collectives_12.f90: New. + 2014-09-24 Bill Schmidt <wschmidt@linux.vnet.ibm.com> * gcc.target/powerpc/swaps-p8-17.c: New test. diff --git a/gcc/testsuite/gfortran.dg/coarray/collectives_3.f90 b/gcc/testsuite/gfortran.dg/coarray/collectives_3.f90 new file mode 100644 index 0000000..123a857 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/collectives_3.f90 @@ -0,0 +1,136 @@ +! { dg-do run } +! +! CO_BROADCAST +! +program test + implicit none + intrinsic co_broadcast + + type t + integer :: i + character(len=1) :: c + real(8) :: x(3), y(3) + end type t + + integer :: i, j(10), stat + complex :: a(5,5) + character(kind=1, len=5) :: str1, errstr + character(kind=4, len=8) :: str2(2) + type(t) :: dt(4) + + i = 1 + j = 55 + a = 99.0 + str1 = 1_"XXXXX" + str2 = 4_"YYYYYYYY" + dt = t(1, 'C', [1.,2.,3.], [3,3,3]) + errstr = "ZZZZZ" + + if (this_image() == num_images()) then + i = 2 + j = 66 + a = -99.0 + str1 = 1_"abcd" + str2 = 4_"12 3 4 5" + dt = t(-1, 'a', [3.,1.,8.], [99,24,5]) + end if + sync all + + call co_broadcast(i, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) call abort() + if (errstr /= "ZZZZZ") call abort() + if (i /= 2) call abort() + + call co_broadcast(j, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) call abort() + if (errstr /= "ZZZZZ") call abort() + if (any (j /= 66)) call abort + + call co_broadcast(a, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) call abort() + if (errstr /= "ZZZZZ") call abort() + if (any (a /= -99.0)) call abort + + call co_broadcast(str1, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) call abort() + if (errstr /= "ZZZZZ") call abort() + if (str1 /= "abcd") call abort() + + call co_broadcast(str2, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) call abort() + if (errstr /= "ZZZZZ") call abort() + if (any (str2 /= 4_"12 3 4 5")) call abort + + call co_broadcast(dt, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) call abort() + if (errstr /= "ZZZZZ") call abort() + if (any (dt(:)%i /= -1)) call abort() + if (any (dt(:)%c /= 'a')) call abort() + if (any (dt(:)%x(1) /= 3.)) call abort() + if (any (dt(:)%x(2) /= 1.)) call abort() + if (any (dt(:)%x(3) /= 8.)) call abort() + if (any (dt(:)%y(1) /= 99.)) call abort() + if (any (dt(:)%y(2) /= 24.)) call abort() + if (any (dt(:)%y(3) /= 5.)) call abort() + + sync all + dt = t(1, 'C', [1.,2.,3.], [3,3,3]) + sync all + if (this_image() == num_images()) then + str2 = 4_"001122" + dt(2:4) = t(-2, 'i', [9.,2.,3.], [4,44,321]) + end if + + call co_broadcast(str2(::2), source_image=num_images(), stat=stat, & + errmsg=errstr) + if (stat /= 0) call abort() + if (errstr /= "ZZZZZ") call abort() + if (str2(1) /= 4_"001122") call abort() + if (this_image() == num_images()) then + if (str2(1) /= 4_"001122") call abort() + else + if (str2(2) /= 4_"12 3 4 5") call abort() + end if + + call co_broadcast(dt(2::2), source_image=num_images(), stat=stat, & + errmsg=errstr) + if (stat /= 0) call abort() + if (errstr /= "ZZZZZ") call abort() + if (this_image() == num_images()) then + if (any (dt(1:1)%i /= 1)) call abort() + if (any (dt(1:1)%c /= 'C')) call abort() + if (any (dt(1:1)%x(1) /= 1.)) call abort() + if (any (dt(1:1)%x(2) /= 2.)) call abort() + if (any (dt(1:1)%x(3) /= 3.)) call abort() + if (any (dt(1:1)%y(1) /= 3.)) call abort() + if (any (dt(1:1)%y(2) /= 3.)) call abort() + if (any (dt(1:1)%y(3) /= 3.)) call abort() + + if (any (dt(2:)%i /= -2)) call abort() + if (any (dt(2:)%c /= 'i')) call abort() + if (any (dt(2:)%x(1) /= 9.)) call abort() + if (any (dt(2:)%x(2) /= 2.)) call abort() + if (any (dt(2:)%x(3) /= 3.)) call abort() + if (any (dt(2:)%y(1) /= 4.)) call abort() + if (any (dt(2:)%y(2) /= 44.)) call abort() + if (any (dt(2:)%y(3) /= 321.)) call abort() + else + if (any (dt(1::2)%i /= 1)) call abort() + if (any (dt(1::2)%c /= 'C')) call abort() + if (any (dt(1::2)%x(1) /= 1.)) call abort() + if (any (dt(1::2)%x(2) /= 2.)) call abort() + if (any (dt(1::2)%x(3) /= 3.)) call abort() + if (any (dt(1::2)%y(1) /= 3.)) call abort() + if (any (dt(1::2)%y(2) /= 3.)) call abort() + if (any (dt(1::2)%y(3) /= 3.)) call abort() + + if (any (dt(2::2)%i /= -2)) call abort() + if (any (dt(2::2)%c /= 'i')) call abort() + if (any (dt(2::2)%x(1) /= 9.)) call abort() + if (any (dt(2::2)%x(2) /= 2.)) call abort() + if (any (dt(2::2)%x(3) /= 3.)) call abort() + if (any (dt(2::2)%y(1) /= 4.)) call abort() + if (any (dt(2::2)%y(2) /= 44.)) call abort() + if (any (dt(2::2)%y(3) /= 321.)) call abort() + endif +end program test diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_10.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_10.f90 new file mode 100644 index 0000000..906785c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_10.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +! +! CO_REDUCE/CO_BROADCAST +! +program test + implicit none + intrinsic co_reduce ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." } + intrinsic co_broadcast ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." } +end program test diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_11.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_11.f90 new file mode 100644 index 0000000..b10ba62 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_11.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=single" } +! +! CO_BROADCAST +! +program test + implicit none + intrinsic co_reduce + integer :: stat1 + real :: val + call co_broadcast(val, source_image=1, stat=stat1) +end program test + +! { dg-final { scan-tree-dump-times "stat1 = 0;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 new file mode 100644 index 0000000..e3ba9d8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + integer :: stat1, stat2, stat3 + character(len=6) :: errmesg1 + character(len=7) :: errmesg2 + character(len=8) :: errmesg3 + real :: val1 + complex, allocatable :: val2(:) + character(len=99) :: val3 + integer :: res + + call co_broadcast(val1, source_image=num_images(), stat=stat1, errmsg=errmesg1) + call co_broadcast(val2, source_image=4, stat=stat2, errmsg=errmesg2) + call co_broadcast(val3, source_image=res,stat=stat3, errmsg=errmesg3) +end program test + +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&val2, 4, &stat2, errmesg2, 7\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., res, &stat3, errmesg3, 8\\);" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 new file mode 100644 index 0000000..90c09c5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! +! CO_BROADCAST/CO_REDUCE +! +program test + implicit none + intrinsic co_broadcast + intrinsic co_reduce + integer :: val, i + integer :: vec(3), idx(3) + character(len=30) :: errmsg + integer(8) :: i8 + character(len=19, kind=4) :: msg4 + + interface + pure function red_f(a, b) + integer :: a, b, red_f + intent(in) :: a, b + end function red_f + impure function red_f2(a, b) + integer :: a, b, red_f + intent(in) :: a, b + end function red_f2 + end interface + + call co_broadcast("abc") ! { dg-error "Missing actual argument 'source_image' in call to 'co_broadcast'" } + call co_reduce("abc") ! { dg-error "Missing actual argument 'operator' in call to 'co_reduce'" } + call co_broadcast(1, source_image=1) ! { dg-error "'a' argument of 'co_broadcast' intrinsic at .1. must be a variable" } + call co_reduce(a=1, operator=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" } + call co_reduce(a=val, operator=red_f2) ! { dg-error "OPERATOR argument at (1) must be a PURE function" } + + call co_broadcast(val, source_image=[1,2]) ! { dg-error "must be a scalar" } + call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" } + call co_broadcast(val, 1, stat=[1,2]) ! { dg-error "must be a scalar" } + call co_broadcast(val, 1, stat=1.0) ! { dg-error "must be INTEGER" } + call co_broadcast(val, 1, stat=1) ! { dg-error "must be a variable" } + call co_broadcast(val, stat=i, source_image=1) ! OK + call co_broadcast(val, stat=i, errmsg=errmsg, source_image=1) ! OK + call co_broadcast(val, stat=i, errmsg=[errmsg], source_image=1) ! { dg-error "must be a scalar" } + call co_broadcast(val, stat=i, errmsg=5, source_image=1) ! { dg-error "must be CHARACTER" } + call co_broadcast(val, 1, errmsg="abc") ! { dg-error "must be a variable" } + call co_broadcast(val, 1, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" } + call co_broadcast(val, 1, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" } + + call co_reduce(val, red_f, result_image=[1,2]) ! { dg-error "must be a scalar" } + call co_reduce(val, red_f, result_image=1.0) ! { dg-error "must be INTEGER" } + call co_reduce(val, red_f, stat=[1,2]) ! { dg-error "must be a scalar" } + call co_reduce(val, red_f, stat=1.0) ! { dg-error "must be INTEGER" } + call co_reduce(val, red_f, stat=1) ! { dg-error "must be a variable" } + call co_reduce(val, red_f, stat=i, result_image=1) ! OK + call co_reduce(val, red_f, stat=i, errmsg=errmsg, result_image=1) ! OK + call co_reduce(val, red_f, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" } + call co_reduce(val, red_f, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" } + call co_reduce(val, red_f, errmsg="abc") ! { dg-error "must be a variable" } + call co_reduce(val, red_f, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" } + call co_reduce(val, red_f, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" } + + call co_broadcasr(vec(idx), 1) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_sum shall not have a vector subscript" } + call co_reduce(vec([1,3,2]), red_f) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_min shall not have a vector subscript" } +end program test diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index e27c2a7..71c15a9 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,8 @@ +2014-09-25 Tobias Burnus <burnus@net-b.de> + + * caf/libcaf.h (_gfortran_caf_co_broadcast): New prototype. + * caf/single.c (_gfortran_caf_co_broadcast): New. + 2014-09-18 Janne Blomqvist <jb@gcc.gnu.org> PR libfortran/62768 diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 0f3398a..ffd0980 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -106,12 +106,10 @@ void _gfortran_caf_error_stop_str (const char *, int32_t) __attribute__ ((noreturn)); void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn)); -void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, - char *, int); -void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *, - int, int); -void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, - int, int); +void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, int *, char *, int); +void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, char *, int); +void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *, int, int); +void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, int, int); void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *, caf_vector_t *, gfc_descriptor_t *, int, int, bool); diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index 773941b..e264fc5 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -211,6 +211,16 @@ _gfortran_caf_error_stop (int32_t error) void +_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)), + int source_image __attribute__ ((unused)), + int *stat, char *errmsg __attribute__ ((unused)), + int errmsg_len __attribute__ ((unused))) +{ + if (stat) + *stat = 0; +} + +void _gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)), int result_image __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), @@ -224,7 +234,7 @@ void _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)), int result_image __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), - int src_len __attribute__ ((unused)), + int a_len __attribute__ ((unused)), int errmsg_len __attribute__ ((unused))) { if (stat) @@ -235,7 +245,7 @@ void _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)), int result_image __attribute__ ((unused)), int *stat, char *errmsg __attribute__ ((unused)), - int src_len __attribute__ ((unused)), + int a_len __attribute__ ((unused)), int errmsg_len __attribute__ ((unused))) { if (stat) |