procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran/OpenMP: Support most of 5.1 atomic extensions

Browse source 
Implements moste of OpenMP 5.1 atomic extensions,
except that 'compare' is parsed but rejected during
resolution. (As the trans-openmp.c handling is missing.)

gcc/fortran/ChangeLog:

	* dump-parse-tree.c (show_omp_clauses): Handle
	weak/compare/fail clause.
	* gfortran.h (gfc_omp_clauses): Add weak, compare, fail.
	* openmp.c (enum omp_mask1, gfc_match_omp_clauses,
	OMP_ATOMIC_CLAUSES): Update for new clauses.
	(gfc_match_omp_atomic): Update for 5.1 atomic changes.
	(is_conversion): Support widening in one go.
	(is_scalar_intrinsic_expr): New.
	(resolve_omp_atomic): Update for 5.1 atomic changes.
	* parse.c (parse_omp_oacc_atomic): Update for compare.
	* resolve.c (gfc_resolve_blocks): Update asserts.
	* trans-openmp.c (gfc_trans_omp_atomic): Handle new clauses.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/atomic-2.f90: Move now supported code to ...
	* gfortran.dg/gomp/atomic.f90: here.
	* gfortran.dg/gomp/atomic-10.f90: New test.
	* gfortran.dg/gomp/atomic-12.f90: New test.
	* gfortran.dg/gomp/atomic-15.f90: New test.
	* gfortran.dg/gomp/atomic-16.f90: New test.
	* gfortran.dg/gomp/atomic-17.f90: New test.
	* gfortran.dg/gomp/atomic-18.f90: New test.
	* gfortran.dg/gomp/atomic-19.f90: New test.
	* gfortran.dg/gomp/atomic-20.f90: New test.
	* gfortran.dg/gomp/atomic-22.f90: New test.
	* gfortran.dg/gomp/atomic-24.f90: New test.
	* gfortran.dg/gomp/atomic-25.f90: New test.
	* gfortran.dg/gomp/atomic-26.f90: New test.

libgomp/ChangeLog

	* libgomp.texi (OpenMP 5.1): Update status.
This commit is contained in:
Tobias Burnus 2021-12-04 19:39:43 +01:00
parent 87710ec7b2
commit 689407ef91
21 changed files with 1260 additions and 272 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gcc/fortran/dump-parse-tree.c
View file

