diff mbox

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

Message ID AANLkTil-gqzM_IUMoJVCsgKtV4ymWgOSotoMa39oCWFQ@mail.gmail.com
State New
Headers show

Commit Message

Paul Richard Thomas June 28, 2010, 4:47 p.m. UTC 
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.

Comments

Tobias Burnus June 28, 2010, 6:21 p.m. UTC | #1 
Paul Richard Thomas wrote:
> Bootstrapped and regtested on FC9/x86_64 - OK for trunk, 4.5,4.4 and 4.3?
>   

Thanks for the patch, which is OK - except for the following nit:

! arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
[...]
    /* Elemental functions don't need a temporary anyway.  */
    if (expr2->value.function.esym != NULL
        && expr2->value.function.esym->attr.elemental)
!     return true;

I think the comment is misleading - given the function name and the return value; can you make the comment a bit clearer?


Tobias

> 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.
>
Paul Richard Thomas June 28, 2010, 6:39 p.m. UTC | #2 
Dear Tobias,

Thanks for the review.

> Thanks for the patch, which is OK - except for the following nit:
>
> ! arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
> [...]
>    /* Elemental functions don't need a temporary anyway.  */
>    if (expr2->value.function.esym != NULL
>        && expr2->value.function.esym->attr.elemental)
> !     return true;
>
> I think the comment is misleading - given the function name and the return value; can you make the comment a bit clearer?

Indeed - this is, of course, the original comment.  I'll check them all :-)

Cheers

Paul
Mikael Morin June 28, 2010, 8:44 p.m. UTC | #3 
Tobias has already approved the patch ; however, I'm not so sure about 
this :

Le 28.06.2010 18:47, Paul Richard Thomas a écrit :
> +
> +   /* 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;



Quote from Tobias in the PR :

> Example:
>
>   real :: a(100)
>   call test(a)
> contains
>   subroutine test(x)
>     real, INTENT(OUT) :: x(:)
>     x = f()
>   end subroutine test
>
> Here, no temporary is needed for "x = f()": The dummy "x" is INTENT(OUT) thus
> the actual argument (i.e. "a") becomes undefined. Thus, the following function
> is invalid as "a" is (also) undefined in "f":
>
>   function f()
>     real :: f(100)
>     f = a
>   end function f
> end


Does it work if we rewrite the test function above as :

subroutine test(x)
   real, INTENT(OUT) :: x(:)
   x = 1
   x = f()
end subroutine test

Here, isn't "a" defined at the time "f" is called ? (Thus temporary needed)

Mikael
Tobias Burnus June 28, 2010, 9:16 p.m. UTC | #4 
Mikael Morin wrote:
> Tobias has already approved the patch ; however, I'm not so sure about
> this :
>  
>> +   /* 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;

> Does it work if we rewrite the test function above as :
> subroutine test(x)
>   real, INTENT(OUT) :: x(:)
>   x = 1
>   x = f()
> end subroutine test
> Here, isn't "a" defined at the time "f" is called ? (Thus temporary
> needed)

I think it does:

First, I think we agree that the actual argument associated with the
dummy "x" is undefined as soon as we enter "test" (cf. 12.5.2.4 below).

Secondly, can one access the data? Well, yes - but *only* through the
dummy argument - not by somehow accessing the actual argument of some of
its alias (cf. 12.5.2.13 (4)).

Thus, I think the patch is OK. Do you agree?

"12.5.2.4 Ordinary dummy variables" (F2008) has:
"If a dummy argument has INTENT (OUT) or INTENT (INOUT), the actual
argument shall be definable. If a dummy argument has INTENT (OUT), the
actual argument becomes undened at the time the association is
established, except for direct components of an object of derived type
for which default initialization has been specified."

"12.5.2.13 Restrictions on entities associated with dummy arguments"
"While an entity is associated with a dummy argument, the following
restrictions hold. [...]
(3) Action that affects the value of the entity or any subobject of it
shall be taken only through the
dummy argument unless [...]
(4) If the value of the entity or any subobject of it is affected
through the dummy argument, then at
any time during the invocation and execution of the procedure, either
before or after the denition,
it may be referenced only through that dummy argument [...]"

Tobias
Paul Richard Thomas June 28, 2010, 10:32 p.m. UTC | #5 
Dear All,

>
> Thus, I think the patch is OK. Do you agree?
>
> "12.5.2.4 Ordinary dummy variables" (F2008) has:
> "If a dummy argument has INTENT (OUT) or INTENT (INOUT), the actual
> argument shall be definable. If a dummy argument has INTENT (OUT), the
> actual argument becomes unde ned at the time the association is
> established, except for direct components of an object of derived type
> for which default initialization has been specified."
>
> "12.5.2.13 Restrictions on entities associated with dummy arguments"
> "While an entity is associated with a dummy argument, the following
> restrictions hold. [...]
> (3) Action that affects the value of the entity or any subobject of it
> shall be taken only through the
> dummy argument unless [...]
> (4) If the value of the entity or any subobject of it is affected
> through the dummy argument, then at
> any time during the invocation and execution of the procedure, either
> before or after the de nition,
> it may be referenced only through that dummy argument [...]"

What's the verdict??

Paul
H.J. Lu Oct. 29, 2010, 2:33 p.m. UTC | #6 
On Mon, Jun 28, 2010 at 9:47 AM, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> 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.
>

This caused:

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=46213
diff mbox

Patch

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