check.c (check_co_collective): Renamed from
2014-09-25 Tobias Burnus <burnus@net-b.de>
gcc/fortran
* 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.
gcc/testsuite/
* 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.
libgfortran/
* caf/libcaf.h (_gfortran_caf_co_broadcast): New prototype.
* caf/single.c (_gfortran_caf_co_broadcast): New.
From-SVN: r215579
This commit is contained in:
Tobias Burnus
Tobias Burnus
parent
2bde8cac37
commit
a16ee37946
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
|
|
@ -1483,6 +1484,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);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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 *);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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" } }
|
||||
|
|
@ -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" } }
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -210,6 +210,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)),
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue