From 5d7ab965473e40d20b9db065754b4d9dd6869cf4 Mon Sep 17 00:00:00 2001 From: pault Date: Tue, 29 Jun 2010 18:57:43 +0000 Subject: [PATCH] 2010-06-29 Paul Thomas 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 PR fortran/44582 * gfortran.dg/aliasing_array_result_1.f90 : New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161550 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 10 ++ gcc/fortran/trans-expr.c | 95 +++++++++--- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/aliasing_array_result_1.f90 | 164 +++++++++++++++++++++ 4 files changed, 254 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 60d1e31876a..34c8f6407b5 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2010-06-29 Paul Thomas + + 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 PR fortran/40158 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 0164c163582..692b3e2f846 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3a555de59f2..6bdd576ca7a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-06-29 Paul Thomas + + PR fortran/44582 + * gfortran.dg/aliasing_array_result_1.f90 : New test. + 2010-06-29 Rainer Orth * lib/lto.exp (lto_prune_warns): Also accept leading single quote. diff --git a/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90 b/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90 new file mode 100644 index 00000000000..d8899d2ecf8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/aliasing_array_result_1.f90 @@ -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 and +! elaborated by Tobias Burnus +! +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" } } -- 2.11.4.GIT