[Patch, fortran] PR44582 - gfortran generates wrong results due to wrong ABI in function with array return

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

This PR is marked as critical.

For as long as I can remember, gfortran has made assignments of the kind:
lhs_array = array_valued_function (args,...)
without a temporary, except when, for example, there is a dependency
between the lhs_array and one of the arguments.

The reporter (Yin Ma of Absoft) noticed that aliasing could occur
between the function result and other forms of association.  The
example below, due to Tobias Burnus, illustrates this.

program test
  implicit none
  integer :: a(5)
  a = 5
  a = f()                    ! assignment
  print *, a
  a = 5
  print *, f()               ! print
contains
  function f()
     integer :: f(size(a))
     f = -5                 ! Resets 'a' to -5 in the assignment
     f = a - f              ! Gives 0 for the assignment and 10 for the print
  end function f
end program test

This program prints a row of 0's followed by a row of 10's, whereas
two rows of 10's is the correct result.

The attached patch fixes this by being much more restrictive in the
use of this optimization.  In fact, it is still conservative as the
'TODO' in the new function indicates.  The testcase incorporates the
above and a number of other aliasing situations.  Trunk currently
fails all the cases that need a temporary.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk, 4.5,4.4 and 4.3?

Cheers

Paul

2010-06-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/44582
	* trans-expr.c (arrayfunc_assign_needs_temporary): New function
	to determine if a function assignment can be made without a
	temporary.
	(gfc_trans_arrayfunc_assign): Move all the conditions that
	suppress the direct function call to the above new functon and
	call it.

2010-06-28  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/44582
	* gfortran.dg/aliasing_array_result_1.f90 : New test.

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 161023)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_trans_scalar_assign (gfc_se * lse, g
*** 4867,4907 ****
  }
  
  
! /* Try to translate array(:) = func (...), where func is a transformational
!    array function, without using a temporary.  Returns NULL is this isn't the
!    case.  */
  
! static tree
! gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
  {
-   gfc_se se;
-   gfc_ss *ss;
    gfc_ref * ref;
    bool seen_array_ref;
    bool c = false;
!   gfc_component *comp = NULL;
  
    /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
    if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
!     return NULL;
  
    /* Elemental functions don't need a temporary anyway.  */
    if (expr2->value.function.esym != NULL
        && expr2->value.function.esym->attr.elemental)
!     return NULL;
  
!   /* Fail if rhs is not FULL or a contiguous section.  */
    if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
!     return NULL;
  
!   /* Fail if EXPR1 can't be expressed as a descriptor.  */
    if (gfc_ref_needs_temporary_p (expr1->ref))
!     return NULL;
  
    /* Functions returning pointers need temporaries.  */
    if (expr2->symtree->n.sym->attr.pointer 
        || expr2->symtree->n.sym->attr.allocatable)
!     return NULL;
  
    /* Character array functions need temporaries unless the
       character lengths are the same.  */
--- 4867,4904 ----
  }
  
  
! /* There are quite a lot of restrictions on the optimisation in using an
!    array function assign without a temporary.  */
  
