gcc/fortran/ 2014-07-10 Tobias Burnus * check.c (gfc_check_atomic): Update for STAT=. (gfc_check_atomic_def, gfc_check_atomic_ref): Update call. (gfc_check_atomic_op, gfc_check_atomic_cas, gfc_check_atomic_fetch_op): New. * gfortran.h (gfc_isym_id): GFC_ISYM_ATOMIC_CAS, GFC_ISYM_ATOMIC_ADD, GFC_ISYM_ATOMIC_AND, GFC_ISYM_ATOMIC_OR, GFC_ISYM_ATOMIC_XOR, GFC_ISYM_ATOMIC_FETCH_ADD, GFC_ISYM_ATOMIC_FETCH_AND, GFC_ISYM_ATOMIC_FETCH_OR and GFC_ISYM_ATOMIC_FETCH_XOR. * intrinsic.c (add_subroutines): Handle them. * intrinsic.texi: Add documentation for them. (ATOMIC_REF, ATOMIC_DEFINE): Add STAT=. (ISO_FORTRAN_ENV): Add STAT_FAILED_IMAGE. * intrinsic.h (gfc_check_atomic_op, gfc_check_atomic_cas, gfc_check_atomic_fetch_op): New prototypes. * libgfortran.h (libgfortran_stat_codes): Add GFC_STAT_FAILED_IMAGE. * iso-fortran-env.def: Add it. * trans-intrinsic.c (conv_intrinsic_atomic_op): Renamed from conv_intrinsic_atomic_ref; handle more atomics. (conv_intrinsic_atomic_def): Handle STAT=. (conv_intrinsic_atomic_cas): New. (gfc_conv_intrinsic_subroutine): Handle new atomics. gcc/testsuite/ 2014-07-10 Tobias Burnus * gfortran.dg/coarray/atomic_2.f90: New. * gfortran.dg/coarray_atomic_1.f90: New. * gfortran.dg/coarray_atomic_2.f90: New. * gfortran.dg/coarray_atomic_3.f90: New. * gfortran.dg/coarray_atomic_4.f90: New. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 10944eb..eff2c4c 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1006,12 +1006,11 @@ gfc_check_atan2 (gfc_expr *y, gfc_expr *x) static bool -gfc_check_atomic (gfc_expr *atom, gfc_expr *value) +gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no, + gfc_expr *stat, int stat_no) { - if (atom->expr_type == EXPR_FUNCTION - && atom->value.function.isym - && atom->value.function.isym->id == GFC_ISYM_CAF_GET) - atom = atom->value.function.actual->expr; + if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no)) + return false; if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind) && !(atom->ts.type == BT_LOGICAL @@ -1032,27 +1031,41 @@ gfc_check_atomic (gfc_expr *atom, gfc_expr *value) if (atom->ts.type != value->ts.type) { - gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall " - "have the same type at %L", gfc_current_intrinsic, - &value->where); + gfc_error ("'%s' argument of '%s' intrinsic at %L shall have the same " + "type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name, + gfc_current_intrinsic, &value->where, + gfc_current_intrinsic_arg[atom_no]->name, &atom->where); return false; } + if (stat != NULL) + { + if (!type_check (stat, stat_no, BT_INTEGER)) + return false; + if (!scalar_check (stat, stat_no)) + return false; + if (!variable_check (stat, stat_no, false)) + return false; + if (!kind_value_check (stat, stat_no, gfc_default_integer_kind)) + return false; + + if (!gfc_notify_std (GFC_STD_F2008_TS, "STAT= argument to %s at %L", + gfc_current_intrinsic, &stat->where)) + return false; + } + return true; } bool -gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value) +gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) { if (atom->expr_type == EXPR_FUNCTION && atom->value.function.isym && atom->value.function.isym->id == GFC_ISYM_CAF_GET) atom = atom->value.function.actual->expr; - if (!scalar_check (atom, 0) || !scalar_check (value, 1)) - return false; - if (!gfc_check_vardef_context (atom, false, false, false, NULL)) { gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " @@ -1060,15 +1073,32 @@ gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value) return false; } - return gfc_check_atomic (atom, value); + return gfc_check_atomic (atom, 0, value, 1, stat, 2); } bool -gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom) +gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat) { - if (!scalar_check (value, 0) || !scalar_check (atom, 1)) - return false; + if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) + { + gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " + "integer of ATOMIC_INT_KIND", &atom->where, + gfc_current_intrinsic); + return false; + } + + return gfc_check_atomic_def (atom, value, stat); +} + + +bool +gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) +{ + if (atom->expr_type == EXPR_FUNCTION + && atom->value.function.isym + && atom->value.function.isym->id == GFC_ISYM_CAF_GET) + atom = atom->value.function.actual->expr; if (!gfc_check_vardef_context (value, false, false, false, NULL)) { @@ -1077,7 +1107,90 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom) return false; } - return gfc_check_atomic (atom, value); + return gfc_check_atomic (atom, 1, value, 0, stat, 2); +} + + +bool +gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare, + gfc_expr *new_val, gfc_expr *stat) +{ + if (atom->expr_type == EXPR_FUNCTION + && atom->value.function.isym + && atom->value.function.isym->id == GFC_ISYM_CAF_GET) + atom = atom->value.function.actual->expr; + + if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4)) + return false; + + if (!scalar_check (old, 1) || !scalar_check (compare, 2)) + return false; + + if (!same_type_check (atom, 0, old, 1)) + return false; + + if (!same_type_check (atom, 0, compare, 2)) + return false; + + if (!gfc_check_vardef_context (atom, false, false, false, NULL)) + { + gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &atom->where); + return false; + } + + if (!gfc_check_vardef_context (old, false, false, false, NULL)) + { + gfc_error ("OLD argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &old->where); + return false; + } + + return true; +} + + +bool +gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old, + gfc_expr *stat) +{ + if (atom->expr_type == EXPR_FUNCTION + && atom->value.function.isym + && atom->value.function.isym->id == GFC_ISYM_CAF_GET) + atom = atom->value.function.actual->expr; + + if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind) + { + gfc_error ("ATOM argument at %L to intrinsic function %s shall be an " + "integer of ATOMIC_INT_KIND", &atom->where, + gfc_current_intrinsic); + return false; + } + + if (!gfc_check_atomic (atom, 0, value, 1, stat, 3)) + return false; + + if (!scalar_check (old, 2)) + return false; + + if (!same_type_check (atom, 0, old, 2)) + return false; + + if (!gfc_check_vardef_context (atom, false, false, false, NULL)) + { + gfc_error ("ATOM argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &atom->where); + return false; + } + + if (!gfc_check_vardef_context (old, false, false, false, NULL)) + { + gfc_error ("OLD argument of the %s intrinsic function at %L shall be " + "definable", gfc_current_intrinsic, &old->where); + return false; + } + + return true; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 3481319..f1750da 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -332,8 +332,17 @@ enum gfc_isym_id GFC_ISYM_ATAN, GFC_ISYM_ATAN2, GFC_ISYM_ATANH, + GFC_ISYM_ATOMIC_ADD, + GFC_ISYM_ATOMIC_AND, + GFC_ISYM_ATOMIC_CAS, GFC_ISYM_ATOMIC_DEF, + GFC_ISYM_ATOMIC_FETCH_ADD, + GFC_ISYM_ATOMIC_FETCH_AND, + GFC_ISYM_ATOMIC_FETCH_OR, + GFC_ISYM_ATOMIC_FETCH_XOR, + GFC_ISYM_ATOMIC_OR, GFC_ISYM_ATOMIC_REF, + GFC_ISYM_ATOMIC_XOR, GFC_ISYM_BGE, GFC_ISYM_BGT, GFC_ISYM_BIT_SIZE, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index bf784b5..d681d70 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -3038,17 +3038,88 @@ add_subroutines (void) make_noreturn(); - add_sym_2s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC, + add_sym_3s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC, BT_UNKNOWN, 0, GFC_STD_F2008, gfc_check_atomic_def, NULL, gfc_resolve_atomic_def, "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "value", BT_INTEGER, di, REQUIRED, INTENT_IN); + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); - add_sym_2s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC, + add_sym_3s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC, BT_UNKNOWN, 0, GFC_STD_F2008, gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref, "value", BT_INTEGER, di, REQUIRED, INTENT_OUT, - "atom", BT_INTEGER, di, REQUIRED, INTENT_IN); + "atom", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_5s ("atomic_cas", GFC_ISYM_ATOMIC_CAS, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_cas, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_INOUT, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "compare", BT_INTEGER, di, REQUIRED, INTENT_IN, + "new", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_add", GFC_ISYM_ATOMIC_ADD, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_and", GFC_ISYM_ATOMIC_AND, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_or", GFC_ISYM_ATOMIC_OR, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_3s ("atomic_xor", GFC_ISYM_ATOMIC_XOR, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("atomic_fetch_add", GFC_ISYM_ATOMIC_FETCH_ADD, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_fetch_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("atomic_fetch_and", GFC_ISYM_ATOMIC_FETCH_AND, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_fetch_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("atomic_fetch_or", GFC_ISYM_ATOMIC_FETCH_OR, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_fetch_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + + add_sym_4s ("atomic_fetch_xor", GFC_ISYM_ATOMIC_FETCH_XOR, CLASS_ATOMIC, + BT_UNKNOWN, 0, GFC_STD_F2008_TS, + gfc_check_atomic_fetch_op, NULL, NULL, + "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, + "value", BT_INTEGER, di, REQUIRED, INTENT_IN, + "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); add_sym_0s ("backtrace", GFC_ISYM_BACKTRACE, GFC_STD_GNU, NULL); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 05cd146..9437171 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -38,8 +38,12 @@ bool gfc_check_allocated (gfc_expr *); bool gfc_check_associated (gfc_expr *, gfc_expr *); bool gfc_check_atan_2 (gfc_expr *, gfc_expr *); bool gfc_check_atan2 (gfc_expr *, gfc_expr *); -bool gfc_check_atomic_def (gfc_expr *, gfc_expr *); -bool gfc_check_atomic_ref (gfc_expr *, gfc_expr *); +bool gfc_check_atomic_cas (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *); +bool gfc_check_atomic_def (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_atomic_fetch_op (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_atomic_op (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_atomic_ref (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_besn (gfc_expr *, gfc_expr *); bool gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 87f6478..2cf6dfe 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -60,8 +60,17 @@ Some basic guidelines for editing this document: * @code{ATAN}: ATAN, Arctangent function * @code{ATAN2}: ATAN2, Arctangent function * @code{ATANH}: ATANH, Inverse hyperbolic tangent function +* @code{ATOMIC_ADD}: ATOMIC_ADD, Atomic ADD operation +* @code{ATOMIC_AND}: ATOMIC_AND, Atomic bitwise AND operation +* @code{ATOMIC_CAS}: ATOMIC_CAS, Atomic compare and swap +* @code{ATOMIC_FETCH_ADD}: ATOMIC_FETCH_ADD, Atomic ADD operation with prior fetch +* @code{ATOMIC_FETCH_AND}: ATOMIC_FETCH_AND, Atomic bitwise AND operation with prior fetch +* @code{ATOMIC_FETCH_OR}: ATOMIC_FETCH_OR, Atomic bitwise OR operation with prior fetch +* @code{ATOMIC_FETCH_XOR}: ATOMIC_FETCH_XOR, Atomic bitwise XOR operation with prior fetch +* @code{ATOMIC_OR}: ATOMIC_OR, Atomic bitwise OR operation * @code{ATOMIC_DEFINE}: ATOMIC_DEFINE, Setting a variable atomically * @code{ATOMIC_REF}: ATOMIC_REF, Obtaining the value of a variable atomically +* @code{ATOMIC_XOR}: ATOMIC_XOR, Atomic bitwise OR operation * @code{BACKTRACE}: BACKTRACE, Show a backtrace * @code{BESSEL_J0}: BESSEL_J0, Bessel function of the first kind of order 0 * @code{BESSEL_J1}: BESSEL_J1, Bessel function of the first kind of order 1 @@ -1554,6 +1563,159 @@ Inverse function: @ref{TANH} +@node ATOMIC_ADD +@section @code{ATOMIC_ADD} --- Atomic ADD operation +@fnindex ATOMIC_ADD +@cindex Atomic subroutine, add + +@table @asis +@item @emph{Description}: +@code{ATOMIC_ADD(ATOM, VALUE)} atomically adds the value of @var{VAR} to the +variable @var{ATOM}. When @var{STAT} is present and the invokation was +successful, it is assigned the value 0. If it is present and the invokation +has failed, it is assigned a positive value; in particular, for a coindexed +@var{ATOM}, if the remote image has stopped, it is assigned the value of +@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has +failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_ADD (ATOM, VALUE [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer +type with @code{ATOMIC_INT_KIND} kind. +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + integer(atomic_int_kind) :: atom[*] + call atomic_add (atom[1], this_image()) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_FETCH_ADD}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_AND}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR} +@end table + + + + +@node ATOMIC_AND +@section @code{ATOMIC_AND} --- Atomic bitwise AND operation +@fnindex ATOMIC_AND +@cindex Atomic subroutine, AND + +@table @asis +@item @emph{Description}: +@code{ATOMIC_AND(ATOM, VALUE)} atomically defines @var{ATOM} with the bitwise +AND between the values of @var{ATOM} and @var{VALUE}. When @var{STAT} is present +and the invokation was successful, it is assigned the value 0. If it is present +and the invokation has failed, it is assigned a positive value; in particular, +for a coindexed @var{ATOM}, if the remote image has stopped, it is assigned the +value of @code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote +image has failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_AND (ATOM, VALUE [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer +type with @code{ATOMIC_INT_KIND} kind. +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + integer(atomic_int_kind) :: atom[*] + call atomic_and (atom[1], int(b'10100011101')) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_FETCH_AND}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_ADD}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR} +@end table + + + +@node ATOMIC_CAS +@section @code{ATOMIC_CAS} --- Atomic compare and swap +@fnindex ATOMIC_DEFINE +@cindex Atomic subroutine, compare and swap + +@table @asis +@item @emph{Description}: +@code{ATOMIC_CAS} compares the variable @var{ATOM} with the value of +@var{COMPARE}; if the value is the same, @var{ATOM} is set to the value +of @var{NEW}. Additionally, @var{OLD} is set to the value of @var{ATOM} +that was used for the comparison. When @var{STAT} is present and the invokation +was successful, it is assigned the value 0. If it is present and the invokation +has failed, it is assigned a positive value; in particular, for a coindexed +@var{ATOM}, if the remote image has stopped, it is assigned the value of +@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has +failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_CAS (ATOM, OLD, COMPARE, NEW [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of either integer +type with @code{ATOMIC_INT_KIND} kind or logical type with +@code{ATOMIC_LOGICAL_KIND} kind. +@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}. +@item @var{COMPARE} @tab Scalar variable of the same type and kind as +@var{ATOM}. +@item @var{NEW} @tab Scalar variable of the same type as @var{ATOM}. If kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + logical(atomic_logical_kind) :: atom[*], prev + call atomic_cas (atom[1], prev, .false., .true.)) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_REF}, @ref{ISO_FORTRAN_ENV} +@end table + + + @node ATOMIC_DEFINE @section @code{ATOMIC_DEFINE} --- Setting a variable atomically @fnindex ATOMIC_DEFINE @@ -1562,25 +1724,31 @@ Inverse function: @ref{TANH} @table @asis @item @emph{Description}: @code{ATOMIC_DEFINE(ATOM, VALUE)} defines the variable @var{ATOM} with the value -@var{VALUE} atomically. +@var{VALUE} atomically. When @var{STAT} is present and the invokation was +successful, it is assigned the value 0. If it is present and the invokation +has failed, it is assigned a positive value; in particular, for a coindexed +@var{ATOM}, if the remote image has stopped, it is assigned the value of +@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has +failed, the value @code{STAT_FAILED_IMAGE}. @item @emph{Standard}: -Fortran 2008 and later +Fortran 2008 and later; with @var{STAT}, TS 18508 or later @item @emph{Class}: Atomic subroutine @item @emph{Syntax}: -@code{CALL ATOMIC_DEFINE(ATOM, VALUE)} +@code{CALL ATOMIC_DEFINE (ATOM, VALUE [, STAT])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @item @var{ATOM} @tab Scalar coarray or coindexed variable of either integer - type with @code{ATOMIC_INT_KIND} kind or logical type - with @code{ATOMIC_LOGICAL_KIND} kind. -@item @var{VALURE} @tab Scalar and of the same type as @var{ATOM}. If the kind - is different, the value is converted to the kind of - @var{ATOM}. +type with @code{ATOMIC_INT_KIND} kind or logical type with +@code{ATOMIC_LOGICAL_KIND} kind. + +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. @end multitable @item @emph{Example}: @@ -1593,7 +1761,263 @@ end program atomic @end smallexample @item @emph{See also}: -@ref{ATOMIC_REF}, @ref{ISO_FORTRAN_ENV} +@ref{ATOMIC_REF}, @ref{ATOMIC_CAS}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_ADD}, @ref{ATOMIC_AND}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR} +@end table + + + +@node ATOMIC_FETCH_ADD +@section @code{ATOMIC_FETCH_ADD} --- Atomic ADD operation with prior fetch +@fnindex ATOMIC_FETCH_ADD +@cindex Atomic subroutine, ADD with fetch + +@table @asis +@item @emph{Description}: +@code{ATOMIC_FETCH_ADD(ATOM, VALUE, OLD)} atomically stores the value of +@var{ATOM} in @var{OLD} and adds the value of @var{VAR} to the +variable @var{ATOM}. When @var{STAT} is present and the invokation was +successful, it is assigned the value 0. If it is present and the invokation +has failed, it is assigned a positive value; in particular, for a coindexed +@var{ATOM}, if the remote image has stopped, it is assigned the value of +@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has +failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_FETCH_ADD (ATOM, VALUE, old [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer +type with @code{ATOMIC_INT_KIND} kind. +@code{ATOMIC_LOGICAL_KIND} kind. + +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + integer(atomic_int_kind) :: atom[*], old + call atomic_add (atom[1], this_image(), old) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_ADD}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_FETCH_AND}, @ref{ATOMIC_FETCH_OR}, @ref{ATOMIC_FETCH_XOR} +@end table + + + +@node ATOMIC_FETCH_AND +@section @code{ATOMIC_FETCH_AND} --- Atomic bitwise AND operation with prior fetch +@fnindex ATOMIC_FETCH_AND +@cindex Atomic subroutine, AND with fetch + +@table @asis +@item @emph{Description}: +@code{ATOMIC_AND(ATOM, VALUE)} atomically stores the value of @var{ATOM} in +@var{OLD} and defines @var{ATOM} with the bitwise AND between the values of +@var{ATOM} and @var{VALUE}. When @var{STAT} is present and the invokation was +successful, it is assigned the value 0. If it is present and the invokation has +failed, it is assigned a positive value; in particular, for a coindexed +@var{ATOM}, if the remote image has stopped, it is assigned the value of +@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has +failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_FETCH_AND (ATOM, VALUE, OLD [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer +type with @code{ATOMIC_INT_KIND} kind. +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + integer(atomic_int_kind) :: atom[*], old + call atomic_fetch_and (atom[1], int(b'10100011101'), old) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_AND}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_FETCH_ADD}, @ref{ATOMIC_FETCH_OR}, @ref{ATOMIC_FETCH_XOR} +@end table + + + +@node ATOMIC_FETCH_OR +@section @code{ATOMIC_FETCH_OR} --- Atomic bitwise OR operation with prior fetch +@fnindex ATOMIC_FETCH_OR +@cindex Atomic subroutine, OR with fetch + +@table @asis +@item @emph{Description}: +@code{ATOMIC_OR(ATOM, VALUE)} atomically stores the value of @var{ATOM} in +@var{OLD} and defines @var{ATOM} with the bitwise OR between the values of +@var{ATOM} and @var{VALUE}. When @var{STAT} is present and the invokation was +successful, it is assigned the value 0. If it is present and the invokation has +failed, it is assigned a positive value; in particular, for a coindexed +@var{ATOM}, if the remote image has stopped, it is assigned the value of +@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has +failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_FETCH_OR (ATOM, VALUE, OLD [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer +type with @code{ATOMIC_INT_KIND} kind. +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + integer(atomic_int_kind) :: atom[*], old + call atomic_fetch_or (atom[1], int(b'10100011101'), old) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_OR}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_FETCH_ADD}, @ref{ATOMIC_FETCH_AND}, @ref{ATOMIC_FETCH_XOR} +@end table + + + +@node ATOMIC_FETCH_XOR +@section @code{ATOMIC_FETCH_XOR} --- Atomic bitwise XOR operation with prior fetch +@fnindex ATOMIC_FETCH_XOR +@cindex Atomic subroutine, XOR with fetch + +@table @asis +@item @emph{Description}: +@code{ATOMIC_XOR(ATOM, VALUE)} atomically stores the value of @var{ATOM} in +@var{OLD} and defines @var{ATOM} with the bitwise XOR between the values of +@var{ATOM} and @var{VALUE}. When @var{STAT} is present and the invokation was +successful, it is assigned the value 0. If it is present and the invokation has +failed, it is assigned a positive value; in particular, for a coindexed +@var{ATOM}, if the remote image has stopped, it is assigned the value of +@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has +failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_FETCH_XOR (ATOM, VALUE, OLD [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer +type with @code{ATOMIC_INT_KIND} kind. +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + integer(atomic_int_kind) :: atom[*], old + call atomic_fetch_xor (atom[1], int(b'10100011101'), old) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_XOR}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_FETCH_ADD}, @ref{ATOMIC_FETCH_AND}, @ref{ATOMIC_FETCH_OR} +@end table + + + +@node ATOMIC_OR +@section @code{ATOMIC_OR} --- Atomic bitwise OR operation +@fnindex ATOMIC_OR +@cindex Atomic subroutine, OR + +@table @asis +@item @emph{Description}: +@code{ATOMIC_OR(ATOM, VALUE)} atomically defines @var{ATOM} with the bitwise +AND between the values of @var{ATOM} and @var{VALUE}. When @var{STAT} is present +and the invokation was successful, it is assigned the value 0. If it is present +and the invokation has failed, it is assigned a positive value; in particular, +for a coindexed @var{ATOM}, if the remote image has stopped, it is assigned the +value of @code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote +image has failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_OR (ATOM, VALUE [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer +type with @code{ATOMIC_INT_KIND} kind. +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + integer(atomic_int_kind) :: atom[*] + call atomic_or (atom[1], int(b'10100011101')) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_FETCH_OR}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_ADD}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR} @end table @@ -1606,25 +2030,31 @@ end program atomic @table @asis @item @emph{Description}: @code{ATOMIC_DEFINE(ATOM, VALUE)} atomically assigns the value of the -variable @var{ATOM} to @var{VALUE}. +variable @var{ATOM} to @var{VALUE}. When @var{STAT} is present and the +invokation was successful, it is assigned the value 0. If it is present and the +invokation has failed, it is assigned a positive value; in particular, for a +coindexed @var{ATOM}, if the remote image has stopped, it is assigned the value +of @code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image +has failed, the value @code{STAT_FAILED_IMAGE}. + @item @emph{Standard}: -Fortran 2008 and later +Fortran 2008 and later; with @var{STAT}, TS 18508 or later @item @emph{Class}: Atomic subroutine @item @emph{Syntax}: -@code{CALL ATOMIC_REF(VALUE, ATOM)} +@code{CALL ATOMIC_REF(VALUE, ATOM [, STAT])} @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{VALURE} @tab Scalar and of the same type as @var{ATOM}. If the kind - is different, the value is converted to the kind of - @var{ATOM}. +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. @item @var{ATOM} @tab Scalar coarray or coindexed variable of either integer - type with @code{ATOMIC_INT_KIND} kind or logical type - with @code{ATOMIC_LOGICAL_KIND} kind. +type with @code{ATOMIC_INT_KIND} kind or logical type with +@code{ATOMIC_LOGICAL_KIND} kind. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. @end multitable @item @emph{Example}: @@ -1643,10 +2073,59 @@ end program atomic @end smallexample @item @emph{See also}: -@ref{ATOMIC_DEFINE}, @ref{ISO_FORTRAN_ENV} +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_CAS}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_FETCH_ADD}, @ref{ATOMIC_FETCH_AND}, @ref{ATOMIC_FETCH_OR}, +@ref{ATOMIC_FETCH_XOR} @end table +@node ATOMIC_XOR +@section @code{ATOMIC_XOR} --- Atomic bitwise OR operation +@fnindex ATOMIC_XOR +@cindex Atomic subroutine, XOR + +@table @asis +@item @emph{Description}: +@code{ATOMIC_AND(ATOM, VALUE)} atomically defines @var{ATOM} with the bitwise +XOR between the values of @var{ATOM} and @var{VALUE}. When @var{STAT} is present +and the invokation was successful, it is assigned the value 0. If it is present +and the invokation has failed, it is assigned a positive value; in particular, +for a coindexed @var{ATOM}, if the remote image has stopped, it is assigned the +value of @code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote +image has failed, the value @code{STAT_FAILED_IMAGE}. + +@item @emph{Standard}: +TS 18508 or later + +@item @emph{Class}: +Atomic subroutine + +@item @emph{Syntax}: +@code{CALL ATOMIC_XOR (ATOM, VALUE [, STAT])} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer +type with @code{ATOMIC_INT_KIND} kind. +@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind +is different, the value is converted to the kind of @var{ATOM}. +@item @var{STAT} @tab (optional) Scalar default-kind integer variable. +@end multitable + +@item @emph{Example}: +@smallexample +program atomic + use iso_fortran_env + integer(atomic_int_kind) :: atom[*] + call atomic_xor (atom[1], int(b'10100011101')) +end program atomic +@end smallexample + +@item @emph{See also}: +@ref{ATOMIC_DEFINE}, @ref{ATOMIC_FETCH_XOR}, @ref{ISO_FORTRAN_ENV}, +@ref{ATOMIC_ADD}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR} +@end table + @node BACKTRACE @section @code{BACKTRACE} --- Show a backtrace @@ -13252,6 +13731,11 @@ Positive, scalar default-integer constant used as STAT= return value if the argument in the statement requires synchronisation with an image, which has initiated the termination of the execution. (Fortran 2008 or later.) +@item @code{STAT_FAILED_IMAGE}: +Positive, scalar default-integer constant used as STAT= return value if the +argument in the statement requires communication with an image, which has +is in the failed state. (TS 18508 or later.) + @item @code{STAT_UNLOCKED}: Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to denote that the lock variable is unlocked. (Fortran 2008 or later.) diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index ebadaef..c1d990a 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -85,6 +85,8 @@ NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \ GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \ GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_FAILED_IMAGE, "stat_failed_image", \ + GFC_STAT_FAILED_IMAGE, GFC_STD_F2008_TS) NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \ GFC_STAT_UNLOCKED, GFC_STD_F2008) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 1f8616f..b90dac6 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -115,7 +115,8 @@ typedef enum GFC_STAT_UNLOCKED = 0, GFC_STAT_LOCKED, GFC_STAT_LOCKED_OTHER_IMAGE, - GFC_STAT_STOPPED_IMAGE = 6000 /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ + GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ + GFC_STAT_FAILED_IMAGE } libgfortran_stat_codes; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 5aa5683..a285e9d 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8339,25 +8339,104 @@ conv_co_minmaxsum (gfc_code *code) static tree -conv_intrinsic_atomic_def (gfc_code *code) +conv_intrinsic_atomic_op (gfc_code *code) { - gfc_se atom, value; - stmtblock_t block; + gfc_se atom, value, old; + tree tmp; + stmtblock_t block, post_block; gfc_expr *atom_expr = code->ext.actual->expr; + gfc_expr *stat; + built_in_function fn; if (atom_expr->expr_type == EXPR_FUNCTION && atom_expr->value.function.isym && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) atom_expr = atom_expr->value.function.actual->expr; + gfc_start_block (&block); + gfc_init_block (&post_block); gfc_init_se (&atom, NULL); gfc_init_se (&value, NULL); + atom.want_pointer = 1; gfc_conv_expr (&atom, atom_expr); + gfc_add_block_to_block (&block, &atom.pre); + gfc_add_block_to_block (&post_block, &atom.post); gfc_conv_expr (&value, code->ext.actual->next->expr); + gfc_add_block_to_block (&block, &value.pre); + gfc_add_block_to_block (&post_block, &value.post); - gfc_init_block (&block); - gfc_add_modify (&block, atom.expr, - fold_convert (TREE_TYPE (atom.expr), value.expr)); + switch (code->resolved_isym->id) + { + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_FETCH_ADD: + fn = BUILT_IN_ATOMIC_FETCH_ADD_N; + break; + case GFC_ISYM_ATOMIC_AND: + case GFC_ISYM_ATOMIC_FETCH_AND: + fn = BUILT_IN_ATOMIC_FETCH_AND_N; + break; + case GFC_ISYM_ATOMIC_DEF: + fn = BUILT_IN_ATOMIC_STORE_N; + break; + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_FETCH_OR: + fn = BUILT_IN_ATOMIC_FETCH_OR_N; + break; + case GFC_ISYM_ATOMIC_XOR: + case GFC_ISYM_ATOMIC_FETCH_XOR: + fn = BUILT_IN_ATOMIC_FETCH_XOR_N; + break; + default: + gcc_unreachable (); + } + + tmp = TREE_TYPE (TREE_TYPE (atom.expr)); + fn = (built_in_function) ((int) fn + + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) + + 1); + tmp = builtin_decl_explicit (fn); + tree itype = TREE_TYPE (TREE_TYPE (atom.expr)); + tmp = builtin_decl_explicit (fn); + + switch (code->resolved_isym->id) + { + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_AND: + case GFC_ISYM_ATOMIC_DEF: + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_XOR: + stat = code->ext.actual->next->next->expr; + tmp = build_call_expr_loc (input_location, tmp, 3, atom.expr, + fold_convert (itype, value.expr), + build_int_cst (NULL, MEMMODEL_RELAXED)); + gfc_add_expr_to_block (&block, tmp); + break; + default: + stat = code->ext.actual->next->next->next->expr; + gfc_init_se (&old, NULL); + gfc_conv_expr (&old, code->ext.actual->next->next->expr); + gfc_add_block_to_block (&block, &old.pre); + gfc_add_block_to_block (&post_block, &old.post); + tmp = build_call_expr_loc (input_location, tmp, 3, atom.expr, + fold_convert (itype, value.expr), + build_int_cst (NULL, MEMMODEL_RELAXED)); + gfc_add_modify (&block, old.expr, + fold_convert (TREE_TYPE (old.expr), tmp)); + break; + } + + /* STAT= */ + if (stat != NULL) + { + gcc_assert (stat->expr_type == EXPR_VARIABLE); + gfc_init_se (&value, NULL); + gfc_conv_expr_val (&value, stat); + gfc_add_block_to_block (&block, &value.pre); + gfc_add_block_to_block (&post_block, &value.post); + gfc_add_modify (&block, value.expr, + build_int_cst (TREE_TYPE (value.expr), 0)); + } + gfc_add_block_to_block (&block, &post_block); return gfc_finish_block (&block); } @@ -8366,22 +8445,124 @@ static tree conv_intrinsic_atomic_ref (gfc_code *code) { gfc_se atom, value; - stmtblock_t block; - gfc_expr *atom_expr = code->ext.actual->expr; + tree tmp; + stmtblock_t block, post_block; + built_in_function fn; + gfc_expr *atom_expr = code->ext.actual->next->expr; if (atom_expr->expr_type == EXPR_FUNCTION && atom_expr->value.function.isym && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) atom_expr = atom_expr->value.function.actual->expr; + gfc_start_block (&block); + gfc_init_block (&post_block); gfc_init_se (&atom, NULL); gfc_init_se (&value, NULL); - gfc_conv_expr (&value, atom_expr); - gfc_conv_expr (&atom, code->ext.actual->next->expr); + atom.want_pointer = 1; + gfc_conv_expr (&value, code->ext.actual->expr); + gfc_add_block_to_block (&block, &value.pre); + gfc_add_block_to_block (&post_block, &value.post); + gfc_conv_expr (&atom, atom_expr); + gfc_add_block_to_block (&block, &atom.pre); + gfc_add_block_to_block (&post_block, &atom.post); + + tmp = TREE_TYPE (TREE_TYPE (atom.expr)); + fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N + + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) + + 1); + tmp = builtin_decl_explicit (fn); + tmp = build_call_expr_loc (input_location, tmp, 2, atom.expr, + build_int_cst (integer_type_node, + MEMMODEL_RELAXED)); + gfc_add_modify (&block, value.expr, + fold_convert (TREE_TYPE (value.expr), tmp)); + + /* STAT= */ + if (code->ext.actual->next->next->expr != NULL) + { + gcc_assert (code->ext.actual->next->next->expr->expr_type + == EXPR_VARIABLE); + gfc_init_se (&value, NULL); + gfc_conv_expr_val (&value, code->ext.actual->next->next->expr); + gfc_add_block_to_block (&block, &value.pre); + gfc_add_block_to_block (&post_block, &value.post); + gfc_add_modify (&block, value.expr, + build_int_cst (TREE_TYPE (value.expr), 0)); + } + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); +} + + +static tree +conv_intrinsic_atomic_cas (gfc_code *code) +{ + gfc_se argse; + tree tmp, atom, old, new_val, comp; + stmtblock_t block, post_block; + built_in_function fn; + gfc_expr *atom_expr = code->ext.actual->expr; + + if (atom_expr->expr_type == EXPR_FUNCTION + && atom_expr->value.function.isym + && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET) + atom_expr = atom_expr->value.function.actual->expr; gfc_init_block (&block); - gfc_add_modify (&block, value.expr, - fold_convert (TREE_TYPE (value.expr), atom.expr)); + gfc_init_block (&post_block); + gfc_init_se (&argse, NULL); + argse.want_pointer = 1; + gfc_conv_expr (&argse, atom_expr); + atom = argse.expr; + + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->ext.actual->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + old = argse.expr; + + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->ext.actual->next->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + comp = argse.expr; + + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + new_val = argse.expr; + + tmp = TREE_TYPE (TREE_TYPE (atom)); + fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N + + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp))) + + 1); + tmp = builtin_decl_explicit (fn); + + gfc_add_modify (&block, old, comp); + tmp = build_call_expr_loc (input_location, tmp, 6, atom, + gfc_build_addr_expr (NULL, old), + fold_convert (TREE_TYPE (old), new_val), + boolean_false_node, + build_int_cst (NULL, MEMMODEL_RELAXED), + build_int_cst (NULL, MEMMODEL_RELAXED)); + gfc_add_expr_to_block (&block, tmp); + + /* STAT= */ + if (code->ext.actual->next->next->next->next->expr != NULL) + { + gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type + == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, + code->ext.actual->next->next->next->next->expr); + gfc_add_block_to_block (&block, &argse.pre); + gfc_add_block_to_block (&post_block, &argse.post); + gfc_add_modify (&block, argse.expr, + build_int_cst (TREE_TYPE (argse.expr), 0)); + } + gfc_add_block_to_block (&block, &post_block); return gfc_finish_block (&block); } @@ -8632,8 +8813,20 @@ gfc_conv_intrinsic_subroutine (gfc_code *code) res = conv_intrinsic_move_alloc (code); break; + case GFC_ISYM_ATOMIC_CAS: + res = conv_intrinsic_atomic_cas (code); + break; + + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_AND: case GFC_ISYM_ATOMIC_DEF: - res = conv_intrinsic_atomic_def (code); + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_XOR: + case GFC_ISYM_ATOMIC_FETCH_ADD: + case GFC_ISYM_ATOMIC_FETCH_AND: + case GFC_ISYM_ATOMIC_FETCH_OR: + case GFC_ISYM_ATOMIC_FETCH_XOR: + res = conv_intrinsic_atomic_op (code); break; case GFC_ISYM_ATOMIC_REF: diff --git a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 new file mode 100644 index 0000000..20b6890 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 @@ -0,0 +1,653 @@ +! { dg-do run } +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none + +intrinsic :: atomic_define +intrinsic :: atomic_ref +intrinsic :: atomic_cas +intrinsic :: atomic_add +intrinsic :: atomic_and +intrinsic :: atomic_or +intrinsic :: atomic_xor +intrinsic :: atomic_fetch_add +intrinsic :: atomic_fetch_and +intrinsic :: atomic_fetch_or +intrinsic :: atomic_fetch_xor +integer(atomic_int_kind) :: caf[*], var, var3 +logical(atomic_logical_kind) :: caf_log[*], var2 +integer :: stat, i + +caf = 0 +caf_log = .false. +sync all + +if (this_image() == 1) then + call atomic_define(caf[num_images()], 5, stat=stat) + if (stat /= 0) call abort() + call atomic_define(caf_log[num_images()], .true., stat=stat) + if (stat /= 0) call abort() +end if +sync all + +if (this_image() == num_images()) then + if (caf /= 5) call abort() + if (.not. caf_log) call abort() + var = 99 + call atomic_ref(var, caf, stat=stat) + if (stat /= 0 .or. var /= 5) call abort() + var2 = .false. + call atomic_ref(var2, caf_log, stat=stat) + if (stat /= 0 .or. .not. var2) call abort() +end if +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= 5) call abort() +call atomic_ref(var2, caf_log[num_images()], stat=stat) +if (stat /= 0 .or. .not. var2) call abort() +sync all + +! ADD +caf = 0 +sync all + +call atomic_add(caf, this_image(), stat=stat) +if (stat /= 0) call abort() +do i = 1, num_images() + call atomic_add(caf[i], 1, stat=stat) + if (stat /= 0) call abort() + call atomic_ref(var, caf, stat=stat) + if (stat /= 0 .or. var < this_image()) call abort() +end do +sync all + +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= num_images() + this_image()) call abort() +do i = 1, num_images() + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= num_images() + i) call abort() +end do +sync all + +! AND(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_and(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! AND(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_and(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! AND(3) +caf = 0 +do i = 1, storage_size(caf)-2, 2 + caf = shiftl(1, i) + var3 = shiftl(1, i) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_and(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! OR(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_or(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! OR(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_or(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! OR(3) +caf = 0 +do i = 1, storage_size(caf)-2, 2 + caf = shiftl(1, i) + var3 = shiftl(1, i) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_or(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! XOR(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! XOR(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! XOR(3) +caf = 0 +do i = 1, storage_size(caf)-2, 2 + caf = shiftl(1, i) + var3 = shiftl(1, i) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! ADD +caf = 0 +sync all +var = -99 +call atomic_fetch_add(caf, this_image(), var, stat=stat) +if (stat /= 0 .or. var < 0) call abort() +if (num_images() == 1 .and. var /= 0) call abort() +do i = 1, num_images() + var = -99 + call atomic_fetch_add(caf[i], 1, var, stat=stat) + if (stat /= 0 .or. var < 0) call abort() + call atomic_ref(var, caf, stat=stat) + if (stat /= 0 .or. var < this_image()) call abort() +end do +sync all + +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= num_images() + this_image()) call abort() +do i = 1, num_images() + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= num_images() + i) call abort() +end do +sync all + + +! AND(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = 99 + call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var /= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! AND(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var == shiftl(1, this_image())) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! AND(3) +caf = 0 +var3 = 0 +do i = 1, storage_size(caf)-2, 2 + caf = ior(shiftl(1, i), caf) + var3 = ior(shiftl(1, i), var3) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var <= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + + + +! OR(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var < 0 .or. var == shiftl(1, this_image())) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! OR(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. (var < 0 .and. var /= -1)) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! OR(3) +caf = 0 +var3 = 0 +do i = 1, storage_size(caf)-2, 2 + caf = ior(shiftl(1, i), caf) + var3 = ior(shiftl(1, i), var3) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var <= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + + +! XOR(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var < 0 .or. var == shiftl(1, this_image())) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! XOR(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. (var < 0 .and. var /= -1)) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! XOR(3) +caf = 0 +var3 = 0 +do i = 1, storage_size(caf)-2, 2 + caf = ior(shiftl(1, i), caf) + var3 = ior(shiftl(1, i), var3) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var <= 0) call abort() + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) call abort() + end if + end do +end if +sync all + +! CAS +caf = 9 +caf_log = .true. +sync all + +if (this_image() == 1) then + call atomic_cas(caf[num_images()], compare=5, new=3, old=var, stat=stat) + if (stat /= 0 .or. var /= 9) call abort() + call atomic_ref(var, caf[num_images()], stat=stat) + if (stat /= 0 .or. var /= 9) call abort() +end if +sync all + +if (this_image() == num_images() .and. caf /= 9) call abort() +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= 9) call abort() +sync all + +if (this_image() == 1) then + call atomic_cas(caf[num_images()], compare=9, new=3, old=var, stat=stat) + if (stat /= 0 .or. var /= 9) call abort() + call atomic_ref(var, caf[num_images()], stat=stat) + if (stat /= 0 .or. var /= 3) call abort() +end if +sync all + +if (this_image() == num_images() .and. caf /= 3) call abort() +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= 3) call abort() +sync all + + +if (this_image() == 1) then + call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat) + if (stat /= 0 .or. var2 .neqv. .true.) call abort() + call atomic_ref(var2, caf_log[num_images()], stat=stat) + if (stat /= 0 .or. var2 .neqv. .true.) call abort() +end if +sync all + +if (this_image() == num_images() .and. caf_log .neqv. .true.) call abort() +call atomic_ref(var2, caf_log[num_images()], stat=stat) +if (stat /= 0 .or. var2 .neqv. .true.) call abort() +sync all + +if (this_image() == 1) then + call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat) + if (stat /= 0 .or. var2 .neqv. .true.) call abort() + call atomic_ref(var2, caf_log[num_images()], stat=stat) + if (stat /= 0 .or. var2 .neqv. .false.) call abort() +end if +sync all + +if (this_image() == num_images() .and. caf_log .neqv. .false.) call abort() +call atomic_ref(var2, caf_log[num_images()], stat=stat) +if (stat /= 0 .or. var2 .neqv. .false.) call abort() +end diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_1.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_1.f90 index bf94b91..107f076 100644 --- a/gcc/testsuite/gfortran.dg/coarray_atomic_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_atomic_1.f90 @@ -16,6 +16,6 @@ call atomic_define(a, 7_2) ! { dg-error "must be a scalar" } call atomic_ref(b, b) ! { dg-error "shall be a coarray" } call atomic_define(c, 7) ! { dg-error "an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } -call atomic_ref(d, a(1)) ! { dg-error "shall have the same type" } +call atomic_ref(d, a(1)) ! { dg-error "shall have the same type as 'atom'" } call atomic_ref(.true., e) ! { dg-error "shall be definable" } end diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_2.f90 new file mode 100644 index 0000000..c66827b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_atomic_2.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none + +intrinsic :: atomic_define +intrinsic :: atomic_ref +intrinsic :: atomic_cas ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +intrinsic :: atomic_add ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +intrinsic :: atomic_and ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +intrinsic :: atomic_or ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +intrinsic :: atomic_xor ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +intrinsic :: atomic_fetch_add ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +intrinsic :: atomic_fetch_and ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +intrinsic :: atomic_fetch_or ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +intrinsic :: atomic_fetch_xor ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." } +integer(atomic_int_kind) :: caf[*], var +logical(atomic_logical_kind) :: caf_log[*], var2 +integer :: stat +integer(1) :: stat2 + +call atomic_define(caf, 5, stat=stat) ! { dg-error "STAT= argument to atomic_define" } +call atomic_define(caf_log, .true., stat=stat2) ! { dg-error "must be of kind 4" } +call atomic_ref(var, caf[1], stat=stat2) ! { dg-error "must be of kind 4" } +call atomic_ref(var2, caf_log[1], stat=stat) ! { dg-error "STAT= argument to atomic_ref" } +end diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_3.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_3.f90 new file mode 100644 index 0000000..a3c4264 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_atomic_3.f90 @@ -0,0 +1,112 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008ts -fmax-errors=200" } +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none + +intrinsic :: atomic_define +intrinsic :: atomic_ref +intrinsic :: atomic_cas +intrinsic :: atomic_add +intrinsic :: atomic_and +intrinsic :: atomic_or +intrinsic :: atomic_xor +intrinsic :: atomic_fetch_add +intrinsic :: atomic_fetch_and +intrinsic :: atomic_fetch_or +intrinsic :: atomic_fetch_xor +integer(atomic_int_kind) :: caf[*], var +logical(atomic_logical_kind) :: caf_log[*], var2 +integer :: stat +integer(1) :: var3, caf0[*] +logical(1) :: var4, caf0_log[*] + +call atomic_define(caf[1], 2_2, stat=stat) +call atomic_define(atom=caf_log[1], value=.false._2) +call atomic_define(caf_log[1], 2) ! { dg-error "shall have the same type as 'atom'" } +call atomic_define(var, 2_2, stat=stat) ! { dg-error "shall be a coarray or coindexed" } +call atomic_define(caf0, 2_2, stat=stat) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_define(var2, 2_2, stat=stat) ! { dg-error "shall be a coarray or coindexed" } +call atomic_define(caf0_log, 2_2, stat=stat) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } + +call atomic_ref(var3, caf[1], stat=stat) +call atomic_ref(value=var4, atom=caf_log[1]) +call atomic_ref(var, caf_log[1]) ! { dg-error "shall have the same type as 'atom'" } +call atomic_ref(var, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_ref(var, caf0) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_ref(var, caf0_log) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } + +call atomic_cas(caf[1], var, 2_4, 1_1, stat=stat) +call atomic_cas(caf[1], var, 2_2, 1_1, stat=stat) ! { dg-error "'compare' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" } +call atomic_cas(caf[1], var3, 2_2, 1_1, stat=stat) ! { dg-error "'old' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" } +call atomic_cas(caf[1], var3, 2_4, .false._4, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_cas(caf0[1], var, 2_4, 1_1, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_cas(var, var, 2_4, 1_1, stat=stat) ! { dg-error "shall be a coarray or coindexed" } +call atomic_cas(caf_log[1], var2, .true._4, .false._1, stat=stat) +call atomic_cas(caf_log[1], var2, .true._2, .false._1, stat=stat) ! { dg-error "'compare' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" } +call atomic_cas(caf_log[1], var4, .true._4, .false._1, stat=stat) ! { dg-error "'old' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" } +call atomic_cas(caf_log[1], var4, .true._4, 4_4, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_cas(atom=caf0_log[1], old=var4, compare=.true._4, new=.false._4, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_cas(var2, var4, .true._4, .false._4, stat=stat) ! { dg-error "shall be a coarray or coindexed" } +call atomic_cas(caf[1], var, 2_4, 1_1, stat=var3) ! { dg-error "'stat' argument of 'atomic_cas' intrinsic at .1. must be of kind 4" } + +call atomic_add(atom=caf, value=2_4, stat=stat) +call atomic_add(caf, 2_2, stat=stat) +call atomic_add(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_add(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_add(var, 34._4) ! { dg-error "shall be a coarray or coindexed" } +call atomic_add(atom=caf, value=2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_add' intrinsic at .1. must be of kind 4" } + +call atomic_and(caf, 2_4, stat=stat) +call atomic_and(atom=caf, value=2_2, stat=stat) +call atomic_and(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_and(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_and(var, 34._4) ! { dg-error "shall be a coarray or coindexed" } +call atomic_and(caf, 2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_and' intrinsic at .1. must be of kind 4" } + +call atomic_or(caf, value=2_4, stat=stat) +call atomic_or(atom=caf, value=2_2, stat=stat) +call atomic_or(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_or(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_or(var, 34._4) ! { dg-error "shall be a coarray or coindexed" } +call atomic_or(caf, value=2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_or' intrinsic at .1. must be of kind 4" } + +call atomic_xor(caf, 2_4, stat=stat) +call atomic_xor(atom=caf, value=2_2, stat=stat) +call atomic_xor(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_xor(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_xor(var, 34._4) ! { dg-error "shall be a coarray or coindexed" } +call atomic_xor(caf, 2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_xor' intrinsic at .1. must be of kind 4" } + +call atomic_fetch_add(atom=caf, value=2_4, old=var, stat=stat) +call atomic_fetch_add(caf, 2_2, var) +call atomic_fetch_add(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_fetch_add(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_fetch_add(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_fetch_add(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" } +call atomic_fetch_add(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_add' intrinsic at .1. must be of kind 4" } + +call atomic_fetch_and(atom=caf, value=2_4, old=var, stat=stat) +call atomic_fetch_and(caf, 2_2, var) +call atomic_fetch_and(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_fetch_and(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_fetch_and(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_fetch_and(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" } +call atomic_fetch_and(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_and' intrinsic at .1. must be of kind 4" } + +call atomic_fetch_or(atom=caf, value=2_4, old=var, stat=stat) +call atomic_fetch_or(caf, 2_2, var) +call atomic_fetch_or(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_fetch_or(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_fetch_or(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_fetch_or(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" } +call atomic_fetch_or(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_or' intrinsic at .1. must be of kind 4" } + +call atomic_fetch_xor(atom=caf, value=2_4, old=var, stat=stat) +call atomic_fetch_xor(caf, 2_2, var) +call atomic_fetch_xor(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_fetch_xor(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_fetch_xor(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_fetch_xor(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" } +call atomic_fetch_xor(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_xor' intrinsic at .1. must be of kind 4" } +end diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_4.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_4.f90 new file mode 100644 index 0000000..663a6c8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_atomic_4.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -fdump-tree-original" } +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none + +intrinsic :: atomic_define +intrinsic :: atomic_ref +intrinsic :: atomic_cas +intrinsic :: atomic_add +intrinsic :: atomic_and +intrinsic :: atomic_or +intrinsic :: atomic_xor +intrinsic :: atomic_fetch_add +intrinsic :: atomic_fetch_and +intrinsic :: atomic_fetch_or +intrinsic :: atomic_fetch_xor +integer(atomic_int_kind) :: caf[*], var +logical(atomic_logical_kind) :: caf_log[*], var2 +integer :: stat +integer(1) :: var3 +logical(1) :: var4 + +call atomic_define(caf, var, stat=stat) +call atomic_define(caf_log, var2, stat=stat) + +call atomic_ref(var, caf, stat=stat) +call atomic_ref(var2, caf_log, stat=stat) + +call atomic_cas(caf, var, 3_atomic_int_kind, 5_1, stat=stat) +call atomic_cas(caf_log, var2, .true._atomic_logical_kind, & + .false._2, stat=stat) + +call atomic_add(caf, 77, stat=stat) +call atomic_and(caf, 88, stat=stat) +call atomic_or(caf, 101, stat=stat) +call atomic_xor(caf, 105_2, stat=stat) + +call atomic_fetch_add(caf, var3, var, stat=stat) +call atomic_fetch_and(caf, 22_16, var, stat=stat) +call atomic_fetch_or(caf, var3, var, stat=stat) +call atomic_fetch_xor(caf, 47_2, var, stat=stat) + +end + +! All the atomic calls: +! { dg-final { scan-tree-dump-times " __atomic_store_4 \\(&caf, \\(integer\\(kind=4\\)\\) var, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_store_4 \\(&caf_log, \\(logical\\(kind=4\\)\\) var2, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_load_4 \\(&caf, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "var2 = \\(logical\\(kind=4\\)\\) __atomic_load_4 \\(&caf_log, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_compare_exchange_4 \\(&caf, &var, 5, 0, 0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_compare_exchange_4 \\(&caf_log, &var2, 0, 0, 0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_fetch_add_4 \\(&caf, 77, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_fetch_and_4 \\(&caf, 88, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_fetch_or_4 \\(&caf, 101, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_fetch_xor_4 \\(&caf, 105, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_fetch_add_4 \\(&caf, \\(integer\\(kind=4\\)\\) var3, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_fetch_and_4 \\(&caf, 22, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " var = \\(integer\\(kind=4\\)\\) __atomic_fetch_or_4 \\(&caf, \\(integer\\(kind=4\\)\\) var3, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " var = \\(integer\\(kind=4\\)\\) __atomic_fetch_xor_4 \\(&caf, 47, 0\\);" 1 "original" } } + +! CAS: Handle "compare" argument +! { dg-final { scan-tree-dump-times "var = 3;" 1 "original" } } +! { dg-final { scan-tree-dump-times "var2 = 1;" 1 "original" } } + +! All calls should have a stat=0 +! { dg-final { scan-tree-dump-times "stat = 0;" 14 "original" } } + +! { dg-final { cleanup-tree-dump "original" } }