[gcc r13-3751] Fortran: Fix reallocation on assignment for kind=4 strings [PR107508]

[Tobias Burnus <burnus@gcc.gnu.org>]

https://gcc.gnu.org/g:071d00e0faabbd45449d2e83f207fca0f8e8ef68

commit r13-3751-g071d00e0faabbd45449d2e83f207fca0f8e8ef68
Author: Tobias Burnus <tobias@codesourcery.com>
Date:   Mon Nov 7 11:32:33 2022 +0100

    Fortran: Fix reallocation on assignment for kind=4 strings [PR107508]
    
    The check whether reallocation on assignment was required did not handle
    kind=4 characters correctly such that there was always a reallocation,
    implying issues with pointer addresses and lower bounds.  Additionally,
    with all deferred strings, the old memory was not freed on reallocation.
    And, finally, inside the block which was only executed if string lengths
    or bounds or dynamic types changed, was a subcheck of the same, which
    was effectively a no op but still confusing and at least added with -O0
    extra instructions to the binary.
    
            PR fortran/107508
    
    gcc/fortran/ChangeLog:
    
            * trans-array.cc (gfc_alloc_allocatable_for_assignment): Fix
            string-length check, plug memory leak, and avoid generation of
            effectively no-op code.
            * trans-expr.cc (alloc_scalar_allocatable_for_assignment): Extend
            comment; minor cleanup.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/widechar_11.f90: New test.

Diff:
---
 gcc/fortran/trans-array.cc                | 57 ++++---------------------------
 gcc/fortran/trans-expr.cc                 |  6 ++--
 gcc/testsuite/gfortran.dg/widechar_11.f90 | 51 +++++++++++++++++++++++++++
 3 files changed, 60 insertions(+), 54 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 514cb057afb..b7d4c41b5fe 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -10527,7 +10527,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   tree offset;
   tree jump_label1;
   tree jump_label2;
-  tree neq_size;
   tree lbd;
   tree class_expr2 = NULL_TREE;
   int n;
@@ -10607,6 +10606,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 	elemsize1 = expr1->ts.u.cl->backend_decl;
       else
 	elemsize1 = lss->info->string_length;
+      tree unit_size = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
+      elemsize1 = fold_build2_loc (input_location, MULT_EXPR,
+				   TREE_TYPE (elemsize1), elemsize1,
+				   fold_convert (TREE_TYPE (elemsize1), unit_size));
+
     }
   else if (expr1->ts.type == BT_CLASS)
     {
@@ -10699,19 +10703,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   /* Allocate if data is NULL.  */
   cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
 			 array1, build_int_cst (TREE_TYPE (array1), 0));
-
-  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
-    {
-      tmp = fold_build2_loc (input_location, NE_EXPR,
-			     logical_type_node,
-			     lss->info->string_length,
-			     rss->info->string_length);
-      cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				   logical_type_node, tmp, cond_null);
-      cond_null= gfc_evaluate_now (cond_null, &fblock);
-    }
-  else
-    cond_null= gfc_evaluate_now (cond_null, &fblock);
+  cond_null= gfc_evaluate_now (cond_null, &fblock);
 
   tmp = build3_v (COND_EXPR, cond_null,
 		  build1_v (GOTO_EXPR, jump_label1),
@@ -10778,19 +10770,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   tmp = build1_v (LABEL_EXPR, jump_label1);
   gfc_add_expr_to_block (&fblock, tmp);
 
-  /* If the lhs has not been allocated, its bounds will not have been
-     initialized and so its size is set to zero.  */
-  size1 = gfc_create_var (gfc_array_index_type, NULL);
-  gfc_init_block (&alloc_block);
-  gfc_add_modify (&alloc_block, size1, gfc_index_zero_node);
-  gfc_init_block (&realloc_block);
-  gfc_add_modify (&realloc_block, size1,
-		  gfc_conv_descriptor_size (desc, expr1->rank));
-  tmp = build3_v (COND_EXPR, cond_null,
-		  gfc_finish_block (&alloc_block),
-		  gfc_finish_block (&realloc_block));
-  gfc_add_expr_to_block (&fblock, tmp);
-
   /* Get the rhs size and fix it.  */
   size2 = gfc_index_one_node;
   for (n = 0; n < expr2->rank; n++)
@@ -10807,16 +10786,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
     }
   size2 = gfc_evaluate_now (size2, &fblock);
 
