Fortran: Cray pointer comparison wrongly optimized away [PR106692]

	PR fortran/106692

gcc/fortran/ChangeLog:

	* trans-expr.cc (gfc_conv_expr_op): Inhibit excessive optimization
	of Cray pointers by treating them as volatile in comparisons.

gcc/testsuite/ChangeLog:

	* gfortran.dg/cray_pointers_13.f90: New test.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f73e04bfd1d4324ca9e35d475fb98bccbeade634..bc24105ce3295d7b3f1445378f85d31ffddb97d0 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -4150,6 +4150,19 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
 
   if (lop)
     {
+      // Inhibit overeager optimization of Cray pointer comparisons (PR106692).
+      if (expr->value.op.op1->expr_type == EXPR_VARIABLE
+         && expr->value.op.op1->ts.type == BT_INTEGER
+         && expr->value.op.op1->symtree
+         && expr->value.op.op1->symtree->n.sym->attr.cray_pointer)
+       TREE_THIS_VOLATILE (lse.expr) = 1;
+
+      if (expr->value.op.op2->expr_type == EXPR_VARIABLE
+         && expr->value.op.op2->ts.type == BT_INTEGER
+         && expr->value.op.op2->symtree
+         && expr->value.op.op2->symtree->n.sym->attr.cray_pointer)
+       TREE_THIS_VOLATILE (rse.expr) = 1;
+
       /* The result of logical ops is always logical_type_node.  */
       tmp = fold_build2_loc (input_location, code, logical_type_node,
                             lse.expr, rse.expr);

diff --git a/gcc/testsuite/gfortran.dg/cray_pointers_13.f90 b/gcc/testsuite/gfortran.dg/cray_pointers_13.f90
new file mode 100644 (file)
index 0000000..766d245
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/cray_pointers_13.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+! { dg-additional-options "-fcray-pointer" }
+!
+! PR fortran/106692 - Cray pointer comparison wrongly optimized away
+!
+! Contributed by Marek Polacek
+
+program test
+  call test_cray()
+  call test_cray2()
+end
+
+subroutine test_cray()
+  pointer(ptrzz1 , zz1)
+  ptrzz1=0
+  if (ptrzz1 .ne. 0) then
+    print *, "test_cray: ptrzz1=", ptrzz1
+    stop 1
+  else
+    call shape_cray(zz1)
+  end if
+end
+
+subroutine shape_cray(zz1)
+  pointer(ptrzz , zz)
+  ptrzz=loc(zz1)
+  if (ptrzz .ne. 0) then
+    print *, "shape_cray: ptrzz=", ptrzz
+    stop 3
+  end if
+end
+
+subroutine test_cray2()
+  pointer(ptrzz1 , zz1)
+  ptrzz1=0
+  if (0 == ptrzz1) then
+    call shape_cray2(zz1)
+  else
+    print *, "test_cray2: ptrzz1=", ptrzz1
+    stop 2
+  end if
+end
+
+subroutine shape_cray2(zz1)
+  pointer(ptrzz , zz)
+  ptrzz=loc(zz1)
+  if (.not. (0 == ptrzz)) then
+    print *, "shape_cray2: ptrzz=", ptrzz
+    stop 4
+  end if
+end