diff options
Diffstat (limited to 'gcc')
20 files changed, 1248 insertions, 261 deletions
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 04660d5..2aa44ff 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1810,6 +1810,10 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) } fputc (')', dumpfile); } + if (omp_clauses->weak) + fputs (" WEAK", dumpfile); + if (omp_clauses->compare) + fputs (" COMPARE", dumpfile); if (omp_clauses->nogroup) fputs (" NOGROUP", dumpfile); if (omp_clauses->simd) @@ -1926,6 +1930,20 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) fputc (' ', dumpfile); fputs (memorder, dumpfile); } + if (omp_clauses->fail != OMP_MEMORDER_UNSET) + { + const char *memorder; + switch (omp_clauses->fail) + { + case OMP_MEMORDER_ACQUIRE: memorder = "AQUIRE"; break; + case OMP_MEMORDER_RELAXED: memorder = "RELAXED"; break; + case OMP_MEMORDER_SEQ_CST: memorder = "SEQ_CST"; break; + default: gcc_unreachable (); + } + fputs (" FAIL(", dumpfile); + fputs (memorder, dumpfile); + putc (')', dumpfile); + } if (omp_clauses->at != OMP_AT_UNSET) { if (omp_clauses->at != OMP_AT_COMPILATION) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 24ad3ed..e5d2dd7 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1529,10 +1529,11 @@ typedef struct gfc_omp_clauses unsigned sched_simd:1, sched_monotonic:1, sched_nonmonotonic:1; unsigned simd:1, threads:1, depend_source:1, destroy:1, order_concurrent:1; unsigned order_unconstrained:1, order_reproducible:1, capture:1; - unsigned grainsize_strict:1, num_tasks_strict:1; + unsigned grainsize_strict:1, num_tasks_strict:1, compare:1, weak:1; ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3; ENUM_BITFIELD (gfc_omp_device_type) device_type:2; ENUM_BITFIELD (gfc_omp_memorder) memorder:3; + ENUM_BITFIELD (gfc_omp_memorder) fail:3; ENUM_BITFIELD (gfc_omp_cancel_kind) cancel:3; ENUM_BITFIELD (gfc_omp_proc_bind_kind) proc_bind:3; ENUM_BITFIELD (gfc_omp_depend_op) depobj_update:3; diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index d120be8..846fd7b 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -917,6 +917,9 @@ enum omp_mask1 OMP_CLAUSE_AT, /* OpenMP 5.1. */ OMP_CLAUSE_MESSAGE, /* OpenMP 5.1. */ OMP_CLAUSE_SEVERITY, /* OpenMP 5.1. */ + OMP_CLAUSE_COMPARE, /* OpenMP 5.1. */ + OMP_CLAUSE_FAIL, /* OpenMP 5.1. */ + OMP_CLAUSE_WEAK, /* OpenMP 5.1. */ OMP_CLAUSE_NOWAIT, /* This must come last. */ OMP_MASK1_LAST @@ -1450,7 +1453,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, *cp = NULL; while (1) { - if ((first || gfc_match_char (',') != MATCH_YES) + match m = MATCH_NO; + if ((first || (m = gfc_match_char (',')) != MATCH_YES) && (needs_space && gfc_match_space () != MATCH_YES)) break; needs_space = false; @@ -1460,7 +1464,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, gfc_omp_namelist **head; old_loc = gfc_current_locus; char pc = gfc_peek_ascii_char (); - match m; + if (pc == '\n' && m == MATCH_YES) + { + gfc_error ("Clause expected at %C after trailing comma"); + goto error; + } switch (pc) { case 'a': @@ -1654,6 +1662,16 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, continue; } } + if ((mask & OMP_CLAUSE_COMPARE) + && (m = gfc_match_dupl_check (!c->compare, "compare")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->compare = true; + needs_space = true; + continue; + } if ((mask & OMP_CLAUSE_COPY) && gfc_match ("copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], @@ -2009,6 +2027,27 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } break; case 'f': + if ((mask & OMP_CLAUSE_FAIL) + && (m = gfc_match_dupl_check (c->fail == OMP_MEMORDER_UNSET, + "fail", true)) != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + if (gfc_match ("seq_cst") == MATCH_YES) + c->fail = OMP_MEMORDER_SEQ_CST; + else if (gfc_match ("acquire") == MATCH_YES) + c->fail = OMP_MEMORDER_ACQUIRE; + else if (gfc_match ("relaxed") == MATCH_YES) + c->fail = OMP_MEMORDER_RELAXED; + else + { + gfc_error ("Expected SEQ_CST, ACQUIRE or RELAXED at %C"); + break; + } + if (gfc_match (" )") != MATCH_YES) + goto error; + continue; + } if ((mask & OMP_CLAUSE_FILTER) && (m = gfc_match_dupl_check (!c->filter, "filter", true, &c->filter)) != MATCH_NO) @@ -2903,6 +2942,16 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } continue; } + if ((mask & OMP_CLAUSE_WEAK) + && (m = gfc_match_dupl_check (!c->weak, "weak")) + != MATCH_NO) + { + if (m == MATCH_ERROR) + goto error; + c->weak = true; + needs_space = true; + continue; + } if ((mask & OMP_CLAUSE_WORKER) && (m = gfc_match_dupl_check (!c->worker, "worker")) != MATCH_NO) { @@ -3593,7 +3642,8 @@ cleanup: (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE) #define OMP_ATOMIC_CLAUSES \ (omp_mask (OMP_CLAUSE_ATOMIC) | OMP_CLAUSE_CAPTURE | OMP_CLAUSE_HINT \ - | OMP_CLAUSE_MEMORDER) + | OMP_CLAUSE_MEMORDER | OMP_CLAUSE_COMPARE | OMP_CLAUSE_FAIL \ + | OMP_CLAUSE_WEAK) #define OMP_MASKED_CLAUSES \ (omp_mask (OMP_CLAUSE_FILTER)) #define OMP_ERROR_CLAUSES \ @@ -5718,6 +5768,7 @@ gfc_match_omp_ordered_depend (void) - capture - memory-order-clause: seq_cst | acq_rel | release | acquire | relaxed - hint(hint-expr) + - OpenMP 5.1: compare | fail (seq_cst | acquire | relaxed ) | weak */ match @@ -5729,12 +5780,25 @@ gfc_match_omp_atomic (void) if (gfc_match_omp_clauses (&c, OMP_ATOMIC_CLAUSES, true, true) != MATCH_YES) return MATCH_ERROR; - if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UNSET) - gfc_error ("OMP ATOMIC at %L with multiple atomic clauses", &loc); - if (c->atomic_op == GFC_OMP_ATOMIC_UNSET) c->atomic_op = GFC_OMP_ATOMIC_UPDATE; + if (c->capture && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) + gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " + "READ or WRITE", &loc, "CAPTURE"); + if (c->compare && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) + gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " + "READ or WRITE", &loc, "COMPARE"); + if (c->fail != OMP_MEMORDER_UNSET && c->atomic_op != GFC_OMP_ATOMIC_UPDATE) + gfc_error ("!$OMP ATOMIC at %L with %s clause is incompatible with " + "READ or WRITE", &loc, "FAIL"); + if (c->weak && !c->compare) + { + gfc_error ("!$OMP ATOMIC at %L with %s clause requires %s clause", &loc, + "WEAK", "COMPARE"); + c->weak = false; + } + if (c->memorder == OMP_MEMORDER_UNSET) { gfc_namespace *prog_unit = gfc_current_ns; @@ -5765,32 +5829,24 @@ gfc_match_omp_atomic (void) switch (c->atomic_op) { case GFC_OMP_ATOMIC_READ: - if (c->memorder == OMP_MEMORDER_ACQ_REL - || c->memorder == OMP_MEMORDER_RELEASE) + if (c->memorder == OMP_MEMORDER_RELEASE) { gfc_error ("!$OMP ATOMIC READ at %L incompatible with " - "ACQ_REL or RELEASE clauses", &loc); + "RELEASE clause", &loc); c->memorder = OMP_MEMORDER_SEQ_CST; } + else if (c->memorder == OMP_MEMORDER_ACQ_REL) + c->memorder = OMP_MEMORDER_ACQUIRE; break; case GFC_OMP_ATOMIC_WRITE: - if (c->memorder == OMP_MEMORDER_ACQ_REL - || c->memorder == OMP_MEMORDER_ACQUIRE) + if (c->memorder == OMP_MEMORDER_ACQUIRE) { gfc_error ("!$OMP ATOMIC WRITE at %L incompatible with " - "ACQ_REL or ACQUIRE clauses", &loc); - c->memorder = OMP_MEMORDER_SEQ_CST; - } - break; - case GFC_OMP_ATOMIC_UPDATE: - if ((c->memorder == OMP_MEMORDER_ACQ_REL - || c->memorder == OMP_MEMORDER_ACQUIRE) - && !c->capture) - { - gfc_error ("!$OMP ATOMIC UPDATE at %L incompatible with " - "ACQ_REL or ACQUIRE clauses", &loc); + "ACQUIRE clause", &loc); c->memorder = OMP_MEMORDER_SEQ_CST; } + else if (c->memorder == OMP_MEMORDER_ACQ_REL) + c->memorder = OMP_MEMORDER_RELEASE; break; default: break; @@ -7451,20 +7507,24 @@ expr_references_sym (gfc_expr *e, gfc_symbol *s, gfc_expr *se) /* If EXPR is a conversion function that widens the type - if WIDENING is true or narrows the type if WIDENING is false, + if WIDENING is true or narrows the type if NARROW is true, return the inner expression, otherwise return NULL. */ static gfc_expr * -is_conversion (gfc_expr *expr, bool widening) +is_conversion (gfc_expr *expr, bool narrowing, bool widening) { gfc_typespec *ts1, *ts2; if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym == NULL || expr->value.function.esym != NULL - || expr->value.function.isym->id != GFC_ISYM_CONVERSION) + || expr->value.function.isym->id != GFC_ISYM_CONVERSION + || (!narrowing && !widening)) return NULL; + if (narrowing && widening) + return expr->value.function.actual->expr; + if (widening) { ts1 = &expr->ts; @@ -7483,163 +7543,297 @@ is_conversion (gfc_expr *expr, bool widening) return NULL; } +static bool +is_scalar_intrinsic_expr (gfc_expr *expr, bool must_be_var, bool conv_ok) +{ + if (must_be_var + && (expr->expr_type != EXPR_VARIABLE || !expr->symtree) + && (!conv_ok || !is_conversion (expr, true, true))) + return false; + return (expr->rank == 0 + && !gfc_is_coindexed (expr) + && (expr->ts.type != BT_INTEGER + || expr->ts.type != BT_REAL + || expr->ts.type != BT_COMPLEX + || expr->ts.type != BT_LOGICAL)); +} static void resolve_omp_atomic (gfc_code *code) { gfc_code *atomic_code = code->block; gfc_symbol *var; - gfc_expr *expr2, *expr2_tmp; + gfc_expr *stmt_expr2, *capt_expr2; gfc_omp_atomic_op aop = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op & GFC_OMP_ATOMIC_MASK); + gfc_code *stmt = NULL, *capture_stmt = NULL; + gfc_expr *comp_cond = NULL; + locus *loc = NULL; code = code->block->next; - /* resolve_blocks asserts this is initially EXEC_ASSIGN. + /* resolve_blocks asserts this is initially EXEC_ASSIGN or EXEC_IF If it changed to EXEC_NOP, assume an error has been emitted already. */ - if (code->op == EXEC_NOP) + if (code->op == EXEC_NOP /* FIXME: || (code->next && code->next->op == EXEC_NOP)*/) return; - if (code->op != EXEC_ASSIGN) + + if (code->op == EXEC_IF && code->block->op == EXEC_IF) + comp_cond = code->block->expr1; + + if (atomic_code->ext.omp_clauses->compare + && atomic_code->ext.omp_clauses->capture) { - unexpected: - gfc_error ("unexpected !$OMP ATOMIC expression at %L", &code->loc); - return; + /* Must be either "if (x == e) then; x = d; else; v = x; end if" + or "v = expr" followed/preceded by + "if (x == e) then; x = d; end if" or "if (x == e) x = d". */ + gfc_code *next = code; + if (code->op == EXEC_ASSIGN) + { + capture_stmt = code; + next = code->next; + } + if (next->op == EXEC_IF + && next->block + && next->block->op == EXEC_IF + && next->block->next->op == EXEC_ASSIGN) + { + stmt = next->block->next; + if (stmt->next) + { + loc = &stmt->loc; + goto unexpected; + } + } + if (stmt && !capture_stmt && next->block->block) + { + if (next->block->block->expr1) + gfc_error ("Expected ELSE at %L in atomic compare capture", + &next->block->block->expr1->where); + if (!code->block->block->next + || code->block->block->next->op != EXEC_ASSIGN) + { + loc = (code->block->block->next ? &code->block->block->next->loc + : &code->block->block->loc); + goto unexpected; + } + capture_stmt = code->block->block->next; + if (capture_stmt->next) + { + loc = &capture_stmt->next->loc; + goto unexpected; + } + } + if (stmt && !capture_stmt && code->op == EXEC_ASSIGN) + { + capture_stmt = code; + } + else if (!capture_stmt) + { + loc = &code->loc; + goto unexpected; + } } - if (!atomic_code->ext.omp_clauses->capture) + else if (atomic_code->ext.omp_clauses->compare) { - if (code->next != NULL) + /* Must be: "if (x == e) then; x = d; end if" or "if (x == e) x = d". */ + if (code->op == EXEC_IF + && code->block + && code->block->op == EXEC_IF + && code->block->next->op == EXEC_ASSIGN) + { + stmt = code->block->next; + if (stmt->next || code->block->block) + { + loc = stmt->next ? &stmt->next->loc : &code->block->block->loc; + goto unexpected; + } + } + else + { + loc = &code->loc; + goto unexpected; + } + } + else if (atomic_code->ext.omp_clauses->capture) + { + /* Must be: "v = x" followed/preceded by "x = ...". */ + if (code->op != EXEC_ASSIGN) goto unexpected; + if (code->next->op != EXEC_ASSIGN) + { + loc = &code->next->loc; + goto unexpected; + } + gfc_expr *expr2, *expr2_next; + expr2 = is_conversion (code->expr2, true, true); + if (expr2 == NULL) + expr2 = code->expr2; + expr2_next = is_conversion (code->next->expr2, true, true); + if (expr2_next == NULL) + expr2_next = code->next->expr2; + if (code->expr1->expr_type == EXPR_VARIABLE + && code->next->expr1->expr_type == EXPR_VARIABLE + && expr2->expr_type == EXPR_VARIABLE + && expr2_next->expr_type == EXPR_VARIABLE) + { + if (code->expr1->symtree->n.sym == expr2_next->symtree->n.sym) + { + stmt = code; + capture_stmt = code->next; + } + else + { + capture_stmt = code; + stmt = code->next; + } + } + else if (expr2->expr_type == EXPR_VARIABLE) + { + capture_stmt = code; + stmt = code->next; + } + else + { + stmt = code; + capture_stmt = code->next; + } + gcc_assert (!code->next->next); } else { - if (code->next == NULL) + /* x = ... */ + stmt = code; + if ((!atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_ASSIGN) + || (atomic_code->ext.omp_clauses->compare && stmt->op != EXEC_IF)) goto unexpected; - if (code->next->op == EXEC_NOP) + gcc_assert (!code->next); + } + + if (comp_cond) + { + if (comp_cond->expr_type != EXPR_OP + || (comp_cond->value.op.op != INTRINSIC_EQ + && comp_cond->value.op.op != INTRINSIC_EQ_OS + && comp_cond->value.op.op != INTRINSIC_EQV)) + { + gfc_error ("Expected %<==%>, %<.EQ.%> or %<.EQV.%> atomic comparison " + "expression at %L", &comp_cond->where); + return; + } + if (!is_scalar_intrinsic_expr (comp_cond->value.op.op1, true, false)) + { + gfc_error ("Expected scalar intrinsic variable at %L in atomic " + "comparison", &comp_cond->value.op.op1->where); + return; + } + if (!gfc_resolve_expr (comp_cond->value.op.op2)) return; - if (code->next->op != EXEC_ASSIGN || code->next->next) + if (!is_scalar_intrinsic_expr (comp_cond->value.op.op2, false, false)) { - code = code->next; - goto unexpected; + gfc_error ("Expected scalar intrinsic expression at %L in atomic " + "comparison", &comp_cond->value.op.op1->where); + return; } } - if (code->expr1->expr_type != EXPR_VARIABLE - || code->expr1->symtree == NULL - || code->expr1->rank != 0 - || (code->expr1->ts.type != BT_INTEGER - && code->expr1->ts.type != BT_REAL - && code->expr1->ts.type != BT_COMPLEX - && code->expr1->ts.type != BT_LOGICAL)) + if (!is_scalar_intrinsic_expr (stmt->expr1, true, false)) { gfc_error ("!$OMP ATOMIC statement must set a scalar variable of " - "intrinsic type at %L", &code->loc); + "intrinsic type at %L", &stmt->expr1->where); return; } - var = code->expr1->symtree->n.sym; - expr2 = is_conversion (code->expr2, false); - if (expr2 == NULL) + if (!gfc_resolve_expr (stmt->expr2)) + return; + if (!is_scalar_intrinsic_expr (stmt->expr2, false, false)) { - if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE) - expr2 = is_conversion (code->expr2, true); - if (expr2 == NULL) - expr2 = code->expr2; + gfc_error ("!$OMP ATOMIC statement must assign an expression of " + "intrinsic type at %L", &stmt->expr2->where); + return; } + if (gfc_expr_attr (stmt->expr1).allocatable) + { + gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L", + &stmt->expr1->where); + return; + } + + var = stmt->expr1->symtree->n.sym; + stmt_expr2 = is_conversion (stmt->expr2, true, true); + if (stmt_expr2 == NULL) + stmt_expr2 = stmt->expr2; + switch (aop) { case GFC_OMP_ATOMIC_READ: - if (expr2->expr_type != EXPR_VARIABLE - || expr2->symtree == NULL - || expr2->rank != 0 - || (expr2->ts.type != BT_INTEGER - && expr2->ts.type != BT_REAL - && expr2->ts.type != BT_COMPLEX - && expr2->ts.type != BT_LOGICAL)) + if (stmt_expr2->expr_type != EXPR_VARIABLE) gfc_error ("!$OMP ATOMIC READ statement must read from a scalar " - "variable of intrinsic type at %L", &expr2->where); + "variable of intrinsic type at %L", &stmt_expr2->where); return; case GFC_OMP_ATOMIC_WRITE: - if (expr2->rank != 0 || expr_references_sym (code->expr2, var, NULL)) + if (expr_references_sym (stmt_expr2, var, NULL)) gfc_error ("expr in !$OMP ATOMIC WRITE assignment var = expr " "must be scalar and cannot reference var at %L", - &expr2->where); + &stmt_expr2->where); return; default: break; } + + if (atomic_code->ext.omp_clauses->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) { - expr2_tmp = expr2; - if (expr2 == code->expr2) + if (!is_scalar_intrinsic_expr (capture_stmt->expr1, true, false)) { - expr2_tmp = is_conversion (code->expr2, true); - if (expr2_tmp == NULL) - expr2_tmp = expr2; + gfc_error ("!$OMP ATOMIC capture-statement must set a scalar " + "variable of intrinsic type at %L", + &capture_stmt->expr1->where); + return; } - if (expr2_tmp->expr_type == EXPR_VARIABLE) + + if (!is_scalar_intrinsic_expr (capture_stmt->expr2, true, true)) { - if (expr2_tmp->symtree == NULL - || expr2_tmp->rank != 0 - || (expr2_tmp->ts.type != BT_INTEGER - && expr2_tmp->ts.type != BT_REAL - && expr2_tmp->ts.type != BT_COMPLEX - && expr2_tmp->ts.type != BT_LOGICAL) - || expr2_tmp->symtree->n.sym == var) - { - gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read from " - "a scalar variable of intrinsic type at %L", - &expr2_tmp->where); - return; - } - var = expr2_tmp->symtree->n.sym; - code = code->next; - if (code->expr1->expr_type != EXPR_VARIABLE - || code->expr1->symtree == NULL - || code->expr1->rank != 0 - || (code->expr1->ts.type != BT_INTEGER - && code->expr1->ts.type != BT_REAL - && code->expr1->ts.type != BT_COMPLEX - && code->expr1->ts.type != BT_LOGICAL)) - { - gfc_error ("!$OMP ATOMIC CAPTURE update statement must set " - "a scalar variable of intrinsic type at %L", - &code->expr1->where); - return; - } - if (code->expr1->symtree->n.sym != var) - { - gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " - "different variable than update statement writes " - "into at %L", &code->expr1->where); - return; - } - expr2 = is_conversion (code->expr2, false); - if (expr2 == NULL) - expr2 = code->expr2; + gfc_error ("!$OMP ATOMIC capture-statement requires a scalar variable" + " of intrinsic type at %L", &capture_stmt->expr2->where); + return; } - } + capt_expr2 = is_conversion (capture_stmt->expr2, true, true); + if (capt_expr2 == NULL) + capt_expr2 = capture_stmt->expr2; - if (gfc_expr_attr (code->expr1).allocatable) - { - gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L", - &code->loc); - return; + if (capt_expr2->symtree->n.sym != var) + { + gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " + "different variable than update statement writes " + "into at %L", &capture_stmt->expr2->where); + return; + } } if (atomic_code->ext.omp_clauses->capture - && code->next == NULL - && code->expr2->rank == 0 - && !expr_references_sym (code->expr2, var, NULL)) + && !expr_references_sym (stmt_expr2, var, NULL)) atomic_code->ext.omp_clauses->atomic_op = (gfc_omp_atomic_op) (atomic_code->ext.omp_clauses->atomic_op | GFC_OMP_ATOMIC_SWAP); - else if (expr2->expr_type == EXPR_OP) + else if (stmt_expr2->expr_type == EXPR_OP) { gfc_expr *v = NULL, *e, *c; - gfc_intrinsic_op op = expr2->value.op.op; + gfc_intrinsic_op op = stmt_expr2->value.op.op; gfc_intrinsic_op alt_op = INTRINSIC_NONE; + if (atomic_code->ext.omp_clauses->fail != OMP_MEMORDER_UNSET + && !atomic_code->ext.omp_clauses->compare) + gfc_error ("!$OMP ATOMIC UPDATE at %L with FAIL clause requiries either" + " the COMPARE clause or using the intrinsic MIN/MAX " + "procedure", &atomic_code->loc); switch (op) { case INTRINSIC_PLUS: @@ -7666,7 +7860,7 @@ resolve_omp_atomic (gfc_code *code) default: gfc_error ("!$OMP ATOMIC assignment operator must be binary " "+, *, -, /, .AND., .OR., .EQV. or .NEQV. at %L", - &expr2->where); + &stmt_expr2->where); return; } @@ -7676,12 +7870,12 @@ resolve_omp_atomic (gfc_code *code) (expr) op var. We rely here on the fact that the matcher for x op1 y op2 z where op1 and op2 have equal precedence returns (x op1 y) op2 z. */ - e = expr2->value.op.op2; + e = stmt_expr2->value.op.op2; if (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var) v = e; - else if ((c = is_conversion (e, true)) != NULL + else if ((c = is_conversion (e, false, true)) != NULL && c->expr_type == EXPR_VARIABLE && c->symtree != NULL && c->symtree->n.sym == var) @@ -7689,7 +7883,7 @@ resolve_omp_atomic (gfc_code *code) else { gfc_expr **p = NULL, **q; - for (q = &expr2->value.op.op1; (e = *q) != NULL; ) + for (q = &stmt_expr2->value.op.op1; (e = *q) != NULL; ) if (e->expr_type == EXPR_VARIABLE && e->symtree != NULL && e->symtree->n.sym == var) @@ -7697,7 +7891,7 @@ resolve_omp_atomic (gfc_code *code) v = e; break; } - else if ((c = is_conversion (e, true)) != NULL) + else if ((c = is_conversion (e, false, true)) != NULL) q = &e->value.function.actual->expr; else if (e->expr_type != EXPR_OP || (e->value.op.op != op @@ -7713,7 +7907,7 @@ resolve_omp_atomic (gfc_code *code) if (v == NULL) { gfc_error ("!$OMP ATOMIC assignment must be var = var op expr " - "or var = expr op var at %L", &expr2->where); + "or var = expr op var at %L", &stmt_expr2->where); return; } @@ -7728,7 +7922,7 @@ resolve_omp_atomic (gfc_code *code) case INTRINSIC_NEQV: gfc_error ("!$OMP ATOMIC var = var op expr not " "mathematically equivalent to var = var op " - "(expr) at %L", &expr2->where); + "(expr) at %L", &stmt_expr2->where); break; default: break; @@ -7736,43 +7930,44 @@ resolve_omp_atomic (gfc_code *code) /* Canonicalize into var = var op (expr). */ *p = e->value.op.op2; - e->value.op.op2 = expr2; - e->ts = expr2->ts; - if (code->expr2 == expr2) - code->expr2 = expr2 = e; + e->value.op.op2 = stmt_expr2; + e->ts = stmt_expr2->ts; + if (stmt->expr2 == stmt_expr2) + stmt->expr2 = stmt_expr2 = e; else - code->expr2->value.function.actual->expr = expr2 = e; + stmt->expr2->value.function.actual->expr = stmt_expr2 = e; - if (!gfc_compare_types (&expr2->value.op.op1->ts, &expr2->ts)) + if (!gfc_compare_types (&stmt_expr2->value.op.op1->ts, + &stmt_expr2->ts)) { - for (p = &expr2->value.op.op1; *p != v; + for (p = &stmt_expr2->value.op.op1; *p != v; p = &(*p)->value.function.actual->expr) ; *p = NULL; - gfc_free_expr (expr2->value.op.op1); - expr2->value.op.op1 = v; - gfc_convert_type (v, &expr2->ts, 2); + gfc_free_expr (stmt_expr2->value.op.op1); + stmt_expr2->value.op.op1 = v; + gfc_convert_type (v, &stmt_expr2->ts, 2); } } } - if (e->rank != 0 || expr_references_sym (code->expr2, var, v)) + if (e->rank != 0 || expr_references_sym (stmt->expr2, var, v)) { gfc_error ("expr in !$OMP ATOMIC assignment var = var op expr " "must be scalar and cannot reference var at %L", - &expr2->where); + &stmt_expr2->where); return; } } - else if (expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym != NULL - && expr2->value.function.esym == NULL - && expr2->value.function.actual != NULL - && expr2->value.function.actual->next != NULL) + else if (stmt_expr2->expr_type == EXPR_FUNCTION + && stmt_expr2->value.function.isym != NULL + && stmt_expr2->value.function.esym == NULL + && stmt_expr2->value.function.actual != NULL + && stmt_expr2->value.function.actual->next != NULL) { gfc_actual_arglist *arg, *var_arg; - switch (expr2->value.function.isym->id) + switch (stmt_expr2->value.function.isym->id) { case GFC_ISYM_MIN: case GFC_ISYM_MAX: @@ -7780,31 +7975,37 @@ resolve_omp_atomic (gfc_code *code) case GFC_ISYM_IAND: case GFC_ISYM_IOR: case GFC_ISYM_IEOR: - if (expr2->value.function.actual->next->next != NULL) + if (stmt_expr2->value.function.actual->next->next != NULL) { gfc_error ("!$OMP ATOMIC assignment intrinsic IAND, IOR " "or IEOR must have two arguments at %L", - &expr2->where); + &stmt_expr2->where); return; } break; default: gfc_error ("!$OMP ATOMIC assignment intrinsic must be " "MIN, MAX, IAND, IOR or IEOR at %L", - &expr2->where); + &stmt_expr2->where); return; } var_arg = NULL; - for (arg = expr2->value.function.actual; arg; arg = arg->next) - { - if ((arg == expr2->value.function.actual - || (var_arg == NULL && arg->next == NULL)) - && arg->expr->expr_type == EXPR_VARIABLE - && arg->expr->symtree != NULL - && arg->expr->symtree->n.sym == var) - var_arg = arg; - else if (expr_references_sym (arg->expr, var, NULL)) + for (arg = stmt_expr2->value.function.actual; arg; arg = arg->next) + { + gfc_expr *e = NULL; + if (arg == stmt_expr2->value.function.actual + || (var_arg == NULL && arg->next == NULL)) + { + e = is_conversion (arg->expr, false, true); + if (!e) + e = arg->expr; + if (e->expr_type == EXPR_VARIABLE + && e->symtree != NULL + && e->symtree->n.sym == var) + var_arg = arg; + } + if ((!var_arg || !e) && expr_references_sym (arg->expr, var, NULL)) { gfc_error ("!$OMP ATOMIC intrinsic arguments except one must " "not reference %qs at %L", @@ -7822,72 +8023,35 @@ resolve_omp_atomic (gfc_code *code) if (var_arg == NULL) { gfc_error ("First or last !$OMP ATOMIC intrinsic argument must " - "be %qs at %L", var->name, &expr2->where); + "be %qs at %L", var->name, &stmt_expr2->where); return; } - if (var_arg != expr2->value.function.actual) + if (var_arg != stmt_expr2->value.function.actual) { /* Canonicalize, so that var comes first. */ gcc_assert (var_arg->next == NULL); - for (arg = expr2->value.function.actual; + for (arg = stmt_expr2->value.function.actual; arg->next != var_arg; arg = arg->next) ; - var_arg->next = expr2->value.function.actual; - expr2->value.function.actual = var_arg; + var_arg->next = stmt_expr2->value.function.actual; + stmt_expr2->value.function.actual = var_arg; arg->next = NULL; } } else gfc_error ("!$OMP ATOMIC assignment must have an operator or " - "intrinsic on right hand side at %L", &expr2->where); - - if (atomic_code->ext.omp_clauses->capture && code->next) - { - code = code->next; - if (code->expr1->expr_type != EXPR_VARIABLE - || code->expr1->symtree == NULL - || code->expr1->rank != 0 - || (code->expr1->ts.type != BT_INTEGER - && code->expr1->ts.type != BT_REAL - && code->expr1->ts.type != BT_COMPLEX - && code->expr1->ts.type != BT_LOGICAL)) - { - gfc_error ("!$OMP ATOMIC CAPTURE capture statement must set " - "a scalar variable of intrinsic type at %L", - &code->expr1->where); - return; - } + "intrinsic on right hand side at %L", &stmt_expr2->where); - expr2 = is_conversion (code->expr2, false); - if (expr2 == NULL) - { - expr2 = is_conversion (code->expr2, true); - if (expr2 == NULL) - expr2 = code->expr2; - } + if (atomic_code->ext.omp_clauses->compare) + gfc_error ("Sorry, COMPARE clause in ATOMIC at %L is not yet " + "supported", &atomic_code->loc); + return; - if (expr2->expr_type != EXPR_VARIABLE - || expr2->symtree == NULL - || expr2->rank != 0 - || (expr2->ts.type != BT_INTEGER - && expr2->ts.type != BT_REAL - && expr2->ts.type != BT_COMPLEX - && expr2->ts.type != BT_LOGICAL)) - { - gfc_error ("!$OMP ATOMIC CAPTURE capture statement must read " - "from a scalar variable of intrinsic type at %L", - &expr2->where); - return; - } - if (expr2->symtree->n.sym != var) - { - gfc_error ("!$OMP ATOMIC CAPTURE capture statement reads from " - "different variable than update statement writes " - "into at %L", &expr2->where); - return; - } - } +unexpected: + gfc_error ("unexpected !$OMP ATOMIC expression at %L", + loc ? loc : &code->loc); + return; } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 94b677f..1f11109 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -5313,7 +5313,22 @@ parse_omp_oacc_atomic (bool omp_p) st = next_statement (); if (st == ST_NONE) unexpected_eof (); - else if (st == ST_ASSIGNMENT) + else if (np->ext.omp_clauses->compare + && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK)) + { + count--; + if (st == ST_IF_BLOCK) + { + parse_if_block (); + /* With else (or elseif). */ + if (gfc_state_stack->tail->block->block) + count--; + } + accept_statement (st); + } + else if (st == ST_ASSIGNMENT + && (!np->ext.omp_clauses->compare + || np->ext.omp_clauses->capture)) { accept_statement (st); count--; @@ -5332,8 +5347,6 @@ parse_omp_oacc_atomic (bool omp_p) gfc_warning_check (); st = next_statement (); } - else if (np->ext.omp_clauses->capture) - gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C"); return st; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f074a0a..0ed3197 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -10849,13 +10849,8 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) { /* Verify this before calling gfc_resolve_code, which might change it. */ - gcc_assert (b->next && b->next->op == EXEC_ASSIGN); - gcc_assert ((!b->ext.omp_clauses->capture - && b->next->next == NULL) - || (b->ext.omp_clauses->capture - && b->next->next != NULL - && b->next->next->op == EXEC_ASSIGN - && b->next->next->next == NULL)); + gcc_assert (b->op == EXEC_OMP_ATOMIC + || (b->next && b->next->op == EXEC_ASSIGN)); } break; diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 18268fb..2015506 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -4492,7 +4492,7 @@ gfc_trans_omp_atomic (gfc_code *code) enum tree_code op = ERROR_MARK; enum tree_code aop = OMP_ATOMIC; bool var_on_left = false; - enum omp_memory_order mo; + enum omp_memory_order mo, fail_mo; switch (atomic_code->ext.omp_clauses->memorder) { case OMP_MEMORDER_UNSET: mo = OMP_MEMORY_ORDER_UNSPECIFIED; break; @@ -4503,6 +4503,15 @@ gfc_trans_omp_atomic (gfc_code *code) case OMP_MEMORDER_SEQ_CST: mo = OMP_MEMORY_ORDER_SEQ_CST; break; default: gcc_unreachable (); } + switch (atomic_code->ext.omp_clauses->fail) + { + case OMP_MEMORDER_UNSET: fail_mo = OMP_FAIL_MEMORY_ORDER_UNSPECIFIED; break; + case OMP_MEMORDER_ACQUIRE: fail_mo = OMP_FAIL_MEMORY_ORDER_ACQUIRE; break; + case OMP_MEMORDER_RELAXED: fail_mo = OMP_FAIL_MEMORY_ORDER_RELAXED; break; + case OMP_MEMORDER_SEQ_CST: fail_mo = OMP_FAIL_MEMORY_ORDER_SEQ_CST; break; + default: gcc_unreachable (); + } + mo = (omp_memory_order) (mo | fail_mo); code = code->block->next; gcc_assert (code->op == EXEC_ASSIGN); @@ -4733,6 +4742,7 @@ gfc_trans_omp_atomic (gfc_code *code) { x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x)); OMP_ATOMIC_MEMORY_ORDER (x) = mo; + OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak; gfc_add_expr_to_block (&block, x); } else @@ -4756,6 +4766,7 @@ gfc_trans_omp_atomic (gfc_code *code) } x = build2 (aop, type, lhsaddr, convert (type, x)); OMP_ATOMIC_MEMORY_ORDER (x) = mo; + OMP_ATOMIC_WEAK (x) = atomic_code->ext.omp_clauses->weak; x = convert (TREE_TYPE (vse.expr), x); gfc_add_modify (&block, vse.expr, x); } diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-10.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-10.f90 new file mode 100644 index 0000000..bafc88b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-10.f90 @@ -0,0 +1,32 @@ +! PR middle-end/28046 for the original C tet. +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-ompexp" } +! { dg-require-effective-target cas_int } + +module m + implicit none + integer a(3), b + type t_C + integer :: x, y + end type + type(t_C) :: c + + interface + integer function bar(); end + integer function baz(); end + end interface + pointer :: baz +contains +subroutine foo +!$omp atomic + a(2) = a(2) + bar () +!$omp atomic + b = b + bar () +!$omp atomic + c%y = c%y + bar () +!$omp atomic + b = b + baz () +end +end module + +! { dg-final { scan-tree-dump-times "__atomic_fetch_add" 4 "ompexp" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-12.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-12.f90 new file mode 100644 index 0000000..a097076 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-12.f90 @@ -0,0 +1,364 @@ +! PR middle-end/45423 - for the original C/C++ testcase +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple -g0 -Wno-deprecated" } +! atomicvar should never be referenced in between the barrier and +! following #pragma omp atomic_load. +! { dg-final { scan-tree-dump-not "barrier\[^#\]*atomicvar" "gimple" } } + +module m + implicit none + logical :: atomicvar, c + integer :: i, atomicvar2, c2 +contains +integer function foo () + !$omp barrier + !$omp atomic + atomicvar = atomicvar .or. .true. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .or. .false. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .or. c + !$omp barrier + !$omp atomic + atomicvar = atomicvar .and. .true. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .and. .false. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .and. c + !$omp barrier + !$omp atomic + atomicvar = atomicvar .neqv. .true. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .neqv. .false. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .neqv. c + !$omp barrier + !$omp atomic + atomicvar = atomicvar .eqv. .true. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .eqv. .false. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .eqv. c + !$omp barrier + !$omp atomic + atomicvar = .true. .or. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .false. .or. atomicvar + !$omp barrier + !$omp atomic + atomicvar = c .or. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .true. .and. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .false. .and. atomicvar + !$omp barrier + !$omp atomic + atomicvar = c .and. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .true. .neqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .false. .neqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = c .neqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .true. .eqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .false. .eqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = c .eqv. atomicvar + !$omp barrier + foo = 0 +end + +integer function bar () + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = min (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = max (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + (-1) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + 0 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + 1 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + 2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + c2 + !$omp barrier + !$omp atomic + atomicvar2 = -1 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 0 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 1 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 2 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = c2 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - (-1) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - 0 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - 1 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - 2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - c2 + !$omp barrier + !$omp atomic + atomicvar2 = -1 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 0 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 1 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 2 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = c2 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * (-1) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * 0 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * 1 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * 2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * c2 + !$omp barrier + !$omp atomic + atomicvar2 = (-1) * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 0 * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 1 * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 2 * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = c2 * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / (-1) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / 0 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / 1 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / 2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / c2 + !$omp barrier + !$omp atomic + atomicvar2 = (-1) / atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 0 / atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 1 / atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 2 / atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = c2 / atomicvar2 + !$omp barrier + bar = 0 +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-15.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-15.f90 new file mode 100644 index 0000000..4c81791 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-15.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } +module m + implicit none + integer :: x = 6 +end module m + +program main + use m + implicit none + integer v + !$omp atomic + x = x * 7 + 6 ! { dg-error "assignment must be var = var op expr or var = expr op var" } + !$omp atomic + x = ieor (x * 7, 6) ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic update + x = x - 8 + 6 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic + x = ior (ieor (x, 7), 2) ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic + x = x / 7 * 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic + x = x / 7 / 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + v = x; x = x * 7 + 6 ! { dg-error "assignment must be var = var op expr or var = expr op var" } + !$omp atomic capture + v = x; x = ieor(x * 7, 6) ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic capture + v = x; x = x - 8 + 6 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + v = x; x = ior (ieor(x, 7), 2) ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic capture + v = x; x = x / 7 * 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + v = x; x = x / 7 / 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + x = x * 7 + 6; v = x ! { dg-error "assignment must be var = var op expr or var = expr op var" } + !$omp atomic capture + x = ieor(x * 7, 6); v = x ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic capture + x = x - 8 + 6; v = x ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + x = ior(ieor(x, 7), 2); v = x ! { dg-error "intrinsic arguments except one must not reference 'x'" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-16.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-16.f90 new file mode 100644 index 0000000..7660858 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-16.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m + implicit none + integer :: x = 6 +contains + +subroutine foo () + integer v + !$omp atomic seq_cst read + v = x + !$omp atomic seq_cst, read + v = x + !$omp atomic seq_cst write + x = v + !$omp atomic seq_cst ,write + x = v + !$omp atomic seq_cst update + x = x + v; + !$omp atomic seq_cst , update + x = v + x; + !$omp atomic seq_cst capture + v = x; x = x + 2; + !$omp atomic seq_cst, capture + v = x; x = 2 + x; + !$omp atomic read , seq_cst + v = x + !$omp atomic write ,seq_cst + x = v + !$omp atomic update, seq_cst + x = x + v + !$omp atomic capture, seq_cst + x = x + 2; v = x +end +end module m diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-17.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-17.f90 new file mode 100644 index 0000000..d6864f5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-17.f90 @@ -0,0 +1,41 @@ +module m +implicit none +integer i, v +real f +contains + +subroutine foo () + !$omp atomic release, hint (0), update + i = i + 1 + !$omp atomic hint(0)seq_cst + i = i + 1 + !$omp atomic relaxed,update,hint (0) + i = i + 1 + !$omp atomic release + i = i + 1 + !$omp atomic relaxed + i = i + 1 + !$omp atomic acq_rel capture + i = i + 1; v = i + !$omp atomic capture,acq_rel , hint (1) + i = i + 1; v = i + !$omp atomic hint(0),acquire capture + i = i + 1; v = i + !$omp atomic read acquire + v = i + !$omp atomic acq_rel read + v = i + !$omp atomic release,write + i = v + !$omp atomic write,acq_rel + i = v + !$omp atomic hint(1),update,release + f = f + 2.0 + !$omp atomic update ,acquire + i = i + 1 + !$omp atomic acq_rel update + i = i + 1 + !$omp atomic acq_rel,hint(0) + i = i + 1 +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-18.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-18.f90 new file mode 100644 index 0000000..9bc6f63 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-18.f90 @@ -0,0 +1,27 @@ +module m +implicit none +integer i, v +real f +contains +subroutine foo (j) +integer, value :: j + !$omp atomic update,update ! { dg-error "Duplicated atomic clause: unexpected update clause" } + i = i + 1 + !$omp atomic seq_cst release ! { dg-error "Duplicated memory-order clause: unexpected release clause" } + i = i + 1 + !$omp atomic read,release ! { dg-error "ATOMIC READ at .1. incompatible with RELEASE clause" } + v = i + !$omp atomic acquire , write ! { dg-error "ATOMIC WRITE at .1. incompatible with ACQUIRE clause" } + i = v + !$omp atomic capture hint (0) capture ! { dg-error "Duplicated 'capture' clause" } + v = i = i + 1 + !$omp atomic hint(j + 2) ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" } + i = i + 1 + !$omp atomic hint(f) + ! { dg-error "HINT clause at .1. requires a scalar INTEGER expression" "" { target *-*-* } .-1 } + ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" "" { target *-*-* } .-2 } + i = i + 1 + !$omp atomic foobar ! { dg-error "Failed to match clause" } + i = i + 1 +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-19.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-19.f90 new file mode 100644 index 0000000..ade4c94 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-19.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! { dg-final { scan-tree-dump-times "omp atomic release" 1 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic relaxed" 3 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic read relaxed" 1 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic capture relaxed" 1 "original" } } + +module mod + implicit none + integer i, j, k, l, m, n + +contains + +subroutine foo () + !$omp atomic release + i = i + 1; +end +end + +module m2 +use mod +implicit none +!$omp requires atomic_default_mem_order (relaxed) + +contains +subroutine bar () + integer v; + !$omp atomic + j = j + 1 + !$omp atomic update + k = k + 1 + !$omp atomic read + v = l + !$omp atomic write + m = v + !$omp atomic capture + n = n + 1; v = n +end +end module m2 diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-2.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-2.f90 index 1de418d..b6c1b6a 100644 --- a/gcc/testsuite/gfortran.dg/gomp/atomic-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-2.f90 @@ -3,13 +3,13 @@ subroutine bar integer :: i, v real :: f - !$omp atomic update acq_rel hint("abc") ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" } + !$omp atomic update acq_rel hint("abc") ! { dg-error "HINT clause at .1. requires a scalar INTEGER expression" "" { target *-*-* } .-1 } ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" "" { target *-*-* } .-2 } i = i + 1 !$omp end atomic - !$omp atomic acq_rel ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" } + !$omp atomic acq_rel i = i + 1 !$omp end atomic @@ -18,7 +18,7 @@ subroutine bar v = i !$omp end atomic - !$omp atomic acq_rel , hint (1), update ! { dg-error "OMP ATOMIC UPDATE at .1. incompatible with ACQ_REL or ACQUIRE clauses" } + !$omp atomic acq_rel , hint (1), update i = i + 1 !$omp end atomic @@ -27,44 +27,10 @@ subroutine bar v = i !$omp end atomic - !$omp atomic write capture ! { dg-error "multiple atomic clauses" } + !$omp atomic write capture ! { dg-error "with CAPTURE clause is incompatible with READ or WRITE" } i = 2 v = i !$omp end atomic !$omp atomic foobar ! { dg-error "Failed to match clause" } end - -! moved here from atomic.f90 -subroutine openmp51_foo - integer :: x, v - !$omp atomic update seq_cst capture ! { dg-error "multiple atomic clauses" } - x = x + 2 - v = x - !$omp end atomic - !$omp atomic seq_cst, capture, update ! { dg-error "multiple atomic clauses" } - x = x + 2 - v = x - !$omp end atomic - !$omp atomic capture, seq_cst ,update ! { dg-error "multiple atomic clauses" } - x = x + 2 - v = x - !$omp end atomic -end - -subroutine openmp51_bar - integer :: i, v - real :: f - !$omp atomic relaxed capture update ! { dg-error "multiple atomic clauses" } - i = i + 1 - v = i - !$omp end atomic - !$omp atomic update capture,release , hint (1) ! { dg-error "multiple atomic clauses" } - i = i + 1 - v = i - !$omp end atomic - !$omp atomic hint(0),update relaxed capture ! { dg-error "multiple atomic clauses" } - i = i + 1 - v = i - !$omp end atomic -end diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-20.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-20.f90 new file mode 100644 index 0000000..29193e1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-20.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! { dg-final { scan-tree-dump-times "omp atomic release" 1 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic seq_cst" 3 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic read seq_cst" 1 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic capture seq_cst" 1 "original" } } + +module mod +implicit none +integer i, j, k, l, m, n + +contains +subroutine foo () + !$omp atomic release + i = i + 1 +end +end module + +module m2 +use mod +implicit none +!$omp requires atomic_default_mem_order (seq_cst) + +contains + +subroutine bar () + integer v + !$omp atomic + j = j + 1 + !$omp atomic update + k = k + 1 + !$omp atomic read + v = l + !$omp atomic write + m = v + !$omp atomic capture + n = n + 1; v = n +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-22.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-22.f90 new file mode 100644 index 0000000..584c0d3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-22.f90 @@ -0,0 +1,24 @@ +module mod +integer i, j + +contains +subroutine foo () + integer v + !$omp atomic release + i = i + 1 + !$omp atomic read + v = j +end +end module + +module m2 +!$omp requires atomic_default_mem_order (acq_rel) ! OK +contains +subroutine bar + !$omp atomic release + i = i + 1 +!$omp requires atomic_default_mem_order (acq_rel) ! { dg-error "must appear in the specification part of a program unit" } + !$omp atomic read + v = j +end subroutine +end module m2 diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-24.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-24.f90 new file mode 100644 index 0000000..235826e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-24.f90 @@ -0,0 +1,13 @@ +! PR c/101297 + +module m +implicit none +integer :: i +contains +subroutine foo () + !$omp atomic update, ! { dg-error "Clause expected at .1. after trailing comma" } + i = i + 1 + !$omp atomic update,, ! { dg-error "Failed to match clause" } + i = i + 1 +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 new file mode 100644 index 0000000..598ff4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-25.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } + +module m +use iso_fortran_env +implicit none +integer, parameter :: mrk = maxval(real_kinds) +integer x, r, z +real(kind(4.0d0)) d, v +real(mrk) ld + +contains +subroutine foo (y, e, f) + integer :: y + real(kind(4.0d0)) :: e + real(mrk) :: f + !$omp atomic update seq_cst fail(acquire) + x = min(x, y) + !$omp atomic relaxed fail(relaxed) + d = max (e, d) + !$omp atomic fail(SEQ_CST) + d = min (d, f) + !$omp atomic seq_cst compare fail(relaxed) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" } + if (x == 7) x = 24 + !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" } + if (x == 7) x = 24 + !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" } + if (x == 123) x = 256 + !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" } + if (ld == f) ld = f + 5.0_mrk + !$omp atomic compare ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" } + if (x == 9) then + x = 5 + endif + !$omp atomic compare update capture seq_cst fail(acquire) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" } + if (x == 42) then + x = f + else + v = x + endif + !$omp atomic capture compare weak ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" } + if (x == 42) then + x = f + else + v = x + endif + !$omp atomic capture compare fail(seq_cst) ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" } + if (d == 8.0) then + d = 16.0 + else + v = d + end if +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 new file mode 100644 index 0000000..5f21d3b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/atomic-26.f90 @@ -0,0 +1,75 @@ +! { dg-do compile } + +module m +implicit none +integer x +real d + +contains + +real function foo (y, e, f) + integer :: y + real v, e + real(8) :: f + !$omp atomic compare compare ! { dg-error "Duplicated 'compare' clause" } + if (x == y) x = d + !$omp atomic compare fail(seq_cst) fail(seq_cst) ! { dg-error "Duplicated 'fail' clause" } + if (x == y) x = d + !$omp atomic compare,fail(seq_cst),fail(relaxed) ! { dg-error "Duplicated 'fail' clause" } + if (x == y) x = d + !$omp atomic compare weak weak ! { dg-error "Duplicated 'weak' clause" } + if (x == y) x = d + !$omp atomic read capture ! { dg-error "CAPTURE clause is incompatible with READ or WRITE" } + v = d + !$omp atomic capture, write ! { dg-error "CAPTURE clause is incompatible with READ or WRITE" } + d = v; v = v + 1 ! { dg-error "Unexpected ..OMP ATOMIC statement" "" { target *-*-* } .-1 } + foo = v +end + +real function bar (y, e, f) + integer :: y + real v, e + real(8) :: f + !$omp atomic read compare ! { dg-error "COMPARE clause is incompatible with READ or WRITE" } + if (x == y) x = d + !$omp atomic compare, write ! { dg-error "COMPARE clause is incompatible with READ or WRITE" } + if (x == y) x = d + !$omp atomic read fail(seq_cst) ! { dg-error "FAIL clause is incompatible with READ or WRITE" } + v = d + !$omp atomic fail(relaxed), write ! { dg-error "FAIL clause is incompatible with READ or WRITE" } + d = v + !$omp atomic fail(relaxed) update ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" } + d = d + 3.0 + !$omp atomic fail(relaxed) ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" } + d = d + 3.0 + !$omp atomic capture fail(relaxed) ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" } + v = d; d = d + 3.0 + !$omp atomic read weak ! { dg-error "WEAK clause requires COMPARE clause" } + v = d + !$omp atomic weak, write ! { dg-error "WEAK clause requires COMPARE clause" } + d = v + !$omp atomic weak update ! { dg-error "WEAK clause requires COMPARE clause" } + d = d + 3.0 + !$omp atomic weak ! { dg-error "WEAK clause requires COMPARE clause" } + d = d + 3.0 + !$omp atomic capture weak ! { dg-error "WEAK clause requires COMPARE clause" } + d = d + 3.0; v = d + !$omp atomic capture + d = d + 3.0; v = x ! { dg-error "capture statement reads from different variable than update statement writes" } + !$omp atomic compare fail ! { dg-error "Expected '\\\(' after 'fail'" } + if (x == y) x = d + !$omp atomic compare fail( ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d ! { dg-error "Sorry, COMPARE clause in ATOMIC at .1. is not yet supported" "" { target *-*-* } .-1 } + !$omp atomic compare fail() ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail(foobar) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail(acq_rel) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail(release) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail(seq_cst ! { dg-error "Failed to match clause" } + if (x == y) x = d + bar = v +end +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/atomic.f90 b/gcc/testsuite/gfortran.dg/gomp/atomic.f90 index b4caf03..ca12796 100644 --- a/gcc/testsuite/gfortran.dg/gomp/atomic.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/atomic.f90 @@ -3,14 +3,13 @@ ! { dg-final { scan-tree-dump-times "#pragma omp atomic relaxed" 4 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp atomic release" 4 "original" } } -! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture relaxed" 2 "original" } } -! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture release" 1 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture relaxed" 4 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture release" 2 "original" } } ! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read acquire" 1 "original" } } ! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst" 7 "original" } } ! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read seq_cst" 3 "original" } } -! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture seq_cst" 3 "original" } } - +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture seq_cst" 6 "original" } } subroutine foo () integer :: x, v @@ -85,3 +84,36 @@ subroutine bar !$omp atomic hint(1),update,release f = f + 2.0 end + +subroutine openmp51_foo + integer :: x, v + !$omp atomic update seq_cst capture + x = x + 2 + v = x + !$omp end atomic + !$omp atomic seq_cst, capture, update + x = x + 2 + v = x + !$omp end atomic + !$omp atomic capture, seq_cst ,update + x = x + 2 + v = x + !$omp end atomic +end + +subroutine openmp51_bar + integer :: i, v + real :: f + !$omp atomic relaxed capture update + i = i + 1 + v = i + !$omp end atomic + !$omp atomic update capture,release , hint (1) + i = i + 1 + v = i + !$omp end atomic + !$omp atomic hint(0),update relaxed capture + i = i + 1 + v = i + !$omp end atomic +end |