@ -1810,6 +1810,10 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
}
fputc (')', dumpfile);
}
if (omp_clauses->weak)
fputs (" WEAK", dumpfile);
if (omp_clauses->compare)
fputs (" COMPARE", dumpfile);
if (omp_clauses->nogroup)
fputs (" NOGROUP", dumpfile);
if (omp_clauses->simd)
@ -1926,6 +1930,20 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses)
fputc (' ', dumpfile);
fputs (memorder, dumpfile);
}
if (omp_clauses->fail != OMP_MEMORDER_UNSET)
{
const char *memorder;
switch (omp_clauses->fail)
{
case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break;
case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break;
case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break;
default: gcc_unreachable ();
}
fputs (" FAIL(", dumpfile);
fputs (memorder, dumpfile);
putc (')', dumpfile);
}
if (omp_clauses->at != OMP_AT_UNSET)
{
if (omp_clauses->at != OMP_AT_COMPILATION)

3
gcc/fortran/gfortran.h
View file

@ -1529,10 +1529,11 @@ typedef struct gfc_omp_clauses
unsigned sched_simd:1, sched_monotonic:1, sched_nonmonotonic:1;
unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1;
unsigned order_unconstrained:1, order_reproducible:1, capture:1;
unsigned grainsize_strict:1, num_tasks_strict:1;
unsigned grainsize_strict:1, num_tasks_strict:1, compare:1, weak:1;
ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3;
ENUM_BITFIELD (gfc_omp_device_type) device_type:2;
ENUM_BITFIELD (gfc_omp_memorder) memorder:3;
ENUM_BITFIELD (gfc_omp_memorder) fail:3;
ENUM_BITFIELD (gfc_omp_cancel_kind) cancel:3;
ENUM_BITFIELD (gfc_omp_proc_bind_kind) proc_bind:3;
ENUM_BITFIELD (gfc_omp_depend_op) depobj_update:3;

598
gcc/fortran/openmp.c
View file

@ -917,6 +917,9 @@ enum omp_mask1
OMP_CLAUSE_AT, /* OpenMP 5.1. */
OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */
OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */
OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */
OMP_CLAUSE_FAIL, /* OpenMP 5.1. */
OMP_CLAUSE_WEAK, /* OpenMP 5.1. */
OMP_CLAUSE_NOWAIT,
/* This must come last. */
OMP_MASK1_LAST
@ -1450,7 +1453,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
*cp = NULL;
while (1)
{
if ((first || gfc_match_char (',') != MATCH_YES)
match m = MATCH_NO;
if ((first || (m = gfc_match_char (',')) != MATCH_YES)
&& (needs_space && gfc_match_space () != MATCH_YES))
break;
needs_space = false;
@ -1460,7 +1464,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
gfc_omp_namelist **head;
old_loc = gfc_current_locus;
char pc = gfc_peek_ascii_char ();
match m;
if (pc == '\n' && m == MATCH_YES)
{
gfc_error ("Clause expected at %C after trailing comma");
goto error;
}
switch (pc)
{
case 'a':
@ -1654,6 +1662,16 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
continue;
}
}
if ((mask & OMP_CLAUSE_COMPARE)
&& (m = gfc_match_dupl_check (!c->compare, "compare"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->compare = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_COPY)
&& gfc_match ("copy ( ") == MATCH_YES
&& gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
@ -2009,6 +2027,27 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
break;
case 'f':
if ((mask & OMP_CLAUSE_FAIL)
&& (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET,
"fail", true)) != MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
if (gfc_match ("seq_cst") == MATCH_YES)
c->fail = OMP_MEMORDER_SEQ_CST;
else if (gfc_match ("acquire") == MATCH_YES)
c->fail = OMP_MEMORDER_ACQUIRE;
else if (gfc_match ("relaxed") == MATCH_YES)
c->fail = OMP_MEMORDER_RELAXED;
else
{
gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C");
break;
}
if (gfc_match (" )") != MATCH_YES)
goto error;
continue;
}
if ((mask & OMP_CLAUSE_FILTER)
&& (m = gfc_match_dupl_check (!c->filter, "filter", true,
&c->filter)) != MATCH_NO)
@ -2903,6 +2942,16 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
continue;
}
if ((mask & OMP_CLAUSE_WEAK)
&& (m = gfc_match_dupl_check (!c->weak, "weak"))
!= MATCH_NO)
{
if (m == MATCH_ERROR)
goto error;
c->weak = true;
needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_WORKER)
&& (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO)
{
@ -3593,7 +3642,8 @@ cleanup:
(omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE)
#define OMP_ATOMIC_CLAUSES \
(omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \
| OMP_CLAUSE_MEMORDER)
| OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \
| OMP_CLAUSE_WEAK)
#define OMP_MASKED_CLAUSES \
(omp_mask (OMP_CLAUSE_FILTER))
#define OMP_ERROR_CLAUSES \
@ -5718,6 +5768,7 @@ gfc_match_omp_ordered_depend (void)
- capture
- memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed
- hint(hint-expr)
- OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak
*/
match
@ -5729,12 +5780,25 @@ gfc_match_omp_atomic (void)
if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES)
return MATCH_ERROR;
if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UNSET)
gfc_error ("OMP ATOMIC at %L with multiple atomic clauses", &loc);
if (c->atomic_op == GFC_OMP_ATOMIC_UNSET)
c->atomic_op = GFC_OMP_ATOMIC_UPDATE;
if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
"READ or WRITE", &loc, "CAPTURE");
if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
"READ or WRITE", &loc, "COMPARE");
if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE)
gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with "
"READ or WRITE", &loc, "FAIL");
if (c->weak && !c->compare)
{
gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc,
"WEAK", "COMPARE");
c->weak = false;
}
if (c->memorder == OMP_MEMORDER_UNSET)
{
gfc_namespace *prog_unit = gfc_current_ns;
@ -5765,32 +5829,24 @@ gfc_match_omp_atomic (void)
switch (c->atomic_op)
{
case GFC_OMP_ATOMIC_READ:
if (c->memorder == OMP_MEMORDER_ACQ_REL
|| c->memorder == OMP_MEMORDER_RELEASE)
if (c->memorder == OMP_MEMORDER_RELEASE)
{
gfc_error ("!$OMP ATOMIC READ at %L incompatible with "
"ACQ_REL or RELEASE clauses", &loc);
"RELEASE clause", &loc);
c->memorder = OMP_MEMORDER_SEQ_CST;
}
else if (c->memorder == OMP_MEMORDER_ACQ_REL)
c->memorder = OMP_MEMORDER_ACQUIRE;
break;
case GFC_OMP_ATOMIC_WRITE:
if (c->memorder == OMP_MEMORDER_ACQ_REL
|| c->memorder == OMP_MEMORDER_ACQUIRE)
if (c->memorder == OMP_MEMORDER_ACQUIRE)
{
gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with "
"ACQ_REL or ACQUIRE clauses", &loc);
c->memorder = OMP_MEMORDER_SEQ_CST;
}
break;
case GFC_OMP_ATOMIC_UPDATE:
if ((c->memorder == OMP_MEMORDER_ACQ_REL
|| c->memorder == OMP_MEMORDER_ACQUIRE)
&& !c->capture)
{
gfc_error ("!$OMP ATOMIC UPDATE at %L incompatible with "
"ACQ_REL or ACQUIRE clauses", &loc);
"ACQUIRE clause", &loc);
c->memorder = OMP_MEMORDER_SEQ_CST;
}
else if (c->memorder == OMP_MEMORDER_ACQ_REL)
c->memorder = OMP_MEMORDER_RELEASE;
break;
default:
break;
@ -7451,20 +7507,24 @@ expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se)
/* If EXPR is a conversion function that widens the type
if WIDENING is true or narrows the type if WIDENING is false,
if WIDENING is true or narrows the type if NARROW is true,
return the inner expression, otherwise return NULL. */
static gfc_expr *
is_conversion (gfc_expr *expr, bool widening)
is_conversion (gfc_expr *expr, bool narrowing, bool widening)
{
gfc_typespec *ts1, *ts2;
if (expr->expr_type != EXPR_FUNCTION
|| expr->value.function.isym == NULL
|| expr->value.function.esym != NULL
|| expr->value.function.isym->id != GFC_ISYM_CONVERSION)
|| expr->value.function.isym->id != GFC_ISYM_CONVERSION
|| (!narrowing && !widening))
return NULL;
if (narrowing && widening)
return expr->value.function.actual->expr;
if (widening)
{
ts1 = &expr->ts;
@ -7483,163 +7543,297 @@ is_conversion (gfc_expr *expr, bool widening)
return NULL;
}
static bool
is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
{
if (must_be_var
&& (expr->expr_type != EXPR_VARIABLE || !expr->symtree)
&& (!conv_ok || !is_conversion (expr, true, true)))
return false;
return (expr->rank == 0
&& !gfc_is_coindexed (expr)
&& (expr->ts.type != BT_INTEGER
|| expr->ts.type != BT_REAL
|| expr->ts.type != BT_COMPLEX
|| expr->ts.type != BT_LOGICAL));
}
static void
resolve_omp_atomic (gfc_code *code)
{
gfc_code *atomic_code = code->block;
gfc_symbol *var;
gfc_expr *expr2, *expr2_tmp;
gfc_expr *stmt_expr2, *capt_expr2;
gfc_omp_atomic_op aop
= (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
& GFC_OMP_ATOMIC_MASK);
gfc_code *stmt = NULL, *capture_stmt = NULL;
gfc_expr *comp_cond = NULL;
locus *loc = NULL;
code = code->block->next;
/* resolve_blocks asserts this is initially EXEC_ASSIGN.
/* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF
If it changed to EXEC_NOP, assume an error has been emitted already. */
if (code->op == EXEC_NOP)
if (code->op == EXEC_NOP /* FIXME: || (code->next && code->next->op == EXEC_NOP)*/)
return;
if (code->op != EXEC_ASSIGN)
if (code->op == EXEC_IF && code->block->op == EXEC_IF)
comp_cond = code->block->expr1;
if (atomic_code->ext.omp_clauses->compare
&& atomic_code->ext.omp_clauses->capture)
{
unexpected:
gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc);
return;
}
if (!atomic_code->ext.omp_clauses->capture)
{
if (code->next != NULL)
goto unexpected;
}
else
{
if (code->next == NULL)
goto unexpected;
if (code->next->op == EXEC_NOP)
return;
if (code->next->op != EXEC_ASSIGN || code->next->next)
/* Must be either "if (x == e) then; x = d; else; v = x; end if"
or "v = expr" followed/preceded by
"if (x == e) then; x = d; end if" or "if (x == e) x = d". */
gfc_code *next = code;
if (code->op == EXEC_ASSIGN)
{
code = code->next;
capture_stmt = code;
next = code->next;
}
if (next->op == EXEC_IF
&& next->block
&& next->block->op == EXEC_IF
&& next->block->next->op == EXEC_ASSIGN)
{
stmt = next->block->next;
if (stmt->next)
{
loc = &stmt->loc;
goto unexpected;
}
}
if (stmt && !capture_stmt && next->block->block)
{
if (next->block->block->expr1)
gfc_error ("Expected ELSE at %L in atomic compare capture",
&next->block->block->expr1->where);
if (!code->block->block->next
|| code->block->block->next->op != EXEC_ASSIGN)
{
loc = (code->block->block->next ? &code->block->block->next->loc
: &code->block->block->loc);
goto unexpected;
}
capture_stmt = code->block->block->next;
if (capture_stmt->next)
{
loc = &capture_stmt->next->loc;
goto unexpected;
}
}
if (stmt && !capture_stmt && code->op == EXEC_ASSIGN)
{
capture_stmt = code;
}
else if (!capture_stmt)
{
loc = &code->loc;
goto unexpected;
}
}
else if (atomic_code->ext.omp_clauses->compare)
{
/* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */
if (code->op == EXEC_IF
&& code->block
&& code->block->op == EXEC_IF
&& code->block->next->op == EXEC_ASSIGN)
{
stmt = code->block->next;
if (stmt->next || code->block->block)
{
loc = stmt->next ? &stmt->next->loc : &code->block->block->loc;
goto unexpected;
}
}
else
{
loc = &code->loc;
goto unexpected;
}
}
else if (atomic_code->ext.omp_clauses->capture)
{
/* Must be: "v = x" followed/preceded by "x = ...". */
if (code->op != EXEC_ASSIGN)
goto unexpected;
if (code->next->op != EXEC_ASSIGN)
{
loc = &code->next->loc;
goto unexpected;
}
gfc_expr *expr2, *expr2_next;
expr2 = is_conversion (code->expr2, true, true);
if (expr2 == NULL)
expr2 = code->expr2;
expr2_next = is_conversion (code->next->expr2, true, true);
if (expr2_next == NULL)
expr2_next = code->next->expr2;
if (code->expr1->expr_type == EXPR_VARIABLE
&& code->next->expr1->expr_type == EXPR_VARIABLE
&& expr2->expr_type == EXPR_VARIABLE
&& expr2_next->expr_type == EXPR_VARIABLE)
{
if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym)
{
stmt = code;
capture_stmt = code->next;
}
else
{
capture_stmt = code;
stmt = code->next;
}
}
else if (expr2->expr_type == EXPR_VARIABLE)
{
capture_stmt = code;
stmt = code->next;
}
else
{
stmt = code;
capture_stmt = code->next;
}
gcc_assert (!code->next->next);
}
else
{
/* x = ... */
stmt = code;
if ((!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
|| (atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_IF))
goto unexpected;
gcc_assert (!code->next);
}
if (code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->symtree == NULL
|| code->expr1->rank != 0
|| (code->expr1->ts.type != BT_INTEGER
&& code->expr1->ts.type != BT_REAL
&& code->expr1->ts.type != BT_COMPLEX
&& code->expr1->ts.type != BT_LOGICAL))
if (comp_cond)
{
if (comp_cond->expr_type != EXPR_OP
|| (comp_cond->value.op.op != INTRINSIC_EQ
&& comp_cond->value.op.op != INTRINSIC_EQ_OS
&& comp_cond->value.op.op != INTRINSIC_EQV))
{
gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison "
"expression at %L", &comp_cond->where);
return;
}
if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, false))
{
gfc_error ("Expected scalar intrinsic variable at %L in atomic "
"comparison", &comp_cond->value.op.op1->where);
return;
}
if (!gfc_resolve_expr (comp_cond->value.op.op2))
return;
if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false))
{
gfc_error ("Expected scalar intrinsic expression at %L in atomic "
"comparison", &comp_cond->value.op.op1->where);
return;
}
}
if (!is_scalar_intrinsic_expr (stmt->expr1, true, false))
{
gfc_error ("!$OMP ATOMIC statement must set a scalar variable of "
"intrinsic type at %L", &code->loc);
"intrinsic type at %L", &stmt->expr1->where);
return;
}
var = code->expr1->symtree->n.sym;
expr2 = is_conversion (code->expr2, false);
if (expr2 == NULL)
if (!gfc_resolve_expr (stmt->expr2))
return;
if (!is_scalar_intrinsic_expr (stmt->expr2, false, false))
{
if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
expr2 = is_conversion (code->expr2, true);
if (expr2 == NULL)
expr2 = code->expr2;
gfc_error ("!$OMP ATOMIC statement must assign an expression of "
"intrinsic type at %L", &stmt->expr2->where);
return;
}
if (gfc_expr_attr (stmt->expr1).allocatable)
{
gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
&stmt->expr1->where);
return;
}
var = stmt->expr1->symtree->n.sym;
stmt_expr2 = is_conversion (stmt->expr2, true, true);
if (stmt_expr2 == NULL)
stmt_expr2 = stmt->expr2;
switch (aop)
{
case GFC_OMP_ATOMIC_READ:
if (expr2->expr_type != EXPR_VARIABLE
|| expr2->symtree == NULL
|| expr2->rank != 0
|| (expr2->ts.type != BT_INTEGER
&& expr2->ts.type != BT_REAL
&& expr2->ts.type != BT_COMPLEX
&& expr2->ts.type != BT_LOGICAL))
if (stmt_expr2->expr_type != EXPR_VARIABLE)
gfc_error ("!$OMP ATOMIC READ statement must read from a scalar "
"variable of intrinsic type at %L", &expr2->where);
"variable of intrinsic type at %L", &stmt_expr2->where);
return;
case GFC_OMP_ATOMIC_WRITE:
if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL))
if (expr_references_sym (stmt_expr2, var, NULL))
gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr "
"must be scalar and cannot reference var at %L",
&expr2->where);
&stmt_expr2->where);
return;
default:
break;
}
if (atomic_code->ext.omp_clauses->capture)
{
expr2_tmp = expr2;
if (expr2 == code->expr2)
{
expr2_tmp = is_conversion (code->expr2, true);
if (expr2_tmp == NULL)
expr2_tmp = expr2;
}
if (expr2_tmp->expr_type == EXPR_VARIABLE)
{
if (expr2_tmp->symtree == NULL
|| expr2_tmp->rank != 0
|| (expr2_tmp->ts.type != BT_INTEGER
&& expr2_tmp->ts.type != BT_REAL
&& expr2_tmp->ts.type != BT_COMPLEX
&& expr2_tmp->ts.type != BT_LOGICAL)
|| expr2_tmp->symtree->n.sym == var)
{
gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from "
"a scalar variable of intrinsic type at %L",
&expr2_tmp->where);
return;
}
var = expr2_tmp->symtree->n.sym;
code = code->next;
if (code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->symtree == NULL
|| code->expr1->rank != 0
|| (code->expr1->ts.type != BT_INTEGER
&& code->expr1->ts.type != BT_REAL
&& code->expr1->ts.type != BT_COMPLEX
&& code->expr1->ts.type != BT_LOGICAL))
{
gfc_error ("!$OMP ATOMIC CAPTURE update statement must set "
"a scalar variable of intrinsic type at %L",
&code->expr1->where);
return;
}
if (code->expr1->symtree->n.sym != var)
{
gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
"different variable than update statement writes "
"into at %L", &code->expr1->where);
return;
}
expr2 = is_conversion (code->expr2, false);
if (expr2 == NULL)
expr2 = code->expr2;
}
}
if (gfc_expr_attr (code->expr1).allocatable)
if (atomic_code->ext.omp_clauses->compare
&& !atomic_code->ext.omp_clauses->capture)
{
gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
&code->loc);
gfc_error ("Sorry, COMPARE clause in ATOMIC at %L is not yet "
"supported", &atomic_code->loc);
return;
}
if (atomic_code->ext.omp_clauses->capture)
{
if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false))
{
gfc_error ("!$OMP ATOMIC capture-statement must set a scalar "
"variable of intrinsic type at %L",
&capture_stmt->expr1->where);
return;
}
if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true))
{
gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable"
" of intrinsic type at %L", &capture_stmt->expr2->where);
return;
}
capt_expr2 = is_conversion (capture_stmt->expr2, true, true);
if (capt_expr2 == NULL)
capt_expr2 = capture_stmt->expr2;
if (capt_expr2->symtree->n.sym != var)
{
gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
"different variable than update statement writes "
"into at %L", &capture_stmt->expr2->where);
return;
}
}
if (atomic_code->ext.omp_clauses->capture
&& code->next == NULL
&& code->expr2->rank == 0
&& !expr_references_sym (code->expr2, var, NULL))
&& !expr_references_sym (stmt_expr2, var, NULL))
atomic_code->ext.omp_clauses->atomic_op
= (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op
| GFC_OMP_ATOMIC_SWAP);
else if (expr2->expr_type == EXPR_OP)
else if (stmt_expr2->expr_type == EXPR_OP)
{
gfc_expr *v = NULL, *e, *c;
gfc_intrinsic_op op = expr2->value.op.op;
gfc_intrinsic_op op = stmt_expr2->value.op.op;
gfc_intrinsic_op alt_op = INTRINSIC_NONE;
if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET
&& !atomic_code->ext.omp_clauses->compare)
gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either"
" the COMPARE clause or using the intrinsic MIN/MAX "
"procedure", &atomic_code->loc);
switch (op)
{
case INTRINSIC_PLUS:
@ -7666,7 +7860,7 @@ resolve_omp_atomic (gfc_code *code)
default:
gfc_error ("!$OMP ATOMIC assignment operator must be binary "
"+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L",
&expr2->where);
&stmt_expr2->where);
return;
}
@ -7676,12 +7870,12 @@ resolve_omp_atomic (gfc_code *code)
(expr) op var. We rely here on the fact that the matcher
for x op1 y op2 z where op1 and op2 have equal precedence
returns (x op1 y) op2 z. */
e = expr2->value.op.op2;
e = stmt_expr2->value.op.op2;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
v = e;
else if ((c = is_conversion (e, true)) != NULL
else if ((c = is_conversion (e, false, true)) != NULL
&& c->expr_type == EXPR_VARIABLE
&& c->symtree != NULL
&& c->symtree->n.sym == var)
@ -7689,7 +7883,7 @@ resolve_omp_atomic (gfc_code *code)
else
{
gfc_expr **p = NULL, **q;
for (q = &expr2->value.op.op1; (e = *q) != NULL; )
for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; )
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
@ -7697,7 +7891,7 @@ resolve_omp_atomic (gfc_code *code)
v = e;
break;
}
else if ((c = is_conversion (e, true)) != NULL)
else if ((c = is_conversion (e, false, true)) != NULL)
q = &e->value.function.actual->expr;
else if (e->expr_type != EXPR_OP
|| (e->value.op.op != op
@ -7713,7 +7907,7 @@ resolve_omp_atomic (gfc_code *code)
if (v == NULL)
{
gfc_error ("!$OMP ATOMIC assignment must be var = var op expr "
"or var = expr op var at %L", &expr2->where);
"or var = expr op var at %L", &stmt_expr2->where);
return;
}
@ -7728,7 +7922,7 @@ resolve_omp_atomic (gfc_code *code)
case INTRINSIC_NEQV:
gfc_error ("!$OMP ATOMIC var = var op expr not "
"mathematically equivalent to var = var op "
"(expr) at %L", &expr2->where);
"(expr) at %L", &stmt_expr2->where);
break;
default:
break;
@ -7736,43 +7930,44 @@ resolve_omp_atomic (gfc_code *code)
/* Canonicalize into var = var op (expr). */
*p = e->value.op.op2;
e->value.op.op2 = expr2;
e->ts = expr2->ts;
if (code->expr2 == expr2)
code->expr2 = expr2 = e;
e->value.op.op2 = stmt_expr2;
e->ts = stmt_expr2->ts;
if (stmt->expr2 == stmt_expr2)
stmt->expr2 = stmt_expr2 = e;
else
code->expr2->value.function.actual->expr = expr2 = e;
stmt->expr2->value.function.actual->expr = stmt_expr2 = e;
if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts))
if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts,
&stmt_expr2->ts))
{
for (p = &expr2->value.op.op1; *p != v;
for (p = &stmt_expr2->value.op.op1; *p != v;
p = &(*p)->value.function.actual->expr)
;
*p = NULL;
gfc_free_expr (expr2->value.op.op1);
expr2->value.op.op1 = v;
gfc_convert_type (v, &expr2->ts, 2);
gfc_free_expr (stmt_expr2->value.op.op1);
stmt_expr2->value.op.op1 = v;
gfc_convert_type (v, &stmt_expr2->ts, 2);
}
}
}
if (e->rank != 0 || expr_references_sym (code->expr2, var, v))
if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v))
{
gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr "
"must be scalar and cannot reference var at %L",
&expr2->where);
&stmt_expr2->where);
return;
}
}
else if (expr2->expr_type == EXPR_FUNCTION
&& expr2->value.function.isym != NULL
&& expr2->value.function.esym == NULL
&& expr2->value.function.actual != NULL
&& expr2->value.function.actual->next != NULL)
else if (stmt_expr2->expr_type == EXPR_FUNCTION
&& stmt_expr2->value.function.isym != NULL
&& stmt_expr2->value.function.esym == NULL
&& stmt_expr2->value.function.actual != NULL
&& stmt_expr2->value.function.actual->next != NULL)
{
gfc_actual_arglist *arg, *var_arg;
switch (expr2->value.function.isym->id)
switch (stmt_expr2->value.function.isym->id)
{
case GFC_ISYM_MIN:
case GFC_ISYM_MAX:
@ -7780,31 +7975,37 @@ resolve_omp_atomic (gfc_code *code)
case GFC_ISYM_IAND:
case GFC_ISYM_IOR:
case GFC_ISYM_IEOR:
if (expr2->value.function.actual->next->next != NULL)
if (stmt_expr2->value.function.actual->next->next != NULL)
{
gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR "
"or IEOR must have two arguments at %L",
&expr2->where);
&stmt_expr2->where);
return;
}
break;
default:
gfc_error ("!$OMP ATOMIC assignment intrinsic must be "
"MIN, MAX, IAND, IOR or IEOR at %L",
&expr2->where);
&stmt_expr2->where);
return;
}
var_arg = NULL;
for (arg = expr2->value.function.actual; arg; arg = arg->next)
for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next)
{
if ((arg == expr2->value.function.actual
|| (var_arg == NULL && arg->next == NULL))
&& arg->expr->expr_type == EXPR_VARIABLE
&& arg->expr->symtree != NULL
&& arg->expr->symtree->n.sym == var)
var_arg = arg;
else if (expr_references_sym (arg->expr, var, NULL))
gfc_expr *e = NULL;
if (arg == stmt_expr2->value.function.actual
|| (var_arg == NULL && arg->next == NULL))
{
e = is_conversion (arg->expr, false, true);
if (!e)
e = arg->expr;
if (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var)
var_arg = arg;
}
if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL))
{
gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
"not reference %qs at %L",
@ -7822,72 +8023,35 @@ resolve_omp_atomic (gfc_code *code)
if (var_arg == NULL)
{
gfc_error ("First or last !$OMP ATOMIC intrinsic argument must "
"be %qs at %L", var->name, &expr2->where);
"be %qs at %L", var->name, &stmt_expr2->where);
return;
}
if (var_arg != expr2->value.function.actual)
if (var_arg != stmt_expr2->value.function.actual)
{
/* Canonicalize, so that var comes first. */
gcc_assert (var_arg->next == NULL);
for (arg = expr2->value.function.actual;
for (arg = stmt_expr2->value.function.actual;
arg->next != var_arg; arg = arg->next)
;
var_arg->next = expr2->value.function.actual;
expr2->value.function.actual = var_arg;
var_arg->next = stmt_expr2->value.function.actual;
stmt_expr2->value.function.actual = var_arg;
arg->next = NULL;
}
}
else
gfc_error ("!$OMP ATOMIC assignment must have an operator or "
"intrinsic on right hand side at %L", &expr2->where);
"intrinsic on right hand side at %L", &stmt_expr2->where);
if (atomic_code->ext.omp_clauses->capture && code->next)
{
code = code->next;
if (code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->symtree == NULL
|| code->expr1->rank != 0
|| (code->expr1->ts.type != BT_INTEGER
&& code->expr1->ts.type != BT_REAL
&& code->expr1->ts.type != BT_COMPLEX
&& code->expr1->ts.type != BT_LOGICAL))
{
gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set "
"a scalar variable of intrinsic type at %L",
&code->expr1->where);
return;
}
if (atomic_code->ext.omp_clauses->compare)
gfc_error ("Sorry, COMPARE clause in ATOMIC at %L is not yet "
"supported", &atomic_code->loc);
return;
expr2 = is_conversion (code->expr2, false);
if (expr2 == NULL)
{
expr2 = is_conversion (code->expr2, true);
if (expr2 == NULL)
expr2 = code->expr2;
}
if (expr2->expr_type != EXPR_VARIABLE
|| expr2->symtree == NULL
|| expr2->rank != 0
|| (expr2->ts.type != BT_INTEGER
&& expr2->ts.type != BT_REAL
&& expr2->ts.type != BT_COMPLEX
&& expr2->ts.type != BT_LOGICAL))
{
gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read "
"from a scalar variable of intrinsic type at %L",
&expr2->where);
return;
}
if (expr2->symtree->n.sym != var)
{
gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from "
"different variable than update statement writes "
"into at %L", &expr2->where);
return;
}
}
unexpected:
gfc_error ("unexpected !$OMP ATOMIC expression at %L",
loc ? loc : &code->loc);
return;
}