! static bool
! arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
  {
    gfc_ref * ref;
    bool seen_array_ref;
    bool c = false;
!   gfc_symbol *sym = expr1->symtree->n.sym;
  
    /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
    if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
!     return true;
  
    /* Elemental functions don't need a temporary anyway.  */
    if (expr2->value.function.esym != NULL
        && expr2->value.function.esym->attr.elemental)
!     return true;
  
!   /* Need a temporary if rhs is not FULL or a contiguous section.  */
    if (expr1->ref && !(gfc_full_array_ref_p (expr1->ref, &c) || c))
!     return true;
  
!   /* Need a temporary if EXPR1 can't be expressed as a descriptor.  */
    if (gfc_ref_needs_temporary_p (expr1->ref))
!     return true;
  
    /* Functions returning pointers need temporaries.  */
    if (expr2->symtree->n.sym->attr.pointer 
        || expr2->symtree->n.sym->attr.allocatable)
!     return true;
  
    /* Character array functions need temporaries unless the
       character lengths are the same.  */
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 4909,4923 ****
      {
        if (expr1->ts.u.cl->length == NULL
  	    || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
! 	return NULL;
  
        if (expr2->ts.u.cl->length == NULL
  	    || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
! 	return NULL;
  
        if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
  		     expr2->ts.u.cl->length->value.integer) != 0)
! 	return NULL;
      }
  
    /* Check that no LHS component references appear during an array
--- 4906,4920 ----
      {
        if (expr1->ts.u.cl->length == NULL
  	    || expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
! 	return true;
  
        if (expr2->ts.u.cl->length == NULL
  	    || expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
! 	return true;
  
        if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
  		     expr2->ts.u.cl->length->value.integer) != 0)
! 	return true;
      }
  
    /* Check that no LHS component references appear during an array
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 4931,4937 ****
        if (ref->type == REF_ARRAY)
  	seen_array_ref= true;
        else if (ref->type == REF_COMPONENT && seen_array_ref)
! 	return NULL;
      }
  
    /* Check for a dependency.  */
--- 4928,4934 ----
        if (ref->type == REF_ARRAY)
  	seen_array_ref= true;
        else if (ref->type == REF_COMPONENT && seen_array_ref)
! 	return true;
      }
  
    /* Check for a dependency.  */
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 4939,4944 ****
--- 4936,4997 ----
  				   expr2->value.function.esym,
  				   expr2->value.function.actual,
  				   NOT_ELEMENTAL))
