[Patch, fortran] PR69423 - [6 Regression] Invalid optimization with deferred-length character

[Patch, fortran] PR69423 - [6 Regression] Invalid optimization with deferred-length character

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 2068 bytes --]

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.

[-- Attachment #2: submit2.diff --]
[-- Type: text/plain, Size: 16684 bytes --]

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

Re: [Patch, fortran] PR69423 - [6 Regression] Invalid optimization with deferred-length character

[Dominique d'Humières]

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>

Re: [Patch, fortran] PR69423 - [6 Regression] Invalid optimization with deferred-length character

[Paul Richard Thomas]

Dear Dominique, dear all,

Many thanks for picking up the regression, which turned out to have a
trivial cause. I have taken the liberty of assuming that this is
tantamount to approval and have committed the patch as revision
233589. Any style or other wrinkles can be corrected later.

The reason that I took this liberty is that I must get past the
deferred character length business as rapidly as possible. I will
prepare a composite patch for 5-branch, with a view to committing it
in a weeks time, so that both branches have the same capability. I
have several other patches that should be backported to 5-branch,
which will take most of the time that I can devote to gfortran
tomorrow. More importantly, now that it has happened in the field, I
must fix the collisions in SELECT TYPE. The only way that I know to do
this reliably is to drop the use of a has and to use the extended type
names directly. This will take a bit of work!

Cheers

Paul


On 20 February 2016 at 13:11, Dominique d'Humières <dominiq@lps.ens.fr> wrote:
>
>> Le 20 févr. 2016 à 10:58, Paul Richard Thomas <paul.richard.thomas@gmail.com> a écrit :
>>
>> 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.
>
> It fixes the PR without regression.
>
> Thanks,
>
> Dominique
>
>



-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Re: [Patch, fortran] PR69423 - [6 Regression] Invalid optimization with deferred-length character

[Mikael Morin]

Le 20/02/2016 19:35, Paul Richard Thomas a écrit :
> The only way that I know to do
> this reliably is to drop the use of a has and to use the extended type
> names directly. This will take a bit of work!
>
Maybe the vtab pointer can be used to discriminate between types?
There is one vtab struct for each type, isn't there?

Mikael

Re: [Patch, fortran] PR69423 - [6 Regression] Invalid optimization with deferred-length character

[Thomas Koenig]

Hi Paul,

> More importantly, now that it has happened in the field, I
> must fix the collisions in SELECT TYPE. The only way that I know to do
> this reliably is to drop the use of a has and to use the extended type
> names directly

Can you also use the hash in the usual case and only do a name-by-name
comparison in the case of hash collision?

I think this is the standard method of dealing with such cases.

Regards

	Thomas