19
gcc/fortran/parse.c
View file

@ -5313,7 +5313,22 @@ parse_omp_oacc_atomic (bool omp_p)
st = next_statement ();
if (st == ST_NONE)
unexpected_eof ();
else if (st == ST_ASSIGNMENT)
else if (np->ext.omp_clauses->compare
&& (st == ST_SIMPLE_IF || st == ST_IF_BLOCK))
{
count--;
if (st == ST_IF_BLOCK)
{
parse_if_block ();
/* With else (or elseif). */
if (gfc_state_stack->tail->block->block)
count--;
}
accept_statement (st);
}
else if (st == ST_ASSIGNMENT
&& (!np->ext.omp_clauses->compare
|| np->ext.omp_clauses->capture))
{
accept_statement (st);
count--;
@ -5332,8 +5347,6 @@ parse_omp_oacc_atomic (bool omp_p)
gfc_warning_check ();
st = next_statement ();
}
else if (np->ext.omp_clauses->capture)
gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
return st;
}

9
gcc/fortran/resolve.c
View file

@ -10849,13 +10849,8 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
/* Verify this before calling gfc_resolve_code, which might
change it. */
gcc_assert (b->next && b->next->op == EXEC_ASSIGN);
gcc_assert ((!b->ext.omp_clauses->capture
&& b->next->next == NULL)
|| (b->ext.omp_clauses->capture
&& b->next->next != NULL
&& b->next->next->op == EXEC_ASSIGN
&& b->next->next->next == NULL));
gcc_assert (b->op == EXEC_OMP_ATOMIC
|| (b->next && b->next->op == EXEC_ASSIGN));
}
break;

