From 30c931de07f8fcbe4ef3b550633c274fe7828975 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 23 Mar 2015 07:53:31 +0000 Subject: [PATCH] re PR fortran/64952 (Missing temporary in assignment from elemental function) 2015-03-23 Paul Thomas Mikael Morin PR fortran/64952 fortran/ * gfortran.h (struct symbol_attribute) : New field 'array_outer_dependency'. * trans.h (struct gfc_ss_info): New field 'array_outer_dependency'. * module.c (enum ab_attribute): New value AB_ARRAY_OUTER_DEPENDENCY. (attr_bits): Append same value to initializer. (mio_symbol_attribute): Handle 'array_outer_dependency' attr in module read and write. * resolve.c (update_current_proc_outer_array_dependency): New function. (resolve_function, resolve_call): Add code to update current procedure's 'array_outer_dependency' attribute. (resolve_variable): Mark current procedure with attribute array_outer_dependency if the variable is an array coming from outside the current namespace. (resolve_fl_procedure): Mark a procedure without body with attribute 'array_outer_dependency'. * trans-array.c (gfc_conv_resolve_dependencies): If any ss is marked as 'array_outer_dependency' generate a temporary. (gfc_walk_function_expr): If the function may reference external arrays, mark the head gfc_ss with flag 'array_outer_dependency'. testsuite/ * gfortran.dg/elemental_dependency_4.f90: New. * gfortran.dg/elemental_dependency_5.f90: New. Co-Authored-By: Mikael Morin From-SVN: r221586 --- gcc/fortran/ChangeLog | 24 +++ gcc/fortran/gfortran.h | 7 + gcc/fortran/module.c | 9 +- gcc/fortran/resolve.c | 55 ++++++ gcc/fortran/trans-array.c | 19 +- gcc/fortran/trans.h | 4 + gcc/testsuite/ChangeLog | 7 + .../gfortran.dg/elemental_dependency_4.f90 | 167 ++++++++++++++++++ .../gfortran.dg/elemental_dependency_5.f90 | 61 +++++++ 9 files changed, 351 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/elemental_dependency_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/elemental_dependency_5.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c8c030844fd..473d3192a92 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2015-03-23 Paul Thomas + Mikael Morin + + PR fortran/64952 + * gfortran.h (struct symbol_attribute) : New field + 'array_outer_dependency'. + * trans.h (struct gfc_ss_info): New field 'array_outer_dependency'. + * module.c (enum ab_attribute): New value AB_ARRAY_OUTER_DEPENDENCY. + (attr_bits): Append same value to initializer. + (mio_symbol_attribute): Handle 'array_outer_dependency' attr + in module read and write. + * resolve.c (update_current_proc_outer_array_dependency): New function. + (resolve_function, resolve_call): Add code to update current procedure's + 'array_outer_dependency' attribute. + (resolve_variable): Mark current procedure with attribute + array_outer_dependency if the variable is an array coming from outside + the current namespace. + (resolve_fl_procedure): Mark a procedure without body with attribute + 'array_outer_dependency'. + * trans-array.c (gfc_conv_resolve_dependencies): If any ss is + marked as 'array_outer_dependency' generate a temporary. + (gfc_walk_function_expr): If the function may reference external arrays, + mark the head gfc_ss with flag 'array_outer_dependency'. + 2015-03-22 Jerry DeLisle PR libgfortran/59513 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ff0054e7029..9be20109bf6 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -789,6 +789,13 @@ typedef struct cannot alias. Note that this is zero for PURE procedures. */ unsigned implicit_pure:1; + /* This is set for a procedure that contains expressions referencing + arrays coming from outside its namespace. + This is used to force the creation of a temporary when the LHS of + an array assignment may be used by an elemental procedure appearing + on the RHS. */ + unsigned array_outer_dependency:1; + /* This is set if the subroutine doesn't return. Currently, this is only possible for intrinsic subroutines. */ unsigned noreturn:1; diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index b12f8247a91..1abfc46d7a5 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -1893,7 +1893,8 @@ typedef enum AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER, - AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET + AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET, + AB_ARRAY_OUTER_DEPENDENCY } ab_attribute; @@ -1949,6 +1950,7 @@ static const mstring attr_bits[] = minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE), minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY), minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET), + minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY), minit (NULL, -1) }; @@ -2129,6 +2131,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_VTAB, attr_bits); if (attr->omp_declare_target) MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits); + if (attr->array_outer_dependency) + MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits); mio_rparen (); @@ -2295,6 +2299,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_OMP_DECLARE_TARGET: attr->omp_declare_target = 1; break; + case AB_ARRAY_OUTER_DEPENDENCY: + attr->array_outer_dependency =1; + break; } } } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 465cf2ba8cf..2a24dfd8eda 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2866,6 +2866,32 @@ static bool check_pure_function (gfc_expr *e) } +/* Update current procedure's array_outer_dependency flag, considering + a call to procedure SYM. */ + +static void +update_current_proc_array_outer_dependency (gfc_symbol *sym) +{ + /* Check to see if this is a sibling function that has not yet + been resolved. */ + gfc_namespace *sibling = gfc_current_ns->sibling; + for (; sibling; sibling = sibling->sibling) + { + if (sibling->proc_name == sym) + { + gfc_resolve (sibling); + break; + } + } + + /* If SYM has references to outer arrays, so has the procedure calling + SYM. If SYM is a procedure pointer, we can assume the worst. */ + if (sym->attr.array_outer_dependency + || sym->attr.proc_pointer) + gfc_current_ns->proc_name->attr.array_outer_dependency = 1; +} + + /* Resolve a function call, which means resolving the arguments, then figuring out which entity the name refers to. */ @@ -3090,6 +3116,17 @@ resolve_function (gfc_expr *expr) expr->ts = expr->symtree->n.sym->result->ts; } + if (!expr->ref && !expr->value.function.isym) + { + if (expr->value.function.esym) + update_current_proc_array_outer_dependency (expr->value.function.esym); + else + update_current_proc_array_outer_dependency (sym); + } + else if (expr->ref) + /* typebound procedure: Assume the worst. */ + gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + return t; } @@ -3427,6 +3464,12 @@ resolve_call (gfc_code *c) if (!resolve_elemental_actual (NULL, c)) return false; + if (!c->expr1) + update_current_proc_array_outer_dependency (csym); + else + /* Typebound procedure: Assume the worst. */ + gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + return t; } @@ -5058,6 +5101,13 @@ resolve_variable (gfc_expr *e) && gfc_current_ns->parent->parent == sym->ns))) sym->attr.host_assoc = 1; + if (gfc_current_ns->proc_name + && sym->attr.dimension + && (sym->ns != gfc_current_ns + || sym->attr.use_assoc + || sym->attr.in_common)) + gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + resolve_procedure: if (t && !resolve_procedure_expression (e)) t = false; @@ -11494,6 +11544,11 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } } + /* Assume that a procedure whose body is not known has references + to external arrays. */ + if (sym->attr.if_source != IFSRC_DECL) + sym->attr.array_outer_dependency = 1; + return true; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 642110dc41f..0dbfdaab1b2 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4391,6 +4391,12 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, { ss_expr = ss->info->expr; + if (ss->info->array_outer_dependency) + { + nDepend = 1; + break; + } + if (ss->info->type != GFC_SS_SECTION) { if (flag_realloc_lhs @@ -9096,9 +9102,20 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) /* Walk the parameters of an elemental function. For now we always pass by reference. */ if (sym->attr.elemental || (comp && comp->attr.elemental)) - return gfc_walk_elemental_function_args (ss, expr->value.function.actual, + { + gfc_ss *old_ss = ss; + + ss = gfc_walk_elemental_function_args (old_ss, + expr->value.function.actual, gfc_get_proc_ifc_for_expr (expr), GFC_SS_REFERENCE); + if (ss != old_ss + && (comp + || sym->attr.proc_pointer + || sym->attr.if_source != IFSRC_DECL + || sym->attr.array_outer_dependency)) + ss->info->array_outer_dependency = 1; + } /* Scalar functions are OK as these are evaluated outside the scalarization loop. Pass back and let the caller deal with it. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 3ba2f88f0fd..be1136382ae 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -226,6 +226,10 @@ typedef struct gfc_ss_info /* Suppresses precalculation of scalars in WHERE assignments. */ unsigned where:1; + /* This set for an elemental function that contains expressions for + external arrays, thereby triggering creation of a temporary. */ + unsigned array_outer_dependency:1; + /* Tells whether the SS is for an actual argument which can be a NULL reference. In other words, the associated dummy argument is OPTIONAL. Used to handle elemental procedures. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d9747487b42..50d869112e2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2015-03-23 Paul Thomas + Mikael Morin + + PR fortran/64952 + * gfortran.dg/elemental_dependency_4.f90: New. + * gfortran.dg/elemental_dependency_5.f90: New. + 2015-03-22 Jan Hubicka PR ipa/65475 diff --git a/gcc/testsuite/gfortran.dg/elemental_dependency_4.f90 b/gcc/testsuite/gfortran.dg/elemental_dependency_4.f90 new file mode 100644 index 00000000000..fc15e641812 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_dependency_4.f90 @@ -0,0 +1,167 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! Tests the fix for PR64952, in which the assignment to 'array' should +! have generated a temporary because of the references to the lhs in +! the function 'Fred'. +! +! Original report, involving function 'Nick' +! Contributed by Nick Maclaren on clf +! https://groups.google.com/forum/#!topic/comp.lang.fortran/TvVY5j3GPmg +! +! Other tests are due to Mikael Morin +! +MODULE M + INTEGER, PRIVATE :: i + REAL :: arraym(5) = (/ (i+0.0, i = 1,5) /) +CONTAINS + ELEMENTAL FUNCTION Bill (n, x) + REAL :: Bill + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: x + Bill = x+SUM(arraym(:n-1))+SUM(arraym(n+1:)) + END FUNCTION Bill + + ELEMENTAL FUNCTION Charles (x) + REAL :: Charles + REAL, INTENT(IN) :: x + Charles = x + END FUNCTION Charles +END MODULE M + +ELEMENTAL FUNCTION Peter(n, x) + USE M + REAL :: Peter + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: x + Peter = Bill(n, x) +END FUNCTION Peter + +PROGRAM Main + use M + INTEGER :: i, index(5) = (/ (i, i = 1,5) /) + REAL :: array(5) = (/ (i+0.0, i = 1,5) /) + + INTERFACE + ELEMENTAL FUNCTION Peter(n, x) + REAL :: Peter + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: x + END FUNCTION Peter + END INTERFACE + + PROCEDURE(Robert2), POINTER :: missme => Null() + + ! Original testcase + array = Nick(index,array) + If (any (array .ne. array(1))) call abort + + array = (/ (i+0.0, i = 1,5) /) + ! This should not create a temporary + array = Charles(array) + If (any (array .ne. index)) call abort + ! { dg-final { scan-tree-dump-times "array\\\[\[^\\\]\]*\\\]\\s*=\\s*charles\\s*\\(&array\\\[\[^\\\]\]*\\\]\\);" 1 "original" } } + + ! Check use association of the function works correctly. + arraym = Bill(index,arraym) + if (any (arraym .ne. arraym(1))) call abort + + ! Check siblings interact correctly. + array = (/ (i+0.0, i = 1,5) /) + array = Henry(index) + if (any (array .ne. array(1))) call abort + + array = (/ (i+0.0, i = 1,5) /) + ! This should not create a temporary + array = index + Henry2(0) - array + ! { dg-final { scan-tree-dump-times "array\\\[\[^\\\]\]*\\\]\\s*=\\s*\\(\\(real\\(kind=4\\)\\)\\s*index\\\[\[^\\\]\]*\\\]\\s*\\+\\s*D.\\d*\\)\\s*-\\s*array\\\[\[^\\\]\]*\\\];" 1 "original" } } + if (any (array .ne. 15.0)) call abort + + arraym = (/ (i+0.0, i = 1,5) /) + arraym = Peter(index, arraym) + if (any (arraym .ne. 15.0)) call abort + + array = (/ (i+0.0, i = 1,5) /) + array = Robert(index) + if (any (arraym .ne. 15.0)) call abort + + missme => Robert2 + array = (/ (i+0.0, i = 1,5) /) + array = David(index) + if (any (arraym .ne. 15.0)) call abort + + array = (/ (i+0.0, i = 1,5) /) + array = James(index) + if (any (arraym .ne. 15.0)) call abort + + array = (/ (i+0.0, i = 1,5) /) + array = Romeo(index) + if (any (arraym .ne. 15.0)) call abort + +CONTAINS + ELEMENTAL FUNCTION Nick (n, x) + REAL :: Nick + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: x + Nick = x+SUM(array(:n-1))+SUM(array(n+1:)) + END FUNCTION Nick + +! Note that the inverse order of Henry and Henry2 is trivial. +! This way round, Henry2 has to be resolved before Henry can +! be marked as having an inherited external array reference. + ELEMENTAL FUNCTION Henry2 (n) + REAL :: Henry2 + INTEGER, INTENT(IN) :: n + Henry2 = n + SUM(array(:n-1))+SUM(array(n+1:)) + END FUNCTION Henry2 + + ELEMENTAL FUNCTION Henry (n) + REAL :: Henry + INTEGER, INTENT(IN) :: n + Henry = Henry2(n) + END FUNCTION Henry + + PURE FUNCTION Robert2(n) + REAL :: Robert2 + INTEGER, INTENT(IN) :: n + Robert2 = Henry(n) + END FUNCTION Robert2 + + ELEMENTAL FUNCTION Robert(n) + REAL :: Robert + INTEGER, INTENT(IN) :: n + Robert = Robert2(n) + END FUNCTION Robert + + ELEMENTAL FUNCTION David (n) + REAL :: David + INTEGER, INTENT(IN) :: n + David = missme(n) + END FUNCTION David + + ELEMENTAL SUBROUTINE James2 (o, i) + REAL, INTENT(OUT) :: o + INTEGER, INTENT(IN) :: i + o = Henry(i) + END SUBROUTINE James2 + + ELEMENTAL FUNCTION James(n) + REAL :: James + INTEGER, INTENT(IN) :: n + CALL James2(James, n) + END FUNCTION James + + FUNCTION Romeo2(n) + REAL :: Romeo2 + INTEGER, INTENT(in) :: n + Romeo2 = Henry(n) + END FUNCTION Romeo2 + + IMPURE ELEMENTAL FUNCTION Romeo(n) + REAL :: Romeo + INTEGER, INTENT(IN) :: n + Romeo = Romeo2(n) + END FUNCTION Romeo +END PROGRAM Main + +! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/elemental_dependency_5.f90 b/gcc/testsuite/gfortran.dg/elemental_dependency_5.f90 new file mode 100644 index 00000000000..42e92692d02 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_dependency_5.f90 @@ -0,0 +1,61 @@ +! { dg-do run } +! +! Tests the fix for PR64952. +! +! Original report by Nick Maclaren on clf +! https://groups.google.com/forum/#!topic/comp.lang.fortran/TvVY5j3GPmg +! See elemental_dependency_4.f90 +! +! This test contributed by Mikael Morin +! +MODULE M + INTEGER, PRIVATE :: i + + TYPE, ABSTRACT :: t + REAL :: f + CONTAINS + PROCEDURE(Fred_ifc), DEFERRED, PASS :: tbp + END TYPE t + TYPE, EXTENDS(t) :: t2 + CONTAINS + PROCEDURE :: tbp => Fred + END TYPE t2 + + TYPE(t2) :: array(5) = (/ (t2(i+0.0), i = 1,5) /) + + INTERFACE + ELEMENTAL FUNCTION Fred_ifc (x, n) + IMPORT + REAL :: Fred + CLASS(T), INTENT(IN) :: x + INTEGER, INTENT(IN) :: n + END FUNCTION Fred_ifc + END INTERFACE + +CONTAINS + ELEMENTAL FUNCTION Fred (x, n) + REAL :: Fred + CLASS(T2), INTENT(IN) :: x + INTEGER, INTENT(IN) :: n + Fred = x%f+SUM(array(:n-1)%f)+SUM(array(n+1:)%f) + END FUNCTION Fred +END MODULE M + +PROGRAM Main + USE M + INTEGER :: i, index(5) = (/ (i, i = 1,5) /) + + array%f = array%tbp(index) + if (any (array%f .ne. array(1)%f)) call abort + + array%f = index + call Jack(array) + CONTAINS + SUBROUTINE Jack(dummy) + CLASS(t) :: dummy(:) + dummy%f = dummy%tbp(index) + !print *, dummy%f + if (any (dummy%f .ne. 15.0)) call abort + END SUBROUTINE +END PROGRAM Main + -- 2.30.2