FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Revert "Fortran: Auto array allocation with function dependencies [PR59104]"

Browse source 
This reverts commit 5034af8223.
This commit is contained in:
Paul Thomas 2024-07-20 10:42:40 +01:00
parent 6b6a056891
commit 94e4661fee
10 changed files with 29 additions and 238 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

82
gcc/fortran/dependency.cc
View file

@ -2497,85 +2497,3 @@ gfc_omp_expr_prefix_same (gfc_expr *lexpr, gfc_expr *rexpr)
return true;
}
/* gfc_function_dependency returns true for non-dummy symbols with dependencies
on an old-fashioned function result (ie. proc_name = proc_name->result).
This is used to ensure that initialization code appears after the function
result is treated and that any mutual dependencies between these symbols are
respected. */
static bool
dependency_fcn (gfc_expr *e, gfc_symbol *sym,
int *f ATTRIBUTE_UNUSED)
{
if (e == NULL)
return false;
if (e && e->expr_type == EXPR_VARIABLE)
{
if (e->symtree && e->symtree->n.sym == sym)
return true;
/* Recurse to see if this symbol is dependent on the function result. If
so an indirect dependence exists, which should be handled in the same
way as a direct dependence. The recursion is prevented from being
infinite by statement order. */
else if (e->symtree && e->symtree->n.sym)
return gfc_function_dependency (e->symtree->n.sym, sym);
}
return false;
}
bool
gfc_function_dependency (gfc_symbol *sym, gfc_symbol *proc_name)
{
bool dep = false;
if (proc_name && proc_name->attr.function
&& proc_name == proc_name->result
&& !(sym->attr.dummy || sym->attr.result))
{
if (sym->fn_result_dep)
return true;
if (sym->as && sym->as->type == AS_EXPLICIT)
{
for (int dim = 0; dim < sym->as->rank; dim++)
{
if (sym->as->lower[dim]
&& sym->as->lower[dim]->expr_type != EXPR_CONSTANT)
dep = gfc_traverse_expr (sym->as->lower[dim], proc_name,
dependency_fcn, 0);
if (dep)
{
sym->fn_result_dep = 1;
return true;
}
if (sym->as->upper[dim]
&& sym->as->upper[dim]->expr_type != EXPR_CONSTANT)
dep = gfc_traverse_expr (sym->as->upper[dim], proc_name,
dependency_fcn, 0);
if (dep)
{
sym->fn_result_dep = 1;
return true;
}
}
}
if (sym->ts.type == BT_CHARACTER
&& sym->ts.u.cl && sym->ts.u.cl->length
&& sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
dep = gfc_traverse_expr (sym->ts.u.cl->length, proc_name,
dependency_fcn, 0);
if (dep)
{
sym->fn_result_dep = 1;
return true;
}
}
return false;
}

4
gcc/fortran/dependency.h
View file

@ -23,7 +23,7 @@ enum gfc_dep_check
{
NOT_ELEMENTAL, /* Not elemental case: normal dependency check. */
ELEM_CHECK_VARIABLE, /* Test whether variables overlap. */
ELEM_DONT_CHECK_VARIABLE /* Test whether variables overlap only if used
ELEM_DONT_CHECK_VARIABLE /* Test whether variables overlap only if used
in an expression. */
};
@ -43,5 +43,3 @@ bool gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *);
bool gfc_omp_expr_prefix_same (gfc_expr *, gfc_expr *);
gfc_expr * gfc_discard_nops (gfc_expr *);
bool gfc_function_dependency (gfc_symbol *, gfc_symbol *);

2
gcc/fortran/error.cc
View file

@ -892,7 +892,7 @@ error_print (const char *type, const char *format0, va_list argp)
#else
m = INTTYPE_MAXIMUM (ptrdiff_t);
#endif
m = 2 * m + 1;
m = 2 * m + 1;
error_uinteger (a & m);
}
else

6
gcc/fortran/gfortran.h
View file