13
gcc/fortran/trans-openmp.c
View file

@ -4492,7 +4492,7 @@ gfc_trans_omp_atomic (gfc_code *code)
enum tree_code op = ERROR_MARK;
enum tree_code aop = OMP_ATOMIC;
bool var_on_left = false;
enum omp_memory_order mo;
enum omp_memory_order mo, fail_mo;
switch (atomic_code->ext.omp_clauses->memorder)
{
case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break;
@ -4503,6 +4503,15 @@ gfc_trans_omp_atomic (gfc_code *code)
case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break;
default: gcc_unreachable ();
}
switch (atomic_code->ext.omp_clauses->fail)
{
case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break;
case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break;
case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break;
case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
default: gcc_unreachable ();
}
mo = (omp_memory_order) (mo | fail_mo);
code = code->block->next;
gcc_assert (code->op == EXEC_ASSIGN);
@ -4733,6 +4742,7 @@ gfc_trans_omp_atomic (gfc_code *code)
{
x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
OMP_ATOMIC_MEMORY_ORDER (x) = mo;
OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
gfc_add_expr_to_block (&block, x);
}
else
@ -4756,6 +4766,7 @@ gfc_trans_omp_atomic (gfc_code *code)
}
x = build2 (aop, type, lhsaddr, convert (type, x));
OMP_ATOMIC_MEMORY_ORDER (x) = mo;
OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak;
x = convert (TREE_TYPE (vse.expr), x);
gfc_add_modify (&block, vse.expr, x);
}

