b/gcc/fortran/check.c | 65 ++++++++++++++
b/gcc/fortran/gfortran.h | 2
b/gcc/fortran/intrinsic.c | 16 +++
b/gcc/fortran/intrinsic.h | 4
b/gcc/fortran/intrinsic.texi | 96 +++++++++++++++++++++
b/gcc/fortran/iresolve.c | 16 +++
b/gcc/fortran/iso-fortran-env.def | 4
b/gcc/fortran/trans-intrinsic.c | 68 ++++++++++++++
b/gcc/fortran/trans.c | 17 ++-
b/gcc/fortran/trans.h | 5 -
gcc/gcc/testsuite/gfortran.dg/coarray/atomic_1.f90 | 27 +++++
gcc/gcc/testsuite/gfortran.dg/coarray_atomic_1.f90 | 21 ++++
12 files changed, 326 insertions(+), 15 deletions(-)
2011-05-31 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* intrinsic.c (klass): Add CLASS_ATOMIC.
(add_subroutines): Add atomic_ref/atomic_define.
* intrinsic.texi (ATOMIC_REF, ATOMIC_DEFINE): Document.
* intrinsic.h (gfc_check_atomic_def, gfc_check_atomic_ref,
gfc_resolve_atomic_def, gfc_resolve_atomic_ref): New prototypes.
* gfortran.h (gfc_isym_id): Add GFC_ISYM_ATOMIC_DEF
and GFC_ISYM_ATOMIC_REF.
* iresolve.c (gfc_resolve_atomic_def, gfc_resolve_atomic_ref): New
functions.
* check.c (gfc_check_atomic, gfc_check_atomic_def,
gfc_check_atomic_ref): New functions.
* iso-fortran-env.def (ISOFORTRANENV_FILE_ATOMIC_INT_KIND,
ISOFORTRANENV_FILE_ATOMIC_LOGICAL_KIND): Change kind value.
* trans-intrinsic.c (conv_intrinsic_atomic_def,
conv_intrinsic_atomic_ref, gfc_conv_intrinsic_subroutine): New
functions.
(conv_intrinsic_move_alloc) Renamed from
gfc_conv_intrinsic_move_alloc - and made static.
* trans.h (gfc_conv_intrinsic_move_alloc): Remove.
(gfc_conv_intrinsic_subroutine) Add prototype.
* trans.c (trans_code): Call gfc_conv_intrinsic_subroutine.
2011-05-31 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.dg/coarray_atomic_1.f90: New.
* gfortran.dg/coarray/atomic_1.f90: New.
@@ -973,6 +973,71 @@ gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
}
+static gfc_try
+gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
+{
+ if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_c_int_kind)
+ && !(atom->ts.type == BT_LOGICAL && atom->ts.kind == gfc_c_int_kind))
+ {
+ gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
+ "integer of ATOMIC_INT_KIND or a logical of "
+ "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
+ return FAILURE;
+ }
+
+ if (!gfc_expr_attr (atom).codimension)
+ {
+ gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
+ "coarray or coindexed", &atom->where, gfc_current_intrinsic);
+ return FAILURE;
+ }
+
+ 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);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
+{
+ if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
+ return FAILURE;
+
+ if (gfc_check_vardef_context (atom, false, NULL) == FAILURE)
+ {
+ gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
+ "definable", gfc_current_intrinsic, &atom->where);
+ return FAILURE;
+ }
+
+ return gfc_check_atomic (atom, value);
+}
+
+
+gfc_try
+gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
+{
+ if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
+ return FAILURE;
+
+ if (gfc_check_vardef_context (value, false, NULL) == FAILURE)
+ {
+ gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
+ "definable", gfc_current_intrinsic, &value->where);
+ return FAILURE;
+ }
+
+ return gfc_check_atomic (atom, value);
+}
+
+
/* BESJN and BESYN functions. */
gfc_try
@@ -306,6 +306,8 @@ enum gfc_isym_id
GFC_ISYM_ATAN,
GFC_ISYM_ATAN2,
GFC_ISYM_ATANH,
+ GFC_ISYM_ATOMIC_DEF,
+ GFC_ISYM_ATOMIC_REF,
GFC_ISYM_BGE,
GFC_ISYM_BGT,
GFC_ISYM_BIT_SIZE,
@@ -51,7 +51,7 @@ sizing;
enum klass
{ CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL,
- CLASS_INQUIRY, CLASS_TRANSFORMATIONAL };
+ CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC };
#define ACTUAL_NO 0
#define ACTUAL_YES 1
@@ -2880,6 +2880,18 @@ add_subroutines (void)
make_noreturn();
+ add_sym_2s ("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);
+
+ add_sym_2s ("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);
+
add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
@@ -39,6 +39,8 @@ gfc_try gfc_check_allocated (gfc_expr *);
gfc_try gfc_check_associated (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atan_2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atan2 (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_atomic_def (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_atomic_ref (gfc_expr *, gfc_expr *);
gfc_try gfc_check_besn (gfc_expr *, gfc_expr *);
gfc_try gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *);
@@ -414,6 +416,8 @@ void gfc_resolve_asinh (gfc_expr *, gfc_expr *);
void gfc_resolve_atan (gfc_expr *, gfc_expr *);
void gfc_resolve_atanh (gfc_expr *, gfc_expr *);
void gfc_resolve_atan2 (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_atomic_def (gfc_code *);
+void gfc_resolve_atomic_ref (gfc_code *);
void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a);
void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -61,6 +61,8 @@ 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_DEFINE}: ATOMIC_DEFINE, Setting a variable atomically
+* @code{ATOMIC_REF}: ATOMIC_REF, Obtaining the value of a variable atomically
* @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
* @code{BESSEL_JN}: BESSEL_JN, Bessel function of the first kind
@@ -1546,6 +1548,100 @@ Inverse function: @ref{TANH}
+@node ATOMIC_DEFINE
+@section @code{ATOMIC_DEFINE} --- Setting a variable atomically
+@fnindex ATOMIC_DEFINE
+@cindex Atomic subroutine, define
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_DEFINE(ATOM, VALUE)} defines the variable @var{ATOM} with the value
+@var{VALUE} atomically.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_DEFINE(ATOM, VALUE)}
+
+@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}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*]
+ call atomic_define (atom[1], this_image())
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_REF}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
+@node ATOMIC_REF
+@section @code{ATOMIC_REF} --- Obtaining the value of a variable atomically
+@fnindex ATOMIC_REF
+@cindex Atomic subroutine, reference
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_DEFINE(ATOM, VALUE)} atomically assigns the value of the
+variable @var{ATOM} to @var{VALUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_REF(VALUE, ATOM)}
+
+@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{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.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ logical(atomic_logical_kind) :: atom[*]
+ logical :: val
+ call atomic_ref (atom, .false.)
+ ! ...
+ call atomic_ref (atom, val)
+ if (val) then
+ print *, "Obtained"
+ end if
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
@node BESSEL_J0
@section @code{BESSEL_J0} --- Bessel function of the first kind of order 0
@fnindex BESSEL_J0
@@ -2895,6 +2895,22 @@ create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
void
+gfc_resolve_atomic_def (gfc_code *c)
+{
+ const char *name = "atomic_define";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_atomic_ref (gfc_code *c)
+{
+ const char *name = "atomic_ref";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
gfc_resolve_mvbits (gfc_code *c)
{
static const sym_intent INTENTS[] = {INTENT_IN, INTENT_IN, INTENT_IN,
@@ -38,9 +38,9 @@ along with GCC; see the file COPYING3. If not see
-- the standard that supports this type */
NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_INT_KIND, "atomic_int_kind", \
- gfc_default_integer_kind, GFC_STD_F2008)
+ gfc_c_int_kind, GFC_STD_F2008)
NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_LOGICAL_KIND, "atomic_logical_kind", \
- gfc_default_logical_kind, GFC_STD_F2008)
+ gfc_c_int_kind, GFC_STD_F2008)
NAMED_INTCST (ISOFORTRANENV_CHARACTER_STORAGE_SIZE, "character_storage_size", \
gfc_character_storage_size, GFC_STD_F2003)
NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", GFC_STDERR_UNIT_NUMBER, \
@@ -6952,8 +6952,44 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
}
-tree
-gfc_conv_intrinsic_move_alloc (gfc_code *code)
+static tree
+conv_intrinsic_atomic_def (gfc_code *code)
+{
+ gfc_se atom, value;
+ stmtblock_t block;
+
+ gfc_init_se (&atom, NULL);
+ gfc_init_se (&value, NULL);
+ gfc_conv_expr (&atom, code->ext.actual->expr);
+ gfc_conv_expr (&value, code->ext.actual->next->expr);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, atom.expr,
+ fold_convert (TREE_TYPE (atom.expr), value.expr));
+ return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_atomic_ref (gfc_code *code)
+{
+ gfc_se atom, value;
+ stmtblock_t block;
+
+ gfc_init_se (&atom, NULL);
+ gfc_init_se (&value, NULL);
+ gfc_conv_expr (&value, code->ext.actual->expr);
+ gfc_conv_expr (&atom, code->ext.actual->next->expr);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, value.expr,
+ fold_convert (TREE_TYPE (value.expr), atom.expr));
+ return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_move_alloc (gfc_code *code)
{
if (code->ext.actual->expr->rank == 0)
{
@@ -7002,4 +7038,32 @@ gfc_conv_intrinsic_move_alloc (gfc_code *code)
}
+tree
+gfc_conv_intrinsic_subroutine (gfc_code *code)
+{
+ tree res;
+
+ gcc_assert (code->resolved_isym);
+
+ switch (code->resolved_isym->id)
+ {
+ case GFC_ISYM_MOVE_ALLOC:
+ res = conv_intrinsic_move_alloc (code);
+
+ case GFC_ISYM_ATOMIC_DEF:
+ res = conv_intrinsic_atomic_def (code);
+ break;
+
+ case GFC_ISYM_ATOMIC_REF:
+ res = conv_intrinsic_atomic_ref (code);
+ break;
+
+ default:
+ res = NULL_TREE;
+ break;
+ }
+
+ return res;
+}
+
#include "gt-fortran-trans-intrinsic.h"
@@ -1245,15 +1245,20 @@ trans_code (gfc_code * code, tree cond)
dependency check, too. */
{
bool is_mvbits = false;
+
+ if (code->resolved_isym)
+ {
+ res = gfc_conv_intrinsic_subroutine (code);
+ if (res != NULL_TREE)
+ break;
+ }
+
if (code->resolved_isym
&& code->resolved_isym->id == GFC_ISYM_MVBITS)
is_mvbits = true;
- if (code->resolved_isym
- && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
- res = gfc_conv_intrinsic_move_alloc (code);
- else
- res = gfc_trans_call (code, is_mvbits, NULL_TREE,
- NULL_TREE, false);
+
+ res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+ NULL_TREE, false);
}
break;
@@ -345,7 +345,8 @@ tree gfc_evaluate_now (tree, stmtblock_t *);
/* Find the appropriate variant of a math intrinsic. */
tree gfc_builtin_decl_for_float_kind (enum built_in_function, int);
-/* Intrinsic function handling. */
+/* Intrinsic procedure handling. */
+tree gfc_conv_intrinsic_subroutine (gfc_code *);
void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
/* Is the intrinsic expanded inline. */
@@ -356,8 +357,6 @@ bool gfc_inline_intrinsic_function_p (gfc_expr *);
gfc_inline_intrinsic_function_p returns true. */
int gfc_is_intrinsic_libcall (gfc_expr *);
-tree gfc_conv_intrinsic_move_alloc (gfc_code *);
-
/* Used to call ordinary functions/subroutines
and procedure pointer components. */
int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single -std=f2008" }
+!
+! PR fortran/18918
+!
+! Diagnostic for atomic subroutines
+!
+use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
+implicit none
+integer(atomic_int_kind) :: a(1)[*]
+logical(1) :: c[*]
+integer(atomic_int_kind) :: b
+logical(atomic_logical_kind) :: d, e[*]
+
+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(.true., e) ! { dg-error "shall be definable" }
+end
@@ -0,0 +1,27 @@
+! { dg-do run }
+!
+! PR fortran/18918
+!
+! Basic atomic def/ref test
+!
+
+use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
+implicit none
+integer(atomic_int_kind) :: a(1)[*]
+logical(atomic_logical_kind) :: c[*]
+intrinsic :: atomic_define
+intrinsic :: atomic_ref
+integer(8) :: b
+logical(1) :: d
+
+call atomic_define(a(1), 7_2)
+call atomic_ref(b, a(1))
+if (b /= a(1)) call abort()
+
+call atomic_define(c, .false.)
+call atomic_ref(d, c[this_image()])
+if (d .neqv. .false.) call abort()
+call atomic_define(c[this_image()], .true.)
+call atomic_ref(d, c)
+if (d .neqv. .true.) call abort()
+end
This patch adds the atomic_define and atomic_ref intrinsics. They are currently implemented in form a simple assignment. For -fcoarray=lib they will be replaced by a function call to libcaf_{single,mpi,*}. I was shortly thinking of using something more clever, but I concluded that a simple assignment should be sufficiently atomic (for -fcoarray=single). Build and regtested on x86-64-linux. OK for the trunk? Tobias