Skip to content

Commit

Permalink
Fortran: Cray pointer comparison wrongly optimized away [PR106692]
Browse files Browse the repository at this point in the history
	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.

(cherry picked from commit c7754a2)
  • Loading branch information
harald-anlauf committed Jan 13, 2025
1 parent 166cea6 commit b95b340
Show file tree
Hide file tree
Showing 2 changed files with 64 additions and 0 deletions.
13 changes: 13 additions & 0 deletions gcc/fortran/trans-expr.cc
Original file line number Diff line number Diff line change
Expand Up @@ -3923,6 +3923,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);
Expand Down
51 changes: 51 additions & 0 deletions gcc/testsuite/gfortran.dg/cray_pointers_13.f90
Original file line number Diff line number Diff line change
@@ -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

0 comments on commit b95b340

Please sign in to comment.