@ -1887,6 +1887,10 @@ typedef struct gfc_symbol
points to C and B's is NULL. */
struct gfc_common_head* common_head;
/* Make sure setup code for dummy arguments is generated in the correct
order. */
int dummy_order;
gfc_namelist *namelist, *namelist_tail;
/* The tlink field is used in the front end to carry the module
@ -1925,8 +1929,6 @@ typedef struct gfc_symbol
unsigned forall_index:1;
/* Set if the symbol is used in a function result specification . */
unsigned fn_result_spec:1;
/* Set if the symbol spec. depends on an old-style function result. */
unsigned fn_result_dep:1;
/* Used to avoid multiple resolutions of a single symbol. */
/* = 2 if this has already been resolved as an intrinsic,
in gfc_resolve_intrinsic,

10
gcc/fortran/symbol.cc
View file

@ -96,6 +96,11 @@ const mstring dtio_procs[] =
minit ("_dtio_unformatted_write", DTIO_WUF),
};
/* This is to make sure the backend generates setup code in the correct
order. */
static int next_dummy_order = 1;
gfc_namespace *gfc_current_ns;
gfc_namespace *gfc_global_ns_list;
@ -936,10 +941,15 @@ conflict:
void
gfc_set_sym_referenced (gfc_symbol *sym)
{
if (sym->attr.referenced)
return;
sym->attr.referenced = 1;
/* Remember which order dummy variables are accessed in. */
if (sym->attr.dummy)
sym->dummy_order = next_dummy_order++;
}

15
gcc/fortran/trans-array.cc
View file

@ -6871,7 +6871,6 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
tree space;
tree inittree;
bool onstack;
bool back;
gcc_assert (!(sym->attr.pointer || sym->attr.allocatable));
@ -6883,12 +6882,6 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
gcc_assert (GFC_ARRAY_TYPE_P (type));
onstack = TREE_CODE (type) != POINTER_TYPE;
/* In the case of non-dummy symbols with dependencies on an old-fashioned
function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
must be called with the last, optional argument false so that the alloc-
ation occurs after the processing of the result. */
back = sym->fn_result_dep;
gfc_init_block (&init);
/* Evaluate character string length. */
@ -6916,8 +6909,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
if (onstack)
{
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
back);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
return;
}
@ -7004,11 +6996,10 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
addr = fold_build1_loc (gfc_get_location (&sym->declared_at),
ADDR_EXPR, TREE_TYPE (decl), space);
gfc_add_modify (&init, decl, addr);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
back);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
tmp = NULL_TREE;
}
gfc_add_init_cleanup (block, inittree, tmp, back);
gfc_add_init_cleanup (block, inittree, tmp);
}

51
gcc/fortran/trans-decl.cc
View file

@ -49,7 +49,6 @@ along with GCC; see the file COPYING3. If not see
#include "omp-general.h"
#include "attr-fnspec.h"
#include "tree-iterator.h"
#include "dependency.h"
#define MAX_LABEL_VALUE 99999
@ -833,19 +832,6 @@ gfc_allocate_lang_decl (tree decl)
DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> ();
}
/* Determine order of two symbol declarations. */
static bool
decl_order (gfc_symbol *sym1, gfc_symbol *sym2)
{
if (sym1->declared_at.lb->location > sym2->declared_at.lb->location)
return true;
else
return false;
}
/* Remember a symbol to generate initialization/cleanup code at function
entry/exit. */
@ -863,34 +849,18 @@ gfc_defer_symbol_init (gfc_symbol * sym)
last = head = sym->ns->proc_name;
p = last->tlink;
gfc_function_dependency (sym, head);
/* Make sure that setup code for dummy variables which are used in the
setup of other variables is generated first. */
if (sym->attr.dummy)
{
/* Find the first dummy arg seen after us, or the first non-dummy arg.
This is a circular list, so don't go past the head. */
This is a circular list, so don't go past the head. */
while (p != head
&& (!p->attr.dummy || decl_order (p, sym)))
{
last = p;
p = p->tlink;
}
}
else if (sym->fn_result_dep)
{
/* In the case of non-dummy symbols with dependencies on an old-fashioned
function result (ie. proc_name = proc_name->result), make sure that the
order in the tlink chain is such that the code appears in declaration
order. This ensures that mutual dependencies between these symbols are
respected. */
while (p != head
&& (!p->attr.result || decl_order (sym, p)))
{
last = p;
p = p->tlink;
}
&& (!p->attr.dummy || p->dummy_order > sym->dummy_order))
{
last = p;
p = p->tlink;
}
}
/* Insert in between last and p. */
last->tlink = sym;
@ -4206,19 +4176,12 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
stmtblock_t init;
tree decl;
tree tmp;
bool back;
gcc_assert (sym->backend_decl);
gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
gfc_init_block (&init);
/* In the case of non-dummy symbols with dependencies on an old-fashioned
function result (ie. proc_name = proc_name->result), gfc_add_init_cleanup
must be called with the last, optional argument false so that the process
ing of the character length occurs after the processing of the result. */
back = sym->fn_result_dep;
/* Evaluate the string length expression. */
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
@ -4231,7 +4194,7 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&init, tmp);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE, back);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
}
/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */

