Fortran/OpenMP: Support most of 5.1 atomic extensions
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
parent
87710ec7b2
commit
689407ef91
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}
|
||||
|
|
|
|||
Loading…
Reference in New Issue