From patchwork Mon Dec 13 11:19:50 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 48864 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id A8010385781B for ; Mon, 13 Dec 2021 11:21:25 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa2.mentor.iphmx.com (esa2.mentor.iphmx.com [68.232.141.98]) by sourceware.org (Postfix) with ESMTPS id BEF773857C6C; Mon, 13 Dec 2021 11:20:00 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org BEF773857C6C Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: 2q6KtCeZ8p4Q+U9Ef19uqtu6uFA8yPCyW25h/5C+r2mS3iY6IRoApblzkg8Z+ojbFXD+oWS/yq XMLNXeUHdqqiSsnna8TPAg6mCVYR9I/3Yi4avyRnP6dniSk1gtsyTTm61AJwCmHMExHfjiQwnj Ne/xHFjMbS1/oo5BA6t0KIqwIr8jVC3euBDSef3wyjtzS40FPdU6jgAG7Lv2tKOzn8npyUOf/X OylD1LC5wnAILax1bRld6K3VKfUTgY3b3Y4uIgd8nOPiMDqhs0/gIz0/ieX35pSpDbdl8YTIGY srJkqFPTwFYCnMsY/GtP2IB2 X-IronPort-AV: E=Sophos;i="5.88,202,1635235200"; d="diff'?scan'208";a="69606052" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa2.mentor.iphmx.com with ESMTP; 13 Dec 2021 03:19:59 -0800 IronPort-SDR: kov+KqFmdKJHWa5eBLmESMzGyZcoWBbjJWOk8f6xWwgXBfk1UzJ7amNGQybNW857M5LL1Srs+I qLml5VmrK4vvzWhBtlzeCnwc/AOLKNVQtAaX1ivvcBv1b+cbt4QuvGbxtPcHaUNzdNLdpxXRvS rRQJ3Z/3Y9O9BHPz2zY0XDJm9JcKr4bDj4KYedX4eQjp9CFw30CqsZIlsggM6dQb5i5SwojevU 1VVFJjeOvxQzykR55yWGkFrfpnraejZBh48IVlj3skTFzHgDanmcvO9y2xUzcgsKof/ylqog+w te4= Message-ID: <90154e1c-21fc-c0aa-82f4-cbd3e81f826a@codesourcery.com> Date: Mon, 13 Dec 2021 12:19:50 +0100 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:91.0) Gecko/20100101 Thunderbird/91.3.2 Content-Language: en-US To: gcc-patches , fortran , Jakub Jelinek From: Tobias Burnus Subject: [Patch] Fortran: Handle compare in OpenMP atomic X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-11.mgc.mentorg.com (139.181.222.11) To svr-ies-mbx-01.mgc.mentorg.com (139.181.222.1) X-Spam-Status: No, score=-10.8 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_STOCKGEN, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Some Sunday work ... Implement the 'compare' part in trans-openmp of OpenMP 5.1's atomic changes plus a couple of bugfixes throughout. OK? Tobias ----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955 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(-) diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 846fd7b5c5a..2036bc1349f 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 d8229a5ac30..aa0b0a5af73 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 00000000000..febcdbbacfb --- /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 = *TARGET_EXPR == jj \\? kk : *TARGET_EXPR ; +! +! { dg-final { scan-tree-dump-times "TARGET_EXPR = \\*TARGET_EXPR == jj \\? kk : \\*TARGET_EXPR ;" 1 "original" } } + + !$omp atomic compare, capture + if (nn == oo) then + nn = pp + else + qq = nn + endif + +! TARGET_EXPR = #pragma omp atomic capture acq_rel +! TARGET_EXPR = NON_LVALUE_EXPR = *TARGET_EXPR == oo> ? pp : *TARGET_EXPR ;, if (TARGET_EXPR ) +! { +! <<< Unknown tree: void_cst >>> +! } +! else +! { +! qq = TARGET_EXPR ; +! }; +! +! { dg-final { scan-tree-dump-times "TARGET_EXPR = #pragma omp atomic capture acq_rel" 1 "original" } } +! { dg-final { scan-tree-dump-times "TARGET_EXPR = NON_LVALUE_EXPR = \\*TARGET_EXPR == oo> \\? pp : \\*TARGET_EXPR ;, if \\(TARGET_EXPR \\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "<<< Unknown tree: void_cst >>>" 1 "original" } } +! { dg-final { scan-tree-dump-times "qq = TARGET_EXPR ;" 1 "original" } } + + !$omp atomic capture compare + aa = bb + if (bb == cc) bb = dd + +! aa = #pragma omp atomic capture acq_rel +! TARGET_EXPR = *TARGET_EXPR == cc ? dd : *TARGET_EXPR ; +! +! { dg-final { scan-tree-dump-times "aa = #pragma omp atomic capture acq_rel" 1 "original" } } +! { dg-final { scan-tree-dump-times "TARGET_EXPR = \\*TARGET_EXPR == cc \\? dd : \\*TARGET_EXPR ;" 1 "original" } } + + !$omp atomic capture compare + if (ee == ff) ee = gg + hh = ee + +! hh = #pragma omp atomic capture acq_rel +! TARGET_EXPR = *TARGET_EXPR == ff ? gg : *TARGET_EXPR ; +! +! { dg-final { scan-tree-dump-times "hh = #pragma omp atomic capture acq_rel" 1 "original" } } +! { dg-final { scan-tree-dump-times "TARGET_EXPR = \\*TARGET_EXPR == ff \\? gg : \\*TARGET_EXPR ;" 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 598ff4e54db..a501c1f7b04 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 5f21d3b6f92..6448bd9b8bb 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 33ca2bf4f1c..33b9e4cab55 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 00000000000..e5f675f87d9 --- /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