diff options
| -rw-r--r-- | gcc/fortran/openmp.c | 81 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 211 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/gomp/atomic-21.f90 | 93 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 | 18 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 | 26 | ||||
| -rw-r--r-- | libgomp/libgomp.texi | 3 | ||||
| -rw-r--r-- | libgomp/testsuite/libgomp.fortran/atomic-19.f90 | 313 |
7 files changed, 650 insertions, 95 deletions
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 846fd7b..2036bc1 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -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: diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index d8229a5..aa0b0a5 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -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); diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-21.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-21.f90 new file mode 100644 index 0000000..febcdbb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-21.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 index 598ff4e..a501c1f 100644 --- a/gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 index 5f21d3b..6448bd9 100644 --- a/gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 @@ -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 diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index 33ca2bf..33b9e4c 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -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} diff --git a/libgomp/testsuite/libgomp.fortran/atomic-19.f90 b/libgomp/testsuite/libgomp.fortran/atomic-19.f90 new file mode 100644 index 0000000..e5f675f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/atomic-19.f90 @@ -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 |