32
gcc/testsuite/gfortran.dg/gomp/atomic-10.f90 Normal file
View file

@ -0,0 +1,32 @@
! PR middle-end/28046 for the original C tet.
! { dg-do compile }
! { dg-options "-fopenmp -fdump-tree-ompexp" }
! { dg-require-effective-target cas_int }
module m
implicit none
integer a(3), b
type t_C
integer :: x, y
end type
type(t_C) :: c
interface
integer function bar(); end
integer function baz(); end
end interface
pointer :: baz
contains
subroutine foo
!$omp atomic
a(2) = a(2) + bar ()
!$omp atomic
b = b + bar ()
!$omp atomic
c%y = c%y + bar ()
!$omp atomic
b = b + baz ()
end
end module
! { dg-final { scan-tree-dump-times "__atomic_fetch_add" 4 "ompexp" } }

364
gcc/testsuite/gfortran.dg/gomp/atomic-12.f90 Normal file
View file

@ -0,0 +1,364 @@
! PR middle-end/45423 - for the original C/C++ testcase
! { dg-do compile }
! { dg-options "-fopenmp -fdump-tree-gimple -g0 -Wno-deprecated" }
! atomicvar should never be referenced in between the barrier and
! following #pragma omp atomic_load.
! { dg-final { scan-tree-dump-not "barrier\[^#\]*atomicvar" "gimple" } }
module m
implicit none
logical :: atomicvar, c
integer :: i, atomicvar2, c2
contains
integer function foo ()
!$omp barrier
!$omp atomic
atomicvar = atomicvar .or. .true.
!$omp barrier
!$omp atomic
atomicvar = atomicvar .or. .false.
!$omp barrier
!$omp atomic
atomicvar = atomicvar .or. c
!$omp barrier
!$omp atomic
atomicvar = atomicvar .and. .true.
!$omp barrier
!$omp atomic
atomicvar = atomicvar .and. .false.
!$omp barrier
!$omp atomic
atomicvar = atomicvar .and. c
!$omp barrier
!$omp atomic
atomicvar = atomicvar .neqv. .true.
!$omp barrier
!$omp atomic
atomicvar = atomicvar .neqv. .false.
!$omp barrier
!$omp atomic
atomicvar = atomicvar .neqv. c
!$omp barrier
!$omp atomic
atomicvar = atomicvar .eqv. .true.
!$omp barrier
!$omp atomic
atomicvar = atomicvar .eqv. .false.
!$omp barrier
!$omp atomic
atomicvar = atomicvar .eqv. c
!$omp barrier
!$omp atomic
atomicvar = .true. .or. atomicvar
!$omp barrier
!$omp atomic
atomicvar = .false. .or. atomicvar
!$omp barrier
!$omp atomic
atomicvar = c .or. atomicvar
!$omp barrier
!$omp atomic
atomicvar = .true. .and. atomicvar
!$omp barrier
!$omp atomic
atomicvar = .false. .and. atomicvar
!$omp barrier
!$omp atomic
atomicvar = c .and. atomicvar
!$omp barrier
!$omp atomic
atomicvar = .true. .neqv. atomicvar
!$omp barrier
!$omp atomic
atomicvar = .false. .neqv. atomicvar
!$omp barrier
!$omp atomic
atomicvar = c .neqv. atomicvar
!$omp barrier
!$omp atomic
atomicvar = .true. .eqv. atomicvar
!$omp barrier
!$omp atomic
atomicvar = .false. .eqv. atomicvar
!$omp barrier
!$omp atomic
atomicvar = c .eqv. atomicvar
!$omp barrier
foo = 0
end
integer function bar ()
!$omp barrier
!$omp atomic
atomicvar2 = ior (atomicvar2, -1)
!$omp barrier
!$omp atomic
atomicvar2 = ior (atomicvar2, 0)
!$omp barrier
!$omp atomic
atomicvar2 = ior (atomicvar2, 1)
!$omp barrier
!$omp atomic
atomicvar2 = ior (atomicvar2, 2)
!$omp barrier
!$omp atomic
atomicvar2 = ior (atomicvar2, c2)
!$omp barrier
!$omp atomic
atomicvar2 = ior (-1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ior (0, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ior (1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ior (2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ior (c2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ieor (atomicvar2, -1)
!$omp barrier
!$omp atomic
atomicvar2 = ieor (atomicvar2, 0)
!$omp barrier
!$omp atomic
atomicvar2 = ieor (atomicvar2, 1)
!$omp barrier
!$omp atomic
atomicvar2 = ieor (atomicvar2, 2)
!$omp barrier
!$omp atomic
atomicvar2 = ieor (atomicvar2, c2)
!$omp barrier
!$omp atomic
atomicvar2 = ieor (-1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ieor (0, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ieor (1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ior (2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = ior (c2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = iand (atomicvar2, -1)
!$omp barrier
!$omp atomic
atomicvar2 = iand (atomicvar2, 0)
!$omp barrier
!$omp atomic
atomicvar2 = iand (atomicvar2, 1)
!$omp barrier
!$omp atomic
atomicvar2 = iand (atomicvar2, 2)
!$omp barrier
!$omp atomic
atomicvar2 = iand (atomicvar2, c2)
!$omp barrier
!$omp atomic
atomicvar2 = iand (-1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = iand (0, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = iand (1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = iand (2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = iand (c2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = min (atomicvar2, -1)
!$omp barrier
!$omp atomic
atomicvar2 = min (atomicvar2, 0)
!$omp barrier
!$omp atomic
atomicvar2 = min (atomicvar2, 1)
!$omp barrier
!$omp atomic
atomicvar2 = min (atomicvar2, 2)
!$omp barrier
!$omp atomic
atomicvar2 = min (atomicvar2, c2)
!$omp barrier
!$omp atomic
atomicvar2 = min (-1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = min (0, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = min (1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = min (2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = min (c2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = max (atomicvar2, -1)
!$omp barrier
!$omp atomic
atomicvar2 = max (atomicvar2, 0)
!$omp barrier
!$omp atomic
atomicvar2 = max (atomicvar2, 1)
!$omp barrier
!$omp atomic
atomicvar2 = max (atomicvar2, 2)
!$omp barrier
!$omp atomic
atomicvar2 = max (atomicvar2, c2)
!$omp barrier
!$omp atomic
atomicvar2 = max (-1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = max (0, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = max (1, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = max (2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = max (c2, atomicvar2)
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 + (-1)
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 + 0
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 + 1
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 + 2
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 + c2
!$omp barrier
!$omp atomic
atomicvar2 = -1 + atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 0 + atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 1 + atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 2 + atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = c2 + atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 - (-1)
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 - 0
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 - 1
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 - 2
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 - c2
!$omp barrier
!$omp atomic
atomicvar2 = -1 - atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 0 - atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 1 - atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 2 - atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = c2 - atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 * (-1)
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 * 0
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 * 1
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 * 2
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 * c2
!$omp barrier
!$omp atomic
atomicvar2 = (-1) * atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 0 * atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 1 * atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 2 * atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = c2 * atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 / (-1)
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 / 0
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 / 1
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 / 2
!$omp barrier
!$omp atomic
atomicvar2 = atomicvar2 / c2
!$omp barrier
!$omp atomic
atomicvar2 = (-1) / atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 0 / atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 1 / atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = 2 / atomicvar2
!$omp barrier
!$omp atomic
atomicvar2 = c2 / atomicvar2
!$omp barrier
bar = 0
end
end module

44
gcc/testsuite/gfortran.dg/gomp/atomic-15.f90 Normal file
View file

@ -0,0 +1,44 @@
! { dg-do compile }
! { dg-options "-fopenmp" }
module m
implicit none
integer :: x = 6
end module m
program main
use m
implicit none
integer v
!$omp atomic
x = x * 7 + 6 ! { dg-error "assignment must be var = var op expr or var = expr op var" }
!$omp atomic
x = ieor (x * 7, 6) ! { dg-error "intrinsic arguments except one must not reference 'x'" }
!$omp atomic update
x = x - 8 + 6 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
!$omp atomic
x = ior (ieor (x, 7), 2) ! { dg-error "intrinsic arguments except one must not reference 'x'" }
!$omp atomic
x = x / 7 * 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
!$omp atomic
x = x / 7 / 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
!$omp atomic capture
v = x; x = x * 7 + 6 ! { dg-error "assignment must be var = var op expr or var = expr op var" }
!$omp atomic capture
v = x; x = ieor(x * 7, 6) ! { dg-error "intrinsic arguments except one must not reference 'x'" }
!$omp atomic capture
v = x; x = x - 8 + 6 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
!$omp atomic capture
v = x; x = ior (ieor(x, 7), 2) ! { dg-error "intrinsic arguments except one must not reference 'x'" }
!$omp atomic capture
v = x; x = x / 7 * 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
!$omp atomic capture
v = x; x = x / 7 / 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
!$omp atomic capture
x = x * 7 + 6; v = x ! { dg-error "assignment must be var = var op expr or var = expr op var" }
!$omp atomic capture
x = ieor(x * 7, 6); v = x ! { dg-error "intrinsic arguments except one must not reference 'x'" }
!$omp atomic capture
x = x - 8 + 6; v = x ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" }
!$omp atomic capture
x = ior(ieor(x, 7), 2); v = x ! { dg-error "intrinsic arguments except one must not reference 'x'" }
end

36
gcc/testsuite/gfortran.dg/gomp/atomic-16.f90 Normal file
View file

@ -0,0 +1,36 @@
! { dg-do compile }
! { dg-options "-fopenmp" }
module m
implicit none
integer :: x = 6
contains
subroutine foo ()
integer v
!$omp atomic seq_cst read
v = x
!$omp atomic seq_cst, read
v = x
!$omp atomic seq_cst write
x = v
!$omp atomic seq_cst ,write
x = v
!$omp atomic seq_cst update
x = x + v;
!$omp atomic seq_cst , update
x = v + x;
!$omp atomic seq_cst capture
v = x; x = x + 2;
!$omp atomic seq_cst, capture
v = x; x = 2 + x;
!$omp atomic read , seq_cst
v = x
!$omp atomic write ,seq_cst
x = v
!$omp atomic update, seq_cst
x = x + v
!$omp atomic capture, seq_cst
x = x + 2; v = x
end
end module m

41
gcc/testsuite/gfortran.dg/gomp/atomic-17.f90 Normal file
View file

@ -0,0 +1,41 @@
module m
implicit none
integer i, v
real f
contains
subroutine foo ()
!$omp atomic release, hint (0), update
i = i + 1
!$omp atomic hint(0)seq_cst
i = i + 1
!$omp atomic relaxed,update,hint (0)
i = i + 1
!$omp atomic release
i = i + 1
!$omp atomic relaxed
i = i + 1
!$omp atomic acq_rel capture
i = i + 1; v = i
!$omp atomic capture,acq_rel , hint (1)
i = i + 1; v = i
!$omp atomic hint(0),acquire capture
i = i + 1; v = i
!$omp atomic read acquire
v = i
!$omp atomic acq_rel read
v = i
!$omp atomic release,write
i = v
!$omp atomic write,acq_rel
i = v
!$omp atomic hint(1),update,release
f = f + 2.0
!$omp atomic update ,acquire
i = i + 1
!$omp atomic acq_rel update
i = i + 1
!$omp atomic acq_rel,hint(0)
i = i + 1
end
end module

27
gcc/testsuite/gfortran.dg/gomp/atomic-18.f90 Normal file
View file

@ -0,0 +1,27 @@
module m
implicit none
integer i, v
real f
contains
subroutine foo (j)
integer, value :: j
!$omp atomic update,update ! { dg-error "Duplicated atomic clause: unexpected update clause" }
i = i + 1
!$omp atomic seq_cst release ! { dg-error "Duplicated memory-order clause: unexpected release clause" }
i = i + 1
!$omp atomic read,release ! { dg-error "ATOMIC READ at .1. incompatible with RELEASE clause" }
v = i
!$omp atomic acquire , write ! { dg-error "ATOMIC WRITE at .1. incompatible with ACQUIRE clause" }
i = v
!$omp atomic capture hint (0) capture ! { dg-error "Duplicated 'capture' clause" }
v = i = i + 1
!$omp atomic hint(j + 2) ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" }
i = i + 1
!$omp atomic hint(f)
! { dg-error "HINT clause at .1. requires a scalar INTEGER expression" "" { target *-*-* } .-1 }
! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" "" { target *-*-* } .-2 }
i = i + 1
!$omp atomic foobar ! { dg-error "Failed to match clause" }
i = i + 1
end
end module

39
gcc/testsuite/gfortran.dg/gomp/atomic-19.f90 Normal file
View file

@ -0,0 +1,39 @@
! { dg-do compile }
! { dg-additional-options "-fdump-tree-original" }
! { dg-final { scan-tree-dump-times "omp atomic release" 1 "original" } }
! { dg-final { scan-tree-dump-times "omp atomic relaxed" 3 "original" } }
! { dg-final { scan-tree-dump-times "omp atomic read relaxed" 1 "original" } }
! { dg-final { scan-tree-dump-times "omp atomic capture relaxed" 1 "original" } }
module mod
implicit none
integer i, j, k, l, m, n
contains
subroutine foo ()
!$omp atomic release
i = i + 1;
end
end
module m2
use mod
implicit none
!$omp requires atomic_default_mem_order (relaxed)
contains
subroutine bar ()
integer v;
!$omp atomic
j = j + 1
!$omp atomic update
k = k + 1
!$omp atomic read
v = l
!$omp atomic write
m = v
!$omp atomic capture
n = n + 1; v = n
end
end module m2

42
gcc/testsuite/gfortran.dg/gomp/atomic-2.f90
View file

@ -3,13 +3,13 @@
subroutine bar
integer :: i, v
real :: f
!$omp atomic update acq_rel hint("abc") ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" }
!$omp atomic update acq_rel hint("abc")
! { dg-error "HINT clause at .1. requires a scalar INTEGER expression" "" { target *-*-* } .-1 }
! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" "" { target *-*-* } .-2 }
i = i + 1
!$omp end atomic
!$omp atomic acq_rel ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" }
!$omp atomic acq_rel
i = i + 1
!$omp end atomic
@ -18,7 +18,7 @@ subroutine bar
v = i
!$omp end atomic
!$omp atomic acq_rel , hint (1), update ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" }
!$omp atomic acq_rel , hint (1), update
i = i + 1
!$omp end atomic
@ -27,44 +27,10 @@ subroutine bar
v = i
!$omp end atomic
!$omp atomic write capture ! { dg-error "multiple atomic clauses" }
!$omp atomic write capture ! { dg-error "with CAPTURE clause is incompatible with READ or WRITE" }
i = 2
v = i
!$omp end atomic
!$omp atomic foobar ! { dg-error "Failed to match clause" }
end
! moved here from atomic.f90
subroutine openmp51_foo
integer :: x, v
!$omp atomic update seq_cst capture ! { dg-error "multiple atomic clauses" }
x = x + 2
v = x
!$omp end atomic
!$omp atomic seq_cst, capture, update ! { dg-error "multiple atomic clauses" }
x = x + 2
v = x
!$omp end atomic
!$omp atomic capture, seq_cst ,update ! { dg-error "multiple atomic clauses" }
x = x + 2
v = x
!$omp end atomic
end
subroutine openmp51_bar
integer :: i, v
real :: f
!$omp atomic relaxed capture update ! { dg-error "multiple atomic clauses" }
i = i + 1
v = i
!$omp end atomic
!$omp atomic update capture,release , hint (1) ! { dg-error "multiple atomic clauses" }
i = i + 1
v = i
!$omp end atomic
!$omp atomic hint(0),update relaxed capture ! { dg-error "multiple atomic clauses" }
i = i + 1
v = i
!$omp end atomic
end

39
gcc/testsuite/gfortran.dg/gomp/atomic-20.f90 Normal file
View file

@ -0,0 +1,39 @@
! { dg-do compile }
! { dg-additional-options "-fdump-tree-original" }
! { dg-final { scan-tree-dump-times "omp atomic release" 1 "original" } }
! { dg-final { scan-tree-dump-times "omp atomic seq_cst" 3 "original" } }
! { dg-final { scan-tree-dump-times "omp atomic read seq_cst" 1 "original" } }
! { dg-final { scan-tree-dump-times "omp atomic capture seq_cst" 1 "original" } }
module mod
implicit none
integer i, j, k, l, m, n
contains
subroutine foo ()
!$omp atomic release
i = i + 1
end
end module
module m2
use mod
implicit none
!$omp requires atomic_default_mem_order (seq_cst)
contains
subroutine bar ()
integer v
!$omp atomic
j = j + 1
!$omp atomic update
k = k + 1
!$omp atomic read
v = l
!$omp atomic write
m = v
!$omp atomic capture
n = n + 1; v = n
end
end module

24
gcc/testsuite/gfortran.dg/gomp/atomic-22.f90 Normal file
View file

@ -0,0 +1,24 @@
module mod
integer i, j
contains
subroutine foo ()
integer v
!$omp atomic release
i = i + 1
!$omp atomic read
v = j
end
end module
module m2
!$omp requires atomic_default_mem_order (acq_rel) ! OK
contains
subroutine bar
!$omp atomic release
i = i + 1
!$omp requires atomic_default_mem_order (acq_rel) ! { dg-error "must appear in the specification part of a program unit" }
!$omp atomic read
v = j
end subroutine
end module m2

13
gcc/testsuite/gfortran.dg/gomp/atomic-24.f90 Normal file
View file

@ -0,0 +1,13 @@
! PR c/101297
module m
implicit none
integer :: i
contains
subroutine foo ()
!$omp atomic update, ! { dg-error "Clause expected at .1. after trailing comma" }
i = i + 1
!$omp atomic update,, ! { dg-error "Failed to match clause" }
i = i + 1
end
end module

53
gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 Normal file
View file

@ -0,0 +1,53 @@
! { dg-do compile }
module m
use iso_fortran_env
implicit none
integer, parameter :: mrk = maxval(real_kinds)
integer x, r, z
real(kind(4.0d0)) d, v
real(mrk) ld
contains
subroutine foo (y, e, f)
integer :: y
real(kind(4.0d0)) :: e
real(mrk) :: f
!$omp atomic update seq_cst fail(acquire)
x = min(x, y)
!$omp atomic relaxed fail(relaxed)
d = max (e, d)
!$omp atomic fail(SEQ_CST)
d = min (d, f)
!$omp atomic seq_cst compare fail(relaxed) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
if (x == 7) x = 24
!$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
if (x == 7) x = 24
!$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
if (x == 123) x = 256
!$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
if (ld == f) ld = f + 5.0_mrk
!$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
if (x == 9) then
x = 5
endif
!$omp atomic compare update capture seq_cst fail(acquire) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
if (x == 42) then
x = f
else
v = x
endif
!$omp atomic capture compare weak ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
if (x == 42) then
x = f
else
v = x
endif
!$omp atomic capture compare fail(seq_cst) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
if (d == 8.0) then
d = 16.0
else
v = d
end if
end
end module

75
gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 Normal file
View file

@ -0,0 +1,75 @@
! { dg-do compile }
module m
implicit none
integer x
real d
contains
real function foo (y, e, f)
integer :: y
real v, e
real(8) :: f
!$omp atomic compare compare ! { dg-error "Duplicated 'compare' clause" }
if (x == y) x = d
!$omp atomic compare fail(seq_cst) fail(seq_cst) ! { dg-error "Duplicated 'fail' clause" }
if (x == y) x = d
!$omp atomic compare,fail(seq_cst),fail(relaxed) ! { dg-error "Duplicated 'fail' clause" }
if (x == y) x = d
!$omp atomic compare weak weak ! { dg-error "Duplicated 'weak' clause" }
if (x == y) x = d
!$omp atomic read capture ! { dg-error "CAPTURE clause is incompatible with READ or WRITE" }
v = d
!$omp atomic capture, write ! { dg-error "CAPTURE clause is incompatible with READ or WRITE" }
d = v; v = v + 1 ! { dg-error "Unexpected ..OMP ATOMIC statement" "" { target *-*-* } .-1 }
foo = v
end
real function bar (y, e, f)
integer :: y
real v, e
real(8) :: f
!$omp atomic read compare ! { dg-error "COMPARE clause is incompatible with READ or WRITE" }
if (x == y) x = d
!$omp atomic compare, write ! { dg-error "COMPARE clause is incompatible with READ or WRITE" }
if (x == y) x = d
!$omp atomic read fail(seq_cst) ! { dg-error "FAIL clause is incompatible with READ or WRITE" }
v = d
!$omp atomic fail(relaxed), write ! { dg-error "FAIL clause is incompatible with READ or WRITE" }
d = v
!$omp atomic fail(relaxed) update ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" }
d = d + 3.0
!$omp atomic fail(relaxed) ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" }
d = d + 3.0
!$omp atomic capture fail(relaxed) ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" }
v = d; d = d + 3.0
!$omp atomic read weak ! { dg-error "WEAK clause requires COMPARE clause" }
v = d
!$omp atomic weak, write ! { dg-error "WEAK clause requires COMPARE clause" }
d = v
!$omp atomic weak update ! { dg-error "WEAK clause requires COMPARE clause" }
d = d + 3.0
!$omp atomic weak ! { dg-error "WEAK clause requires COMPARE clause" }
d = d + 3.0
!$omp atomic capture weak ! { dg-error "WEAK clause requires COMPARE clause" }
d = d + 3.0; v = d
!$omp atomic capture
d = d + 3.0; v = x ! { dg-error "capture statement reads from different variable than update statement writes" }
!$omp atomic compare fail ! { dg-error "Expected '\\\(' after 'fail'" }
if (x == y) x = d
!$omp atomic compare fail( ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
if (x == y) x = d ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" "" { target *-*-* } .-1 }
!$omp atomic compare fail() ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
if (x == y) x = d
!$omp atomic compare fail(foobar) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
if (x == y) x = d
!$omp atomic compare fail(acq_rel) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
if (x == y) x = d
!$omp atomic compare fail(release) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" }
if (x == y) x = d
!$omp atomic compare fail(seq_cst ! { dg-error "Failed to match clause" }
if (x == y) x = d
bar = v
end
end module

40
gcc/testsuite/gfortran.dg/gomp/atomic.f90
View file

@ -3,14 +3,13 @@
! { dg-final { scan-tree-dump-times "#pragma omp atomic relaxed" 4 "original" } }
! { dg-final { scan-tree-dump-times "#pragma omp atomic release" 4 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture relaxed" 2 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture release" 1 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture relaxed" 4 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture release" 2 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read acquire" 1 "original" } }
! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst" 7 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read seq_cst" 3 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture seq_cst" 3 "original" } }
! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture seq_cst" 6 "original" } }
subroutine foo ()
integer :: x, v
@ -85,3 +84,36 @@ subroutine bar
!$omp atomic hint(1),update,release
f = f + 2.0
end
subroutine openmp51_foo
integer :: x, v
!$omp atomic update seq_cst capture
x = x + 2
v = x
!$omp end atomic
!$omp atomic seq_cst, capture, update
x = x + 2
v = x
!$omp end atomic
!$omp atomic capture, seq_cst ,update
x = x + 2
v = x
!$omp end atomic
end
subroutine openmp51_bar
integer :: i, v
real :: f
!$omp atomic relaxed capture update
i = i + 1
v = i
!$omp end atomic
!$omp atomic update capture,release , hint (1)
i = i + 1
v = i
!$omp end atomic
!$omp atomic hint(0),update relaxed capture
i = i + 1
v = i
!$omp end atomic
end

3
libgomp/libgomp.texi
View file

@ -301,7 +301,8 @@ The OpenMP 4.5 specification is fully supported.
@item @code{interop} directive @tab N @tab
@item @code{omp_interop_t} object support in runtime routines @tab N @tab
@item @code{nowait} clause in @code{taskwait} directive @tab N @tab
@item Extensions to the @code{atomic} directive @tab P @tab C/C++ only
@item Extensions to the @code{atomic} directive @tab P
@tab @code{compare} unsupported in Fortran
@item @code{seq_cst} clause on a @code{flush} construct @tab Y @tab
@item @code{inoutset} argument to the @code{depend} clause @tab N @tab
@item @code{private} and @code{firstprivate} argument to @code{default}