From c7754a2fb2e60987524947fe189f3ffac035ea1d Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Thu, 2 Jan 2025 20:22:23 +0100
Subject: [PATCH] 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.
---
gcc/fortran/trans-expr.cc | 13 +++++
.../gfortran.dg/cray_pointers_13.f90 | 51 +++++++++++++++++++
2 files changed, 64 insertions(+)
create mode 100644 gcc/testsuite/gfortran.dg/cray_pointers_13.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f73e04bfd1d4..bc24105ce329 100644
--- 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
index 000000000000..766d24546ab2
--- /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
--
GitLab