+     return true;
+ 
+   /* If we have reached here with an intrinsic function, we do not
+      need a temporary.  */
+   if (expr2->value.function.isym)
+     return false;
+ 
+   /* If the LHS is a dummy, we need a temporary if it is not
+      INTENT(OUT).  */
+   if (sym->attr.dummy && sym->attr.intent != INTENT_OUT)
+     return true;
+ 
+   /* A PURE function can unconditionally be called without a temporary.  */
+   if (expr2->value.function.esym != NULL
+       && expr2->value.function.esym->attr.pure)
+     return false;
+ 
+   /* TODO a function that could correctly be declared PURE but is not
+      could do with returning false as well.  */
+ 
+   if (!sym->attr.use_assoc
+ 	&& !sym->attr.in_common
+ 	&& !sym->attr.pointer
+ 	&& !sym->attr.target
+ 	&& expr2->value.function.esym)
+     {
+       /* A temporary is not needed if the function is not contained and
+ 	 the variable is local or host associated and not a pointer or
+ 	 a target. */
+       if (!expr2->value.function.esym->attr.contained)
+ 	return false;
+ 
+       /* A temporary is not needed if the variable is local and not
+ 	 a pointer, a target or a result.  */
+       if (sym->ns->parent
+ 	    && expr2->value.function.esym->ns == sym->ns->parent)
+ 	return false;
+     }
+ 
+   /* Default to temporary use.  */
+   return true;
+ }
+ 
+ 
+ /* Try to translate array(:) = func (...), where func is a transformational
+    array function, without using a temporary.  Returns NULL is this isn't the
+    case.  */
+ 
+ static tree
+ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
+ {
+   gfc_se se;
+   gfc_ss *ss;
+   gfc_component *comp = NULL;
+ 
+   if (arrayfunc_assign_needs_temporary (expr1, expr2))
      return NULL;
  
    /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
Index: gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90	(revision 0)
***************
*** 0 ****
--- 1,164 ----
+ ! { dg-do run }
+ ! Tests the fic for PR44582, where gfortran was found to
+ ! produce an incorrect result when the result of a function
+ ! was aliased by a host or use associated variable, to which
+ ! the function is assigned. In these cases a temporary is
+ ! required in the function assignments. The check has to be
+ ! rather restrictive.  Whilst the cases marked below might
+ ! not need temporaries, the TODOs are going to be tough.
+ !
+ ! Reported by Yin Ma <yin@absoft.com> and
+ ! elaborated by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ module foo
+   INTEGER, PARAMETER :: ONE = 1
+   INTEGER, PARAMETER :: TEN = 10
+   INTEGER, PARAMETER :: FIVE = TEN/2
+   INTEGER, PARAMETER :: TWO = 2
+   integer :: foo_a(ONE)
+   integer :: check(ONE) = TEN
+   LOGICAL :: abort_flag = .false. 
+ contains
+   function foo_f()
+      integer :: foo_f(ONE)
+      foo_f = -FIVE
+      foo_f = foo_a - foo_f
+   end function foo_f
+   subroutine bar
+     foo_a = FIVE
+ ! This aliases 'foo_a' by host association.
+     foo_a = foo_f ()
+     if (any (foo_a .ne. check)) call myabort (0)
+   end subroutine bar
+   subroutine myabort(fl)
+     integer :: fl
+     print *, fl
+     abort_flag = .true.
+   end subroutine myabort
+ end module foo
+ 
+ function h_ext()
+   use foo
+   integer :: h_ext(ONE)
+   h_ext = -FIVE
+   h_ext = FIVE - h_ext
+ end function h_ext
+ 
+ function i_ext() result (h)
+   use foo
+   integer :: h(ONE)
+   h = -FIVE
+   h = FIVE - h
+ end function i_ext
+ 
+ subroutine tobias
+   use foo
+   integer :: a(ONE)
+   a = FIVE
+   call sub1(a)
+   if (any (a .ne. check)) call myabort (1)
+ contains
+   subroutine sub1(x)
+     integer :: x(ONE)
+ ! 'x' is aliased by host association in 'f'.
+     x = f()
+   end subroutine sub1
+   function f()
+     integer :: f(ONE)
+     f = ONE
+     f = a + FIVE
+   end function f
+ end subroutine tobias
+ 
+ program test
+   use foo
+   implicit none
+   common /foo_bar/ c
+   integer :: a(ONE), b(ONE), c(ONE), d(ONE)
+   interface
+     function h_ext()
+       use foo
+       integer :: h_ext(ONE)
+     end function h_ext
+   end interface
+   interface
+     function i_ext() result (h)
+       use foo
+       integer :: h(ONE)
+     end function i_ext
+   end interface
+ 
+   a = FIVE
+ ! This aliases 'a' by host association
+   a = f()
+   if (any (a .ne. check)) call myabort (2)
+   a = FIVE
+   if (any (f() .ne. check)) call myabort (3)
+   call bar
+   foo_a = FIVE
+ ! This aliases 'foo_a' by host association.
+   foo_a = g ()
+   if (any (foo_a .ne. check)) call myabort (4)
+   a = FIVE
+   a = h()           ! TODO: Needs no temporary
+   if (any (a .ne. check)) call myabort (5)
+   a = FIVE
+   a = i()           ! TODO: Needs no temporary
+   if (any (a .ne. check)) call myabort (6)
+   a = FIVE
+   a = h_ext()       ! Needs no temporary - was OK
+   if (any (a .ne. check)) call myabort (15)
+   a = FIVE
+   a = i_ext()       ! Needs no temporary - was OK
+   if (any (a .ne. check)) call myabort (16)
+   c = FIVE
+ ! This aliases 'c' through the common block.
+   c = j()
+   if (any (c .ne. check)) call myabort (7)
+   call aaa
+   call tobias
+   if (abort_flag) call abort
+ contains
+   function f()
+      integer :: f(ONE)
+      f = -FIVE
+      f = a - f
+   end function f
+   function g()
+      integer :: g(ONE)
+      g = -FIVE
+      g = foo_a - g
+   end function g
+   function h()
+      integer :: h(ONE)
+      h = -FIVE
+      h = FIVE - h
+   end function h
+   function i() result (h)
+      integer :: h(ONE)
+      h = -FIVE
+      h = FIVE - h
+   end function i
+   function j()
+      common /foo_bar/ cc
+      integer :: j(ONE), cc(ONE)
+      j = -FIVE
+      j = cc - j
+   end function j
+   subroutine aaa()
+     d = TEN - TWO
+ ! This aliases 'd' through 'get_d'.
+     d = bbb()
+     if (any (d .ne. check)) call myabort (8)
+   end subroutine aaa
+   function bbb()
+     integer :: bbb(ONE)
+     bbb = TWO
+     bbb = bbb + get_d()
+   end function bbb
+   function get_d()
+     integer :: get_d(ONE)
+     get_d = d
+   end function get_d
+ end program test
+ ! { dg-final { cleanup-modules "foo" } }