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

Fortran: Auto array allocation with function dependencies [PR59104]

Browse source 
2024-06-20  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/59104
	* dependency.cc (dependency_fcn, gfc_function_dependency): New
	functions to detect dependency in array bounds and character
	lengths on old style function results.
	* dependency.h : Add prototype for gfc_function_dependency.
	* error.cc (error_print): Remove trailing space.
	* gfortran.h : Remove dummy_order and add fn_result_spec.
	* symbol.cc : Remove declaration of next_dummy_order..
	(gfc_set_sym_referenced): remove setting of symbol dummy order.
	* trans-array.cc (gfc_trans_auto_array_allocation): Detect
	non-dummy symbols with function dependencies and put the
	allocation at the end of the initialization code.
	* trans-decl.cc : Include dependency.h.
	(decl_order): New function that determines uses the location
	field of the symbol 'declared_at' to determine the order of two
	declarations.
	(gfc_defer_symbol_init): Call gfc_function_dependency to put
	dependent symbols in the right part of the tlink chain. Use
	the location field of the symbol declared_at to determine the
	order of declarations.
	(gfc_trans_auto_character_variable): Put character length
	initialization of dependent symbols at the end of the chain.
	* trans.cc (gfc_add_init_cleanup): Add boolean argument with
	default false that determines whther an expression is placed at
	the back or the front of the initialization chain.
	* trans.h : Update the prototype for gfc_add_init_cleanup.

gcc/testsuite/
	PR fortran/59104
	* gfortran.dg/dependent_decls_2.f90: New test.

(cherry picked from commit ccaa39a268bef2a1d8880022696ff2dcaa6af941)
This commit is contained in:
Paul Thomas 2024-06-20 08:01:36 +01:00
parent 1205104bbe
commit 5034af8223
10 changed files with 238 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

82
gcc/fortran/dependency.cc
View file

@ -2497,3 +2497,85 @@ 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,3 +43,5 @@ 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,10 +1887,6 @@ 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
@ -1929,6 +1925,8 @@ 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,11 +96,6 @@ 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;
@ -941,15 +936,10 @@ 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

@ -6866,6 +6866,7 @@ 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));
@ -6877,6 +6878,12 @@ 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. */
@ -6904,7 +6911,8 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
if (onstack)
{
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
back);
return;
}
@ -6991,10 +6999,11 @@ 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);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
back);
tmp = NULL_TREE;
}
gfc_add_init_cleanup (block, inittree, tmp);
gfc_add_init_cleanup (block, inittree, tmp, back);
}

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

@ -49,6 +49,7 @@ 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
@ -832,6 +833,19 @@ 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. */
@ -849,18 +863,34 @@ 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 || p->dummy_order > sym->dummy_order))
{
last = p;
p = p->tlink;
}
&& (!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;
}
}
/* Insert in between last and p. */
last->tlink = sym;
@ -4176,12 +4206,19 @@ 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);
@ -4194,7 +4231,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);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE, back);
}
/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */

5
gcc/fortran/trans.cc
View file

@ -2803,14 +2803,15 @@ 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)
gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup,
bool back)
{
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, true);
add_expr_to_chain (&block->init, init, !back);
add_expr_to_chain (&block->cleanup, cleanup, false);
}

3
gcc/fortran/trans.h
View file

@ -471,7 +471,8 @@ 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);
void gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup,
bool back = false);
/* 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 Normal file
View file

@ -0,0 +1,89 @@
! { 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