[Patch, fortran] PR69423 - [6 Regression] Invalid optimization with deferred-length character
Paul Richard Thomas
paul.richard.thomas@gmail.com
Sat Feb 20 09:58:00 GMT 2016
Dear Dominique,
Thanks for giving it a try. Although I cannot reproduce the problem, I
am pretty sure that it is due to the omission of a couple of
gfc_start_blocks. In the circumstances, it is a bit odd that the ICE
does not show up on my system!
Please give the attached a whirl.
Thanks
Paul
On 19 February 2016 at 20:15, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
> With the patch I get an ICE when compiling gfortran.dg/allocate_error_5.f90
>
> (lldb) target create "/opt/gcc/gcc6p-233563p2/libexec/gcc/x86_64-apple-darwin15.3.0/6.0.0/f951"
> Current executable set to '/opt/gcc/gcc6p-233563p2/libexec/gcc/x86_64-apple-darwin15.3.0/6.0.0/f951' (x86_64).
> (lldb) run /opt/gcc/_clean/gcc/testsuite/gfortran.dg/allocate_error_5.f90
> Process 18138 launched: '/opt/gcc/gcc6p-233563p2/libexec/gcc/x86_64-apple-darwin15.3.0/6.0.0/f951' (x86_64)
> gProcess 18138 stopped
> * thread #1: tid = 0x2ebfe4a, 0x00000001000d5679 f951`(chain=0x00007fff5fbfef20, expr=0x00000001427c56b8, front=<unavailable>)(tree *, tree, bool) + 41 at trans.c:1549, queue = 'com.apple.main-thread', stop reason = EXC_BAD_ACCESS (code=1, address=0x500000004)
> frame #0: 0x00000001000d5679 f951`(chain=0x00007fff5fbfef20, expr=0x00000001427c56b8, front=<unavailable>)(tree *, tree, bool) + 41 at trans.c:1549
> 1546
> 1547 if (*chain)
> 1548 {
> -> 1549 if (TREE_CODE (*chain) != STATEMENT_LIST)
> 1550 {
> 1551 tree tmp;
> 1552
> (lldb) bt
> * thread #1: tid = 0x2ebfe4a, 0x00000001000d5679 f951`(chain=0x00007fff5fbfef20, expr=0x00000001427c56b8, front=<unavailable>)(tree *, tree, bool) + 41 at trans.c:1549, queue = 'com.apple.main-thread', stop reason = EXC_BAD_ACCESS (code=1, address=0x500000004)
> * frame #0: 0x00000001000d5679 f951`(chain=0x00007fff5fbfef20, expr=0x00000001427c56b8, front=<unavailable>)(tree *, tree, bool) + 41 at trans.c:1549
> frame #1: 0x00000001000f045e f951`::gfc_null_and_pass_deferred_len(sym=0x0000000143d06d50, init=0x00007fff5fbfef20, loc=0x00007fff5fbfef10) + 174 at trans-decl.c:3965
> frame #2: 0x00000001000f9dba f951`gfc_trans_deferred_vars(proc_sym=0x0000000143d06a50, block=0x00007fff5fbff0b0) + 2042 at trans-decl.c:4275
> frame #3: 0x00000001000fc5e4 f951`gfc_generate_function_code(ns=<unavailable>) + 1332 at trans-decl.c:6269
> frame #4: 0x000000010008cb9c f951`gfc_parse_file() + 1644 at parse.c:5613
> frame #5: 0x00000001000d2d39 f951`::gfc_be_parse_file() + 57 at f95-lang.c:201
> frame #6: 0x00000001009ac32c f951`::compile_file() + 60 at toplev.c:465
> frame #7: 0x0000000100d9caaf f951`toplev::main(int, char**) + 1154 at toplev.c:1988
> frame #8: 0x0000000100d9c62d f951`toplev::main(this=<unavailable>, argc=<unavailable>, argv=<unavailable>) + 733
> frame #9: 0x0000000100d9e479 f951`main(argc=2, argv=0x00007fff5fbff318) + 41 at main.c:39
> frame #10: 0x00007fff97c615ad libdyld.dylib`start + 1
> frame #11: 0x00007fff97c615ad libdyld.dylib`start + 1
>
> Thanks for working on this PR,
>
> Dominique
>
>> Le 19 févr. 2016 à 09:47, Paul Richard Thomas <paul.richard.thomas@gmail.com> a écrit :
>>
>> 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.
>> <submit2.diff>
>
--
The difference between genius and stupidity is; genius has its limits.
Albert Einstein
-------------- 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,4038 ----
/* 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);
! gfc_start_block (&init);
! 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);
--- 4059,4066 ----
/* 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)
--- 4139,4159 ----
= 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 ****
--- 4236,4250 ----
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)
+ {
+ 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);
+ }
break;
default:
*************** gfc_trans_deferred_vars (gfc_symbol * pr
*** 4183,4188 ****
--- 4259,4265 ----
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);
--- 4267,4316 ----
{
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
--- 4318,4338 ----
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 ****
--- 4349,4355 ----
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);
}
}
--- 4390,4398 ----
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 ****
--- 4454,4460 ----
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 Fortran
mailing list