-  cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
-			  size1, size2);
-
-  /* If the lhs is deferred length, assume that the element size
-     changes and force a reallocation.  */
-  if (expr1->ts.deferred)
-    neq_size = gfc_evaluate_now (logical_true_node, &fblock);
-  else
-    neq_size = gfc_evaluate_now (cond, &fblock);
-
   /* Deallocation of allocatable components will have to occur on
      reallocation.  Fix the old descriptor now.  */
   if ((expr1->ts.type == BT_DERIVED)
@@ -11048,20 +11017,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   gfc_add_block_to_block (&realloc_block, &caf_se.post);
   realloc_expr = gfc_finish_block (&realloc_block);
 
-  /* Reallocate if sizes or dynamic types are different.  */
-  if (elemsize1)
-    {
-      tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
-			     elemsize1, elemsize2);
-      tmp = gfc_evaluate_now (tmp, &fblock);
-      neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				  logical_type_node, neq_size, tmp);
-    }
-  tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
-		  build_empty_stmt (input_location));
-
-  realloc_expr = tmp;
-
   /* Malloc expression.  */
   gfc_init_block (&alloc_block);
   if (!coarray)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e7b9211f17e..f3fbb527157 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11236,10 +11236,10 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
 
   if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
     {
-      /* Use the rhs string length and the lhs element size.  */
+      /* Use the rhs string length and the lhs element size. Note that 'size' is
+	 used below for the string-length comparison, only.  */
       size = string_length;
-      tmp = TREE_TYPE (gfc_typenode_for_spec (&expr1->ts));
-      tmp = TYPE_SIZE_UNIT (tmp);
+      tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr1->ts.kind));
       size_in_bytes = fold_build2_loc (input_location, MULT_EXPR,
 				       TREE_TYPE (tmp), tmp,
 				       fold_convert (TREE_TYPE (tmp), size));
diff --git a/gcc/testsuite/gfortran.dg/widechar_11.f90 b/gcc/testsuite/gfortran.dg/widechar_11.f90
new file mode 100644
index 00000000000..02530fb1730
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/widechar_11.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/107508
+!
+use iso_c_binding
+implicit none
+character(len=:,kind=4), allocatable, target :: a4str(:), a4str2
+type(c_ptr) :: cptr, cptr2
+
+allocate(character(len=7,kind=4) :: a4str(-2:3))
+allocate(character(len=9,kind=4) :: a4str2)
+
+cptr = c_loc(a4str)
+cptr2 = c_loc(a4str2)
+
+if (len(a4str) /= 7) error stop
+if (lbound(a4str,1) /= -2) error stop
+if (ubound(a4str,1) /= 3) error stop
+if (len(a4str2) /= 9) error stop
+
+a4str = [4_"sf456aq", 4_"3dtzu24", 4_"_4fh7sm", 4_"=ff85s7", 4_"j=8af4d", 4_".,A%Fsz"]
+a4str2 = 4_"4f5g5f8a9"
+
+!print *, lbound(a4str), ubound(a4str)  ! expected (-2:3) - actually: (1:6)
+
+if (len(a4str) /= 7) error stop
+if (lbound(a4str,1) /= -2) error stop
+if (ubound(a4str,1) /= 3) error stop
+if (len(a4str2) /= 9) error stop
+if (.not. c_associated (cptr, c_loc(a4str))) error stop
+if (.not. c_associated (cptr2, c_loc(a4str2))) error stop
+end
+
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 4 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } }
+
+! { dg-final { scan-tree-dump-times "a4str.data = __builtin_malloc \\(168\\);" 2 "original" } }
+! { dg-final { scan-tree-dump-times "a4str.data = __builtin_realloc \\(a4str.data, 168\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "a4str2 = \\(character\\(kind=4\\)\\\[1:.a4str2\\\] \\*\\) __builtin_malloc \\(36\\);" 2 "original" } }
+! { dg-final { scan-tree-dump-times "a4str2 = \\(character\\(kind=4\\)\\\[1:.a4str2\\\] \\*\\) __builtin_realloc \\(\\(void \\*\\) a4str2, 36\\);" 1 "original" } }
+
+! Array: Assert, realloc-check assign string length (alloc + (realloc'ed) assignment):
+! { dg-final { scan-tree-dump-times "if \\(\[^\\n\\r\]*\\.a4str != 7\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(D\\.\[0-9\]+ != 28\\) goto L\\." 1 "original" } }
+! { dg-final { scan-tree-dump-times "\\.a4str = 7;" 2 "original" } }
+
+! Scalar: Assert, realloc-check assign string length (alloc + (realloc'ed) assignment):
+! { dg-final { scan-tree-dump-times "if \\(\[^\\n\\r\]*\\.a4str2 != 9\\)" 2 "original" } }
+! { dg-final { scan-tree-dump-times "if \\(\\.a4str2 == 9\\) goto L\\." 1 "original" } }
+! { dg-final { scan-tree-dump-times "\\.a4str2 = 9;" 2 "original" } }