[Patch, fortran] PR69423 - [6 Regression] Invalid optimization with deferred-length character
Paul Richard Thomas
paul.richard.thomas@gmail.com
Fri Feb 19 08:47:00 GMT 2016
Dear All,
This has proven to be a rather vexatious bug to fix. On the face of
it, using the indirect reference to the passed string length for
deferred character length functions should have worked at all levels
of optimization. However, setting the string length within a do loop
resulted in the change not being visible within the rest of the
function scope, even though the correct result was returned. This was,
on the face of it, the same mechanism used for both dummies and
declared results, which works fine at all levels of optimization.
In order to be as conservative as possible at this stage in the
release cycle, I have resorted to the belt and braces approach of
using a local variable '..result', which is nulled and returned, as
appropriate, in a new helper function. So that the compiled code is
consistent, I have done the same for functions with and without
explicitly declared result variables.
There is some dead code in 'gfc_get_symbol_decl', which could, with
advantage, be replaced by a gcc_assert. In addition,
gfc_trans_deferred_vars could do with some further tidying up to
ensure that the logic is clear. These steps can easily be done now if
other maintainers think that it is timely.
Bootstraps and regtests on FC21/x86_64 - OK for trunk?
Paul
2016-02-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/69423
* trans-decl.c (create_function_arglist): Deferred character
length functions, with and without declared results, address
the passed reference type as '.result' and the local string
length as '..result'.
(gfc_null_and_pass_deferred_len): Helper function to null and
return deferred string lengths, as needed.
(gfc_trans_deferred_vars): Call it, thereby reducing repeated
code, add call for deferred arrays and reroute pointer function
results. Avoid using 'tmp' for anything other that a temporary
tree by introducing 'type_of_array' for the arrayspec type.
2016-02-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/69423
* gfortran.dg/deferred_character_15.f90 : New test.
-------------- next part --------------
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 233507)
--- gcc/fortran/trans-decl.c (working copy)
*************** create_function_arglist (gfc_symbol * sy
*** 2234,2240 ****
PARM_DECL,
get_identifier (".__result"),
len_type);
! if (!sym->ts.u.cl->length)
{
sym->ts.u.cl->backend_decl = length;
TREE_USED (length) = 1;
--- 2234,2245 ----
PARM_DECL,
get_identifier (".__result"),
len_type);
! if (POINTER_TYPE_P (len_type))
! {
! sym->ts.u.cl->passed_length = length;
! TREE_USED (length) = 1;
! }
! else if (!sym->ts.u.cl->length)
{
sym->ts.u.cl->backend_decl = length;
TREE_USED (length) = 1;
*************** create_function_arglist (gfc_symbol * sy
*** 2271,2283 ****
type = gfc_sym_type (arg);
arg->backend_decl = backend_decl;
type = build_reference_type (type);
-
- if (POINTER_TYPE_P (len_type))
- {
- sym->ts.u.cl->passed_length = length;
- sym->ts.u.cl->backend_decl =
- build_fold_indirect_ref_loc (input_location, length);
- }
}
}
--- 2276,2281 ----
*************** init_intent_out_dt (gfc_symbol * proc_sy
*** 3917,3922 ****
--- 3915,3976 ----
}
+ /* Helper function to manage deferred string lengths. */
+
+ static tree
+ gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
+ locus *loc)
+ {
+ tree tmp;
+
+ /* Character length passed by reference. */
+ tmp = sym->ts.u.cl->passed_length;
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tmp = fold_convert (gfc_charlen_type_node, tmp);
+
+ if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
+ /* Zero the string length when entering the scope. */
+ gfc_add_modify (init, sym->ts.u.cl->backend_decl,
+ build_int_cst (gfc_charlen_type_node, 0));
+ else
+ {
+ tree tmp2;
+
+ tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node,
+ sym->ts.u.cl->backend_decl, tmp);
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp2 = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp2,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (init, tmp2);
+ }
+
+ gfc_restore_backend_locus (loc);
+
+ /* Pass the final character length back. */
+ if (sym->attr.intent != INTENT_IN)
+ {
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ gfc_charlen_type_node, tmp,
+ sym->ts.u.cl->backend_decl);
+ if (sym->attr.optional)
+ {
+ tree present = gfc_conv_expr_present (sym);
+ tmp = build3_loc (input_location, COND_EXPR,
+ void_type_node, present, tmp,
+ build_empty_stmt (input_location));
+ }
+ }
+ else
+ tmp = NULL_TREE;
+
+ return tmp;
+ }
+
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3966,3972 ****
/* An automatic character length, pointer array result. */
if (proc_sym->ts.type == BT_CHARACTER
&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
! gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
--- 4020,4037 ----
/* An automatic character length, pointer array result. */
if (proc_sym->ts.type == BT_CHARACTER
&& TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
! {
! tmp = NULL;
! if (proc_sym->ts.deferred)
! {
! gfc_save_backend_locus (&loc);
! gfc_set_backend_locus (&proc_sym->declared_at);
! tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc);
! gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
! }
! else
! gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
! }
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 3993,3999 ****
/* Pass back the string length on exit. */
tmp = proc_sym->ts.u.cl->backend_decl;
! if (TREE_CODE (tmp) != INDIRECT_REF)
{
tmp = proc_sym->ts.u.cl->passed_length;
tmp = build_fold_indirect_ref_loc (input_location, tmp);
--- 4058,4065 ----
/* Pass back the string length on exit. */
tmp = proc_sym->ts.u.cl->backend_decl;
! if (TREE_CODE (tmp) != INDIRECT_REF
! && proc_sym->ts.u.cl->passed_length)
{
tmp = proc_sym->ts.u.cl->passed_length;
tmp = build_fold_indirect_ref_loc (input_location, tmp);
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4072,4092 ****
= gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
}
! else if (sym->attr.dimension || sym->attr.codimension
! || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))
{
bool is_classarray = IS_CLASS_ARRAY (sym);
symbol_attribute *array_attr;
gfc_array_spec *as;
! array_type tmp;
array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
/* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
! tmp = as->type;
! if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed)
! tmp = AS_EXPLICIT;
! switch (tmp)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
--- 4138,4158 ----
= gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
}
! else if ((sym->attr.dimension || sym->attr.codimension
! || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
{
bool is_classarray = IS_CLASS_ARRAY (sym);
symbol_attribute *array_attr;
gfc_array_spec *as;
! array_type type_of_array;
array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
/* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
! type_of_array = as->type;
! if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed)
! type_of_array = AS_EXPLICIT;
! switch (type_of_array)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4169,4174 ****
--- 4235,4249 ----
case AS_DEFERRED:
seen_trans_deferred_array = true;
gfc_trans_deferred_array (sym, block);
+ if (sym->ts.type == BT_CHARACTER && sym->ts.deferred
+ && sym->attr.result)
+ {
+ tree tmp;
+ gfc_save_backend_locus (&loc);
+ gfc_set_backend_locus (&sym->declared_at);
+ tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
+ }
break;
default:
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4183,4188 ****
--- 4258,4264 ----
continue;
else if ((!sym->attr.dummy || sym->ts.deferred)
&& (sym->attr.allocatable
+ || (sym->attr.pointer && sym->attr.result)
|| (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable)))
{
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4190,4285 ****
{
tree descriptor = NULL_TREE;
- /* Nullify and automatic deallocation of allocatable
- scalars. */
- e = gfc_lval_expr_from_sym (sym);
- if (sym->ts.type == BT_CLASS)
- gfc_add_data_component (e);
-
- gfc_init_se (&se, NULL);
- if (sym->ts.type != BT_CLASS
- || sym->ts.u.derived->attr.dimension
- || sym->ts.u.derived->attr.codimension)
- {
- se.want_pointer = 1;
- gfc_conv_expr (&se, e);
- }
- else if (sym->ts.type == BT_CLASS
- && !CLASS_DATA (sym)->attr.dimension
- && !CLASS_DATA (sym)->attr.codimension)
- {
- se.want_pointer = 1;
- gfc_conv_expr (&se, e);
- }
- else
- {
- se.descriptor_only = 1;
- gfc_conv_expr (&se, e);
- descriptor = se.expr;
- se.expr = gfc_conv_descriptor_data_addr (se.expr);
- se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
- }
- gfc_free_expr (e);
-
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_start_block (&init);
! if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
{
! /* Nullify when entering the scope. */
! tmp = fold_build2_loc (input_location, MODIFY_EXPR,
! TREE_TYPE (se.expr), se.expr,
! fold_convert (TREE_TYPE (se.expr),
! null_pointer_node));
! if (sym->attr.optional)
{
! tree present = gfc_conv_expr_present (sym);
! tmp = build3_loc (input_location, COND_EXPR,
! void_type_node, present, tmp,
! build_empty_stmt (input_location));
}
- gfc_add_expr_to_block (&init, tmp);
- }
-
- if ((sym->attr.dummy || sym->attr.result)
- && sym->ts.type == BT_CHARACTER
- && sym->ts.deferred)
- {
- /* Character length passed by reference. */
- tmp = sym->ts.u.cl->passed_length;
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = fold_convert (gfc_charlen_type_node, tmp);
-
- if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
- /* Zero the string length when entering the scope. */
- gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
- build_int_cst (gfc_charlen_type_node, 0));
else
{
! tree tmp2;
!
! tmp2 = fold_build2_loc (input_location, MODIFY_EXPR,
! gfc_charlen_type_node,
! sym->ts.u.cl->backend_decl, tmp);
! if (sym->attr.optional)
! {
! tree present = gfc_conv_expr_present (sym);
! tmp2 = build3_loc (input_location, COND_EXPR,
! void_type_node, present, tmp2,
! build_empty_stmt (input_location));
! }
! gfc_add_expr_to_block (&init, tmp2);
}
! gfc_restore_backend_locus (&loc);
!
! /* Pass the final character length back. */
! if (sym->attr.intent != INTENT_IN)
{
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
! gfc_charlen_type_node, tmp,
! sym->ts.u.cl->backend_decl);
if (sym->attr.optional)
{
tree present = gfc_conv_expr_present (sym);
--- 4266,4315 ----
{
tree descriptor = NULL_TREE;
gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_start_block (&init);
! if (!sym->attr.pointer)
{
! /* Nullify and automatic deallocation of allocatable
! scalars. */
! e = gfc_lval_expr_from_sym (sym);
! if (sym->ts.type == BT_CLASS)
! gfc_add_data_component (e);
!
! gfc_init_se (&se, NULL);
! if (sym->ts.type != BT_CLASS
! || sym->ts.u.derived->attr.dimension
! || sym->ts.u.derived->attr.codimension)
{
! se.want_pointer = 1;
! gfc_conv_expr (&se, e);
! }
! else if (sym->ts.type == BT_CLASS
! && !CLASS_DATA (sym)->attr.dimension
! && !CLASS_DATA (sym)->attr.codimension)
! {
! se.want_pointer = 1;
! gfc_conv_expr (&se, e);
}
else
{
! se.descriptor_only = 1;
! gfc_conv_expr (&se, e);
! descriptor = se.expr;
! se.expr = gfc_conv_descriptor_data_addr (se.expr);
! se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
}
+ gfc_free_expr (e);
! if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
{
+ /* Nullify when entering the scope. */
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
! TREE_TYPE (se.expr), se.expr,
! fold_convert (TREE_TYPE (se.expr),
! null_pointer_node));
if (sym->attr.optional)
{
tree present = gfc_conv_expr_present (sym);
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4287,4302 ****
void_type_node, present, tmp,
build_empty_stmt (input_location));
}
}
- else
- tmp = NULL_TREE;
}
else
gfc_restore_backend_locus (&loc);
/* Deallocate when leaving the scope. Nullifying is not
needed. */
! if (!sym->attr.result && !sym->attr.dummy
&& !sym->ns->proc_name->attr.is_main_program)
{
if (sym->ts.type == BT_CLASS
--- 4317,4337 ----
void_type_node, present, tmp,
build_empty_stmt (input_location));
}
+ gfc_add_expr_to_block (&init, tmp);
}
}
+
+ if ((sym->attr.dummy || sym->attr.result)
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.deferred
+ && sym->ts.u.cl->passed_length)
+ tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
else
gfc_restore_backend_locus (&loc);
/* Deallocate when leaving the scope. Nullifying is not
needed. */
! if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer
&& !sym->ns->proc_name->attr.is_main_program)
{
if (sym->ts.type == BT_CLASS
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4313,4318 ****
--- 4348,4354 ----
gfc_free_expr (expr);
}
}
+
if (sym->ts.type == BT_CLASS)
{
/* Initialize _vptr to declared type. */
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4353,4371 ****
if (sym->attr.dummy)
{
gfc_start_block (&init);
!
! /* Character length passed by reference. */
! tmp = sym->ts.u.cl->passed_length;
! tmp = build_fold_indirect_ref_loc (input_location, tmp);
! tmp = fold_convert (gfc_charlen_type_node, tmp);
! gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
! /* Pass the final character length back. */
! if (sym->attr.intent != INTENT_IN)
! tmp = fold_build2_loc (input_location, MODIFY_EXPR,
! gfc_charlen_type_node, tmp,
! sym->ts.u.cl->backend_decl);
! else
! tmp = NULL_TREE;
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
--- 4389,4397 ----
if (sym->attr.dummy)
{
gfc_start_block (&init);
! gfc_save_backend_locus (&loc);
! gfc_set_backend_locus (&sym->declared_at);
! tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4427,4432 ****
--- 4453,4459 ----
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
}
+
struct module_hasher : ggc_ptr_hash<module_htab_entry>
{
typedef const char *compare_type;
Index: gcc/testsuite/gfortran.dg/deferred_character_15.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_15.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/deferred_character_15.f90 (working copy)
***************
*** 0 ****
--- 1,44 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR69423.
+ !
+ ! Contributed by Antony Lewis <antony@cosmologist.info>
+ !
+ program tester
+ character(LEN=:), allocatable :: S
+ S= test(2)
+ if (len(S) .ne. 4) call abort
+ if (S .ne. "test") call abort
+ if (allocated (S)) deallocate (S)
+
+ S= test2(2)
+ if (len(S) .ne. 4) call abort
+ if (S .ne. "test") call abort
+ if (allocated (S)) deallocate (S)
+ contains
+ function test(alen)
+ character(LEN=:), allocatable :: test
+ integer alen, i
+ do i = alen, 1, -1
+ test = 'test'
+ exit
+ end do
+ ! This line would print nothing when compiled with -O1 and higher.
+ ! print *, len(test),test
+ if (len(test) .ne. 4) call abort
+ if (test .ne. "test") call abort
+ end function test
+
+ function test2(alen) result (test)
+ character(LEN=:), allocatable :: test
+ integer alen, i
+ do i = alen, 1, -1
+ test = 'test'
+ exit
+ end do
+ ! This worked before the fix.
+ ! print *, len(test),test
+ if (len(test) .ne. 4) call abort
+ if (test .ne. "test") call abort
+ end function test2
+ end program tester
More information about the Gcc-patches
mailing list