5
gcc/fortran/trans.cc
View file

@ -2803,15 +2803,14 @@ gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
/* Add a new pair of initializers/clean-up code. */
void
gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup,
bool back)
gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
{
gcc_assert (block);
/* The new pair of init/cleanup should be "wrapped around" the existing
block of code, thus the initialization is added to the front and the
cleanup to the back. */
add_expr_to_chain (&block->init, init, !back);
add_expr_to_chain (&block->init, init, true);
add_expr_to_chain (&block->cleanup, cleanup, false);
}

3
gcc/fortran/trans.h
View file

@ -471,8 +471,7 @@ void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);
/* Add a pair of init/cleanup code to the block. Each one might be a
NULL_TREE if not required. */
void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup,
bool back = false);
void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup);
/* Finalize the block, that is, create a single expression encapsulating the
original code together with init and clean-up code. */
tree gfc_finish_wrapped_block (gfc_wrapped_block* block);

89
gcc/testsuite/gfortran.dg/dependent_decls_2.f90
View file

@ -1,89 +0,0 @@
! { dg-do run }
!
! Fix for PR59104 in which the dependence on the old style function result
! was not taken into account in the ordering of auto array allocation and
! characters with dependent lengths.
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
module m
implicit none
integer, parameter :: dp = kind([double precision::])
contains
function f(x)
integer, intent(in) :: x
real(dp) f(x/2)
real(dp) g(x/2)
integer y(size (f)+1) ! This was the original problem
integer z(size (f) + size (y)) ! Found in development of the fix
integer w(size (f) + size (y) + x) ! Check dummy is OK
integer :: l1(size(y))
integer :: l2(size(z))
integer :: l3(size(w))
f = 10.0
y = 1 ! Stop -Wall from complaining
z = 1; g = 1; w = 1; l1 = 1; l2 = 1; l3 = 1
if (size (f) .ne. 1) stop 1
if (size (g) .ne. 1) stop 2
if (size (y) .ne. 2) stop 3
if (size (z) .ne. 3) stop 4
if (size (w) .ne. 5) stop 5
if (size (l1) .ne. 2) stop 6 ! Check indirect dependencies
if (size (l2) .ne. 3) stop 7
if (size (l3) .ne. 5) stop 8
end function f
function e(x) result(f)
integer, intent(in) :: x
real(dp) f(x/2)
real(dp) g(x/2)
integer y(size (f)+1)
integer z(size (f) + size (y)) ! As was this.
integer w(size (f) + size (y) + x)
integer :: l1(size(y))
integer :: l2(size(z))
integer :: l3(size(w))
f = 10.0
y = 1; z = 1; g = 1; w = 1; l1 = 1; l2 = 1; l3 = 1
if (size (f) .ne. 2) stop 9
if (size (g) .ne. 2) stop 10
if (size (y) .ne. 3) stop 11
if (size (z) .ne. 5) stop 12
if (size (w) .ne. 9) stop 13
if (size (l1) .ne. 3) stop 14 ! Check indirect dependencies
if (size (l2) .ne. 5) stop 15
if (size (l3) .ne. 9) stop 16
end function
function d(x) ! After fixes to arrays, what was needed was known!
integer, intent(in) :: x
character(len = x/2) :: d
character(len = len (d)) :: line
character(len = len (d) + len (line)) :: line2
character(len = len (d) + len (line) + x) :: line3
! Commented out lines give implicit type warnings with gfortran and nagfor
! character(len = len (d)) :: line4 (len (line3))
character(len = len (line3)) :: line4 (len (line3))
! character(len = size(len4, 1)) :: line5
line = repeat ("a", len (d))
line2 = repeat ("b", x)
line3 = repeat ("c", len (line3))
if (len (line2) .ne. x) stop 17
if (line3 .ne. "cccccccc") stop 18
d = line
line4 = line3
if (size (line4) .ne. 8) stop 19
if (any (line4 .ne. "cccccccc")) stop 20
end
end module m
program p
use m
implicit none
real(dp) y
y = sum (f (2))
if (int (y) .ne. 10) stop 21
y = sum (e (4))
if (int (y) .ne. 20) stop 22
if (d (4) .ne. "aa") stop 23
end program p