mirror of
https://forge.sourceware.org/marek/gcc.git
synced 2026-02-22 12:00:11 -05:00
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.
This commit is contained in:
Tobias Burnus
@@ -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)
|
||||
{
|
||||
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;
|
||||
}
|
||||
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)
|
||||
{
|
||||
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);
|
||||
|
||||
93
gcc/testsuite/gfortran.dg/gomp/atomic-21.f90
Normal file
93
gcc/testsuite/gfortran.dg/gomp/atomic-21.f90
Normal file
@@ -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}
|
||||
|
||||
313
libgomp/testsuite/libgomp.fortran/atomic-19.f90
Normal file
313
libgomp/testsuite/libgomp.fortran/atomic-19.f90
Normal file
@@ -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
|
||||
Reference in New Issue
Block a user