mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-03-21 17:21:03 +08:00
re PR fortran/64952 (Missing temporary in assignment from elemental function)
2015-03-23 Paul Thomas <pault@gcc.gnu.org> Mikael Morin <mikael@gcc.gnu.org> 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 <mikael@gcc.gnu.org> From-SVN: r221586
This commit is contained in:
Paul Thomas
Mikael Morin
parent
af3eb11068
commit
30c931de07
@ -1,3 +1,27 @@
|
||||
2015-03-23 Paul Thomas <pault@gcc.gnu.org>
|
||||
Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
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 <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR libgfortran/59513
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
|
||||
@ -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. */
|
||||
|
||||
@ -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. */
|
||||
|
||||
@ -1,3 +1,10 @@
|
||||
2015-03-23 Paul Thomas <pault@gcc.gnu.org>
|
||||
Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/64952
|
||||
* gfortran.dg/elemental_dependency_4.f90: New.
|
||||
* gfortran.dg/elemental_dependency_5.f90: New.
|
||||
|
||||
2015-03-22 Jan Hubicka <hubicka@ucw.cz>
|
||||
|
||||
PR ipa/65475
|
||||
|
||||
167
gcc/testsuite/gfortran.dg/elemental_dependency_4.f90
Normal file
167
gcc/testsuite/gfortran.dg/elemental_dependency_4.f90
Normal file
@ -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 <nmm1@cam.ac.uk> on clf
|
||||
! https://groups.google.com/forum/#!topic/comp.lang.fortran/TvVY5j3GPmg
|
||||
!
|
||||
! Other tests are due to Mikael Morin <mikael.morin@sfr.fr>
|
||||
!
|
||||
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" } }
|
||||
61
gcc/testsuite/gfortran.dg/elemental_dependency_5.f90
Normal file
61
gcc/testsuite/gfortran.dg/elemental_dependency_5.f90
Normal file
@ -0,0 +1,61 @@
|
||||
! { dg-do run }
|
||||
!
|
||||
! Tests the fix for PR64952.
|
||||
!
|
||||
! Original report by Nick Maclaren <nmm1@cam.ac.uk> on clf
|
||||
! https://groups.google.com/forum/#!topic/comp.lang.fortran/TvVY5j3GPmg
|
||||
! See elemental_dependency_4.f90
|
||||
!
|
||||
! This test contributed by Mikael Morin <mikael.morin@sfr.fr>
|
||||
!
|
||||
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
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user