OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/44582 (gfortran generates wrong results due to wrong ABI in function with array return) 

2010-06-29  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-29  Paul Thomas  <pault@gcc.gnu.org>

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

From-SVN: r161550
This commit is contained in:
Paul Thomas 2010-06-29 18:57:43 +00:00
parent b313b165a4
commit 42488c1b62
4 changed files with 254 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View File

@ -1,3 +1,13 @@
2010-06-29 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/40158

95
gcc/fortran/trans-expr.c
View File

@ -4870,41 +4870,40 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
}
/* Try to translate array(:) = func (...), where func is a transformational
array function, without using a temporary. Returns NULL is this isn't the
case. */
/* There are quite a lot of restrictions on the optimisation in using an
array function assign without a temporary. */
static tree
gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
static bool
arrayfunc_assign_needs_temporary (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;
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 NULL;
return true;
/* Elemental functions don't need a temporary anyway. */
/* Elemental functions are scalarized so that they don't need a
temporary in gfc_trans_assignment_1, so return a true. Otherwise,
they would need special treatment in gfc_trans_arrayfunc_assign. */
if (expr2->value.function.esym != NULL
&& expr2->value.function.esym->attr.elemental)
return NULL;
return true;
/* Fail if rhs is not FULL or a contiguous section. */
/* 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 NULL;
return true;
/* Fail if EXPR1 can't be expressed as a descriptor. */
/* Need a temporary if EXPR1 can't be expressed as a descriptor. */
if (gfc_ref_needs_temporary_p (expr1->ref))
return NULL;
return true;
/* Functions returning pointers need temporaries. */
if (expr2->symtree->n.sym->attr.pointer
|| expr2->symtree->n.sym->attr.allocatable)
return NULL;
return true;
/* Character array functions need temporaries unless the
character lengths are the same. */
@ -4912,15 +4911,15 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
{
if (expr1->ts.u.cl->length == NULL
|| expr1->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return NULL;
return true;
if (expr2->ts.u.cl->length == NULL
|| expr2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
return NULL;
return true;
if (mpz_cmp (expr1->ts.u.cl->length->value.integer,
expr2->ts.u.cl->length->value.integer) != 0)
return NULL;
return true;
}
/* Check that no LHS component references appear during an array
@ -4934,7 +4933,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
if (ref->type == REF_ARRAY)
seen_array_ref= true;
else if (ref->type == REF_COMPONENT && seen_array_ref)
return NULL;
return true;
}
/* Check for a dependency. */
@ -4942,6 +4941,62 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
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 if 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

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2010-06-29 Paul Thomas <pault@gcc.gnu.org>
PR fortran/44582
* gfortran.dg/aliasing_array_result_1.f90 : New test.
2010-06-29 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* lib/lto.exp (lto_prune_warns): Also accept leading single quote.

164
gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90 Normal file
View File

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