Fortran: Handle compare in OpenMP atomic

Message ID 90154e1c-21fc-c0aa-82f4-cbd3e81f826a@codesourcery.com
State New
Headers
Series Fortran: Handle compare in OpenMP atomic |

Commit Message

Tobias Burnus Dec. 13, 2021, 11:19 a.m. UTC
  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
  

Comments

Jakub Jelinek Dec. 13, 2021, 11:21 a.m. UTC | #1
On Mon, Dec 13, 2021 at 12:19:50PM +0100, Tobias Burnus wrote:
> 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.

Ok, thanks.

	Jakub
  

Patch

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 <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 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