Fortran: Handle compare in OpenMP atomic
gcc/fortran/ChangeLog:
PR fortran/103576
* openmp.c (is_scalar_intrinsic_expr): Fix condition.
(resolve_omp_atomic): Fix/update checks, accept compare.
* trans-openmp.c (gfc_trans_omp_atomic): Handle compare.
libgomp/ChangeLog:
* libgomp.texi (OpenMP 5.1): Set Fortran support for atomic to 'Y'.
* testsuite/libgomp.fortran/atomic-19.f90: New test.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/atomic-25.f90: Remove sorry, fix + add checks.
* gfortran.dg/gomp/atomic-26.f90: Likewise.
* gfortran.dg/gomp/atomic-21.f90: New test.
gcc/fortran/openmp.c | 81 +++---
gcc/fortran/trans-openmp.c | 211 ++++++++++++----
gcc/testsuite/gfortran.dg/gomp/atomic-21.f90 | 93 +++++++
gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 | 18 +-
gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 | 26 +-
libgomp/libgomp.texi | 3 +-
libgomp/testsuite/libgomp.fortran/atomic-19.f90 | 313 ++++++++++++++++++++++++
7 files changed, 650 insertions(+), 95 deletions(-)
@@ -7552,10 +7552,10 @@ is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok)
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));
+ && (expr->ts.type == BT_INTEGER
+ || expr->ts.type == BT_REAL
+ || expr->ts.type == BT_COMPLEX
+ || expr->ts.type == BT_LOGICAL));
}
static void
@@ -7574,12 +7574,9 @@ resolve_omp_atomic (gfc_code *code)
code = code->block->next;
/* 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 /* FIXME: || (code->next && code->next->op == EXEC_NOP)*/)
+ if (code->op == EXEC_NOP)
return;
- 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)
{
@@ -7597,6 +7594,7 @@ resolve_omp_atomic (gfc_code *code)
&& next->block->op == EXEC_IF
&& next->block->next->op == EXEC_ASSIGN)
{
+ comp_cond = next->block->expr1;
stmt = next->block->next;
if (stmt->next)
{
@@ -7604,11 +7602,20 @@ resolve_omp_atomic (gfc_code *code)
goto unexpected;
}
}
+ else if (capture_stmt)
+ {
+ gfc_error ("Expected IF at %L in atomic compare capture",
+ &next->loc);
+ return;
+ }
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);
+ {
+ gfc_error ("Expected ELSE at %L in atomic compare capture",
+ &next->block->block->expr1->where);
+ return;
+ }
if (!code->block->block->next
|| code->block->block->next->op != EXEC_ASSIGN)
{
@@ -7623,10 +7630,8 @@ resolve_omp_atomic (gfc_code *code)
goto unexpected;
}
}
- if (stmt && !capture_stmt && code->op == EXEC_ASSIGN)
- {
- capture_stmt = code;
- }
+ if (stmt && !capture_stmt && next->next->op == EXEC_ASSIGN)
+ capture_stmt = next->next;
else if (!capture_stmt)
{
loc = &code->loc;
@@ -7641,6 +7646,7 @@ resolve_omp_atomic (gfc_code *code)
&& code->block->op == EXEC_IF
&& code->block->next->op == EXEC_ASSIGN)
{
+ comp_cond = code->block->expr1;
stmt = code->block->next;
if (stmt->next || code->block->block)
{
@@ -7703,8 +7709,7 @@ resolve_omp_atomic (gfc_code *code)
{
/* x = ... */
stmt = code;
- if ((!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
- || (atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_IF))
+ if (!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN)
goto unexpected;
gcc_assert (!code->next);
}
@@ -7720,7 +7725,7 @@ resolve_omp_atomic (gfc_code *code)
"expression at %L", &comp_cond->where);
return;
}
- if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, false))
+ if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, true))
{
gfc_error ("Expected scalar intrinsic variable at %L in atomic "
"comparison", &comp_cond->value.op.op1->where);
@@ -7781,14 +7786,6 @@ resolve_omp_atomic (gfc_code *code)
break;
}
- if (atomic_code->ext.omp_clauses->compare
- && !atomic_code->ext.omp_clauses->capture)
- {
- 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))
@@ -7818,8 +7815,31 @@ resolve_omp_atomic (gfc_code *code)
}
}
- if (atomic_code->ext.omp_clauses->capture
- && !expr_references_sym (stmt_expr2, var, NULL))
+ if (atomic_code->ext.omp_clauses->compare)
+ {
+ gfc_expr *var_expr;
+ if (comp_cond->value.op.op1->expr_type == EXPR_VARIABLE)
+ var_expr = comp_cond->value.op.op1;
+ else
+ var_expr = comp_cond->value.op.op1->value.function.actual->expr;
+ if (var_expr->symtree->n.sym != var)
+ {
+ gfc_error ("For !$OMP ATOMIC COMPARE, the first operand in comparison"
+ " at %L must be the variable %qs that the update statement"
+ " writes into at %L", &var_expr->where, var->name,
+ &stmt->expr1->where);
+ return;
+ }
+ if (stmt_expr2->rank != 0 || expr_references_sym (stmt_expr2, var, NULL))
+ {
+ gfc_error ("expr in !$OMP ATOMIC COMPARE assignment var = expr "
+ "must be scalar and cannot reference var at %L",
+ &stmt_expr2->where);
+ return;
+ }
+ }
+ else if (atomic_code->ext.omp_clauses->capture
+ && !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);
@@ -7829,8 +7849,7 @@ resolve_omp_atomic (gfc_code *code)
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)
+ if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET)
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);
@@ -8042,10 +8061,6 @@ resolve_omp_atomic (gfc_code *code)
else
gfc_error ("!$OMP ATOMIC assignment must have an operator or "
"intrinsic on right hand side at %L", &stmt_expr2->where);
-
- if (atomic_code->ext.omp_clauses->compare)
- gfc_error ("Sorry, COMPARE clause in ATOMIC at %L is not yet "
- "supported", &atomic_code->loc);
return;
unexpected:
@@ -4488,13 +4488,13 @@ gfc_trans_omp_atomic (gfc_code *code)
gfc_se lse;
gfc_se rse;
gfc_se vse;
- gfc_expr *expr2, *e;
+ gfc_expr *expr1, *expr2, *e, *capture_expr1 = NULL, *capture_expr2 = NULL;
gfc_symbol *var;
stmtblock_t block;
- tree lhsaddr, type, rhs, x;
+ tree lhsaddr, type, rhs, x, compare = NULL_TREE, comp_tgt = NULL_TREE;
enum tree_code op = ERROR_MARK;
enum tree_code aop = OMP_ATOMIC;
- bool var_on_left = false;
+ bool var_on_left = false, else_branch = false;
enum omp_memory_order mo, fail_mo;
switch (atomic_code->ext.omp_clauses->memorder)
{
@@ -4514,18 +4514,86 @@ gfc_trans_omp_atomic (gfc_code *code)
case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break;
default: gcc_unreachable ();
}
- mo = (omp_memory_order) (mo | fail_mo);
+ mo = (omp_memory_order) (mo | fail_mo);
code = code->block->next;
- gcc_assert (code->op == EXEC_ASSIGN);
- var = code->expr1->symtree->n.sym;
+ if (atomic_code->ext.omp_clauses->compare)
+ {
+ gfc_expr *comp_expr;
+ if (code->op == EXEC_IF)
+ {
+ comp_expr = code->block->expr1;
+ gcc_assert (code->block->next->op == EXEC_ASSIGN);
+ expr1 = code->block->next->expr1;
+ expr2 = code->block->next->expr2;
+ if (code->block->block)
+ {
+ gcc_assert (atomic_code->ext.omp_clauses->capture
+ && code->block->block->next->op == EXEC_ASSIGN);
+ else_branch = true;
+ aop = OMP_ATOMIC_CAPTURE_OLD;
+ capture_expr1 = code->block->block->next->expr1;
+ capture_expr2 = code->block->block->next->expr2;
+ }
+ else if (atomic_code->ext.omp_clauses->capture)
+ {
+ gcc_assert (code->next->op == EXEC_ASSIGN);
+ aop = OMP_ATOMIC_CAPTURE_NEW;
+ capture_expr1 = code->next->expr1;
+ capture_expr2 = code->next->expr2;
+ }
+ }
+ else
+ {
+ gcc_assert (atomic_code->ext.omp_clauses->capture
+ && code->op == EXEC_ASSIGN
+ && code->next->op == EXEC_IF);
+ aop = OMP_ATOMIC_CAPTURE_OLD;
+ capture_expr1 = code->expr1;
+ capture_expr2 = code->expr2;
+ expr1 = code->next->block->next->expr1;
+ expr2 = code->next->block->next->expr2;
+ comp_expr = code->next->block->expr1;
+ }
+ gfc_init_se (&lse, NULL);
+ gfc_conv_expr (&lse, comp_expr->value.op.op2);
+ gfc_add_block_to_block (&block, &lse.pre);
+ compare = lse.expr;
+ var = expr1->symtree->n.sym;
+ }
+ else
+ {
+ gcc_assert (code->op == EXEC_ASSIGN);
+ expr1 = code->expr1;
+ expr2 = code->expr2;
+ if (atomic_code->ext.omp_clauses->capture
+ && (expr2->expr_type == EXPR_VARIABLE
+ || (expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym
+ && expr2->value.function.isym->id == GFC_ISYM_CONVERSION
+ && (expr2->value.function.actual->expr->expr_type
+ == EXPR_VARIABLE))))
+ {
+ capture_expr1 = expr1;
+ capture_expr2 = expr2;
+ expr1 = code->next->expr1;
+ expr2 = code->next->expr2;
+ aop = OMP_ATOMIC_CAPTURE_OLD;
+ }
+ else if (atomic_code->ext.omp_clauses->capture)
+ {
+ aop = OMP_ATOMIC_CAPTURE_NEW;
+ capture_expr1 = code->next->expr1;
+ capture_expr2 = code->next->expr2;
+ }
+ var = expr1->symtree->n.sym;
+ }
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
gfc_init_se (&vse, NULL);
gfc_start_block (&block);
- expr2 = code->expr2;
if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
!= GFC_OMP_ATOMIC_WRITE)
&& expr2->expr_type == EXPR_FUNCTION
@@ -4536,7 +4604,7 @@ gfc_trans_omp_atomic (gfc_code *code)
if ((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
== GFC_OMP_ATOMIC_READ)
{
- gfc_conv_expr (&vse, code->expr1);
+ gfc_conv_expr (&vse, expr1);
gfc_add_block_to_block (&block, &vse.pre);
gfc_conv_expr (&lse, expr2);
@@ -4554,36 +4622,32 @@ gfc_trans_omp_atomic (gfc_code *code)
return gfc_finish_block (&block);
}
- if (atomic_code->ext.omp_clauses->capture)
+
+ if (capture_expr2
+ && capture_expr2->expr_type == EXPR_FUNCTION
+ && capture_expr2->value.function.isym
+ && capture_expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
+ capture_expr2 = capture_expr2->value.function.actual->expr;
+ gcc_assert (!capture_expr2 || capture_expr2->expr_type == EXPR_VARIABLE);
+
+ if (aop == OMP_ATOMIC_CAPTURE_OLD)
{
- aop = OMP_ATOMIC_CAPTURE_NEW;
- if (expr2->expr_type == EXPR_VARIABLE)
- {
- aop = OMP_ATOMIC_CAPTURE_OLD;
- gfc_conv_expr (&vse, code->expr1);
- gfc_add_block_to_block (&block, &vse.pre);
-
- gfc_conv_expr (&lse, expr2);
- gfc_add_block_to_block (&block, &lse.pre);
- gfc_init_se (&lse, NULL);
- code = code->next;
- var = code->expr1->symtree->n.sym;
- expr2 = code->expr2;
- if (expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym
- && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
- expr2 = expr2->value.function.actual->expr;
- }
+ gfc_conv_expr (&vse, capture_expr1);
+ gfc_add_block_to_block (&block, &vse.pre);
+ gfc_conv_expr (&lse, capture_expr2);
+ gfc_add_block_to_block (&block, &lse.pre);
+ gfc_init_se (&lse, NULL);
}
- gfc_conv_expr (&lse, code->expr1);
+ gfc_conv_expr (&lse, expr1);
gfc_add_block_to_block (&block, &lse.pre);
type = TREE_TYPE (lse.expr);
lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
== GFC_OMP_ATOMIC_WRITE)
- || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP))
+ || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
+ || compare)
{
gfc_conv_expr (&rse, expr2);
gfc_add_block_to_block (&block, &rse.pre);
@@ -4675,6 +4739,10 @@ gfc_trans_omp_atomic (gfc_code *code)
gcc_unreachable ();
}
e = expr2->value.function.actual->expr;
+ if (e->expr_type == EXPR_FUNCTION
+ && e->value.function.isym
+ && e->value.function.isym->id == GFC_ISYM_CONVERSION)
+ e = e->value.function.actual->expr;
gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->symtree != NULL
&& e->symtree->n.sym == var);
@@ -4717,11 +4785,27 @@ gfc_trans_omp_atomic (gfc_code *code)
NULL_TREE, NULL_TREE);
}
- rhs = gfc_evaluate_now (rse.expr, &block);
+ if (compare)
+ {
+ tree var = create_tmp_var_raw (TREE_TYPE (lhsaddr));
+ DECL_CONTEXT (var) = current_function_decl;
+ lhsaddr = build4 (TARGET_EXPR, TREE_TYPE (lhsaddr), var, lhsaddr, NULL,
+ NULL);
+ lse.expr = build_fold_indirect_ref_loc (input_location, lhsaddr);
+ compare = convert (TREE_TYPE (lse.expr), compare);
+ compare = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ lse.expr, compare);
+ }
+
+ if (expr2->expr_type == EXPR_VARIABLE || compare)
+ rhs = rse.expr;
+ else
+ rhs = gfc_evaluate_now (rse.expr, &block);
if (((atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK)
== GFC_OMP_ATOMIC_WRITE)
- || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP))
+ || (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_SWAP)
+ || compare)
x = rhs;
else
{
@@ -4741,6 +4825,30 @@ gfc_trans_omp_atomic (gfc_code *code)
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
+ if (aop == OMP_ATOMIC_CAPTURE_NEW)
+ {
+ gfc_conv_expr (&vse, capture_expr1);
+ gfc_add_block_to_block (&block, &vse.pre);
+ gfc_add_block_to_block (&block, &lse.pre);
+ }
+
+ if (compare && else_branch)
+ {
+ tree var2 = create_tmp_var_raw (boolean_type_node);
+ DECL_CONTEXT (var2) = current_function_decl;
+ comp_tgt = build4 (TARGET_EXPR, boolean_type_node, var2,
+ boolean_false_node, NULL, NULL);
+ compare = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (var2),
+ var2, compare);
+ TREE_OPERAND (compare, 0) = comp_tgt;
+ compare = omit_one_operand_loc (input_location, boolean_type_node,
+ compare, comp_tgt);
+ }
+
+ if (compare)
+ x = build3_loc (input_location, COND_EXPR, type, compare,
+ convert (type, x), lse.expr);
+
if (aop == OMP_ATOMIC)
{
x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
@@ -4750,28 +4858,31 @@ gfc_trans_omp_atomic (gfc_code *code)
}
else
{
- if (aop == OMP_ATOMIC_CAPTURE_NEW)
- {
- code = code->next;
- expr2 = code->expr2;
- if (expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym
- && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
- expr2 = expr2->value.function.actual->expr;
-
- gcc_assert (expr2->expr_type == EXPR_VARIABLE);
- gfc_conv_expr (&vse, code->expr1);
- gfc_add_block_to_block (&block, &vse.pre);
-
- gfc_init_se (&lse, NULL);
- gfc_conv_expr (&lse, expr2);
- gfc_add_block_to_block (&block, &lse.pre);
- }
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);
+ if (compare && else_branch)
+ {
+ tree vtmp = create_tmp_var_raw (TREE_TYPE (x));
+ DECL_CONTEXT (vtmp) = current_function_decl;
+ x = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (vtmp), vtmp, x);
+ vtmp = build4 (TARGET_EXPR, TREE_TYPE (vtmp), vtmp,
+ build_zero_cst (TREE_TYPE (vtmp)), NULL, NULL);
+ TREE_OPERAND (x, 0) = vtmp;
+ tree x2 = convert (TREE_TYPE (vse.expr), vtmp);
+ x2 = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (vse.expr), vse.expr, x2);
+ x2 = build3_loc (input_location, COND_EXPR, void_type_node, comp_tgt,
+ void_node, x2);
+ x = omit_one_operand_loc (input_location, TREE_TYPE (x2), x2, x);
+ gfc_add_expr_to_block (&block, x);
+ }
+ else
+ {
+ x = convert (TREE_TYPE (vse.expr), x);
+ gfc_add_modify (&block, vse.expr, x);
+ }
}
return gfc_finish_block (&block);
new file mode 100644
@@ -0,0 +1,93 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-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 (acq_rel)
+
+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
+
+! { dg-final { scan-tree-dump-times "#pragma omp atomic release" 5 "original" } }
+! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture acq_rel" 1 "original" } }
+! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read acquire" 1 "original" } }
+
+subroutine foobar()
+ integer :: aa, bb, cc, dd, ee, ff, gg, hh, ii, jj, kk, nn, oo, pp, qq
+
+ !$omp atomic compare
+ if (ii == jj) ii = kk
+
+! #pragma omp atomic release
+! TARGET_EXPR <D.4241, &ii> = *TARGET_EXPR <D.4241, &ii> == jj \\? kk : *TARGET_EXPR <D.4241, &ii>;
+!
+! { dg-final { scan-tree-dump-times "TARGET_EXPR <D.\[0-9\]+, &ii> = \\*TARGET_EXPR <D.\[0-9\]+, &ii> == jj \\? kk : \\*TARGET_EXPR <D.\[0-9\]+, &ii>;" 1 "original" } }
+
+ !$omp atomic compare, capture
+ if (nn == oo) then
+ nn = pp
+ else
+ qq = nn
+ endif
+
+! TARGET_EXPR <D.4244, 0> = #pragma omp atomic capture acq_rel
+! TARGET_EXPR <D.4242, &nn> = NON_LVALUE_EXPR <TARGET_EXPR <D.4243, 0> = *TARGET_EXPR <D.4242, &nn> == oo> ? pp : *TARGET_EXPR <D.4242, &nn>;, if (TARGET_EXPR <D.4243, 0>)
+! {
+! <<< Unknown tree: void_cst >>>
+! }
+! else
+! {
+! qq = TARGET_EXPR <D.4244, 0>;
+! };
+!
+! { dg-final { scan-tree-dump-times "TARGET_EXPR <D.\[0-9\]+, 0> = #pragma omp atomic capture acq_rel" 1 "original" } }
+! { dg-final { scan-tree-dump-times "TARGET_EXPR <D.\[0-9\]+, &nn> = NON_LVALUE_EXPR <TARGET_EXPR <D.\[0-9\]+, 0> = \\*TARGET_EXPR <D.\[0-9\]+, &nn> == oo> \\? pp : \\*TARGET_EXPR <D.\[0-9\]+, &nn>;, if \\(TARGET_EXPR <D.\[0-9\]+, 0>\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "<<< Unknown tree: void_cst >>>" 1 "original" } }
+! { dg-final { scan-tree-dump-times "qq = TARGET_EXPR <D.\[0-9\]+, 0>;" 1 "original" } }
+
+ !$omp atomic capture compare
+ aa = bb
+ if (bb == cc) bb = dd
+
+! aa = #pragma omp atomic capture acq_rel
+! TARGET_EXPR <D.4245, &bb> = *TARGET_EXPR <D.4245, &bb> == cc ? dd : *TARGET_EXPR <D.4245, &bb>;
+!
+! { dg-final { scan-tree-dump-times "aa = #pragma omp atomic capture acq_rel" 1 "original" } }
+! { dg-final { scan-tree-dump-times "TARGET_EXPR <D.\[0-9\]+, &bb> = \\*TARGET_EXPR <D.\[0-9\]+, &bb> == cc \\? dd : \\*TARGET_EXPR <D.\[0-9\]+, &bb>;" 1 "original" } }
+
+ !$omp atomic capture compare
+ if (ee == ff) ee = gg
+ hh = ee
+
+! hh = #pragma omp atomic capture acq_rel
+! TARGET_EXPR <D.4246, &ee> = *TARGET_EXPR <D.4246, &ee> == ff ? gg : *TARGET_EXPR <D.4246, &ee>;
+!
+! { dg-final { scan-tree-dump-times "hh = #pragma omp atomic capture acq_rel" 1 "original" } }
+! { dg-final { scan-tree-dump-times "TARGET_EXPR <D.\[0-9\]+, &ee> = \\*TARGET_EXPR <D.\[0-9\]+, &ee> == ff \\? gg : \\*TARGET_EXPR <D.\[0-9\]+, &ee>;" 1 "original" } }
+end
+end module
@@ -19,31 +19,31 @@ subroutine foo (y, e, f)
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" }
+ !$omp atomic seq_cst compare fail(relaxed)
if (x == 7) x = 24
- !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ !$omp atomic compare
if (x == 7) x = 24
- !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" }
+ !$omp atomic compare
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" }
+ !$omp atomic compare
+ if (ld == f) ld = 5.0_mrk
+ !$omp atomic compare
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" }
+ !$omp atomic compare update capture seq_cst fail(acquire)
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" }
+ !$omp atomic capture compare weak
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" }
+ !$omp atomic capture compare fail(seq_cst)
if (d == 8.0) then
d = 16.0
else
@@ -59,7 +59,7 @@ real function bar (y, e, f)
!$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 }
+ if (x == y) x = d
!$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" }
@@ -72,4 +72,28 @@ real function bar (y, e, f)
if (x == y) x = d
bar = v
end
+
+subroutine foobar
+ implicit none
+ integer :: i, j, k
+
+ !$omp atomic compare write ! { dg-error "COMPARE clause is incompatible with READ or WRITE" }
+ if (i == 1) i = 5
+
+ !$omp atomic compare
+ if (k == 5) i = 7 ! { dg-error "For !.OMP ATOMIC COMPARE, the first operand in comparison at .1. must be the variable 'i' that the update statement writes into at .2." }
+
+ !$omp atomic compare
+ if (j == i) i = 8 ! { dg-error "For !.OMP ATOMIC COMPARE, the first operand in comparison at .1. must be the variable 'i' that the update statement writes into at .2." }
+
+ !$omp atomic compare
+ if (i == 5) i = 8
+
+ !$omp atomic compare
+ if (5 == i) i = 8 ! { dg-error "Expected scalar intrinsic variable at .1. in atomic comparison" }
+
+ !$omp atomic compare
+ if (i == 5) i = i + 8 ! { dg-error "20: expr in !.OMP ATOMIC COMPARE assignment var = expr must be scalar and cannot reference var" }
+
+end subroutine
end module
@@ -301,8 +301,7 @@ 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 @code{compare} unsupported in Fortran
+@item Extensions to the @code{atomic} directive @tab Y @tab
@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}
new file mode 100644
@@ -0,0 +1,313 @@
+! { dg-do run }
+
+module m
+ integer :: x = 6
+ integer :: w, y
+ target :: y
+
+contains
+ function foo ()
+ integer, pointer :: foo
+ if (w /= 0) &
+ error stop
+ foo => y
+ end
+end module
+
+program main
+ use m
+ implicit none
+ integer :: v, r
+ !$omp atomic
+ x = min (8, x)
+ !$omp atomic read
+ v = x
+ if (v /= 6) &
+ error stop
+
+ !$omp atomic compare
+ if (x == 6) x = 7
+ !$omp atomic read
+ v = x
+ if (v /= 7) &
+ error stop
+
+ !$omp atomic
+ x = min (x, 4)
+ !$omp atomic read
+ v = x
+ if (v /= 4) &
+ error stop
+ !$omp atomic capture
+ x = max(x, 8)
+ v = x
+ if (v /= 8) &
+ error stop
+
+ !$omp atomic read
+ v = x
+ if (x /= 8) &
+ error stop
+ !$omp atomic capture
+ v = x
+ x = max (12, x)
+ if (v /= 8) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic capture
+ v = x
+ x = max(4, x)
+ if (v /= 12) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic capture compare
+ if (x == 4) then
+ x = 4
+ else
+ v = x
+ endif
+ if (v /= 12) &
+ error stop
+ !$omp atomic write
+ x = -32
+ !$omp atomic capture seq_cst fail(relaxed)
+ x = max(x, 12_8)
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic compare
+ if (x == 12) x = 16
+ !$omp atomic read
+ v = x
+ if (v /= 16) &
+ error stop
+ r = 57
+ !$omp atomic compare capture
+ if (x == 16) then
+ x = r + 7
+ else
+ v = x
+ endif
+ if (v /= 16) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 64) &
+ error stop
+ !$omp atomic compare capture
+ v = x
+ if (x == 64) x = 16
+ if (v /= 64) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 16) &
+ error stop
+
+ !$omp atomic capture, update, compare seq_cst fail(acquire)
+ v = x
+ if (x == 73_8 - r) x = 12_2
+ if (v /= 16) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic update, compare, capture
+ if (x == 69_2 - r) x = 6_8
+ v = x
+ if (v /= 6) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 6) &
+ error stop
+ !$omp atomic
+ x = min(x, 8)
+ !$omp atomic read
+ v = x
+ if (v /= 6) &
+ error stop
+ !$omp atomic compare
+ if (x == 6) x = 8
+ !$omp atomic read
+ v = x
+ if (v /= 8) &
+ error stop
+ !$omp atomic
+ x = min(4,x)
+ !$omp atomic read
+ v = x
+ if (v /= 4) &
+ error stop
+ !$omp atomic capture
+ x = max(8_2, x)
+ v = x
+ if (v /= 8) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 8) &
+ error stop
+ !$omp atomic capture
+ v = x
+ x = max(12_1, x)
+ if (v /= 8) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic capture
+ v = x
+ x = max(x, 4_1)
+ if (v /= 12) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic write
+ x = -32
+ !$omp atomic capture ,seq_cst fail ( relaxed )
+ x = max(10_1 + 2_8, x)
+ v = x
+ !$omp end atomic
+ if (v /= 12) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic compare
+ if (x == 12) x = 16
+ !$omp atomic read
+ v = x
+ if (v /= 16) &
+ error stop
+ r = 57
+ !$omp atomic compare capture
+ if (x == 15) x = r + 7; v = x
+ if (v /= 16) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 16) &
+ error stop
+ !$omp atomic capture, update, compare seq_cst fail(acquire)
+ v = x; if (x == 73_8 - r) x = 12_8
+ !$omp end atomic
+ if (v /= 16) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 12) &
+ error stop
+ !$omp atomic update, compare, capture
+ if (x == 69_2 - r) x = 6_1; v = x
+ if (v /= 6) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 6) &
+ error stop
+ v = 24
+ !$omp atomic compare capture
+ if (x == 12) then; x = 16; else; v = x; endif
+ if (v /= 6) &
+ error stop
+ v = 32
+ !$omp atomic read
+ v = x
+ if (v /= 6) &
+ error stop
+ v = 147
+ !$omp atomic capture compare
+ if (x == 6) then; x = 57; else; v = x; endif
+ if (v /= 147) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 57) &
+ error stop
+ !$omp atomic update, compare, weak, seq_cst, fail (relaxed)
+ if (x == 137) x = 174
+ !$omp atomic read
+ v = x
+ if (v /= 57) &
+ error stop
+ !$omp atomic compare fail (relaxed)
+ if (x == 57_2) x = 6_8
+ !$omp atomic read
+ v = x
+ if (v /= 6) &
+ error stop
+ v = -5
+ !$omp atomic capture compare
+ if (x == 17) then; x = 25; else; v = x; endif
+ if (v /= 6) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 6) &
+ error stop
+ v = 15
+ !$omp atomic capture compare
+ if (x == 6) then; x = 23; else; v = x; endif
+ if (v /= 15) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 23) &
+ error stop
+ w = 1
+ !$omp atomic compare capture
+ ! if (x == 23) then; x = 57; else; foo () = x; endif ! OpenMP 6
+ if (x == 23) then; x = 57; else; y = x; endif
+ !$omp atomic read
+ v = x
+ if (v /= 57) &
+ error stop
+ !$omp atomic capture update compare
+ ! if (x == 57) then; x = 23; else; foo () = x; endif ! OpenMP 6
+ if (x == 57) then; x = 23; else; y = x; endif
+ !$omp atomic read
+ v = x
+ if (v /= 23) &
+ error stop
+ w = 0
+ !$omp atomic compare capture
+ ! if (x == 24) then; x = 57; else; foo () = x; endif ! OpenMP 6
+ if (x == 24) then; x = 57; else; y = x; endif
+ if (y /= 23) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 23) &
+ error stop
+ y = -5
+ !$omp atomic capture update compare
+ if (x == 57) then
+ x = 27
+ else
+ ! foo () = x ! OpenMP 6
+ y = x
+ end if
+ !$omp end atomic
+ if (y /= 23) &
+ error stop
+ !$omp atomic read
+ v = x
+ if (v /= 23) &
+ error stop
+end