[gcc(refs/users/mikael/heads/refactor_descriptor_v291.01)] Refactor set_gfc_from_cfi

Mikael Morin via Gcc-cvs <[email protected]>
Newsgroups gmane.comp.gcc.cvs
Message-ID <[email protected]> 
https://gcc.gnu.org/g:0ad0a750a9d115c15c3ccc7ad69a586f671c373f

commit 0ad0a750a9d115c15c3ccc7ad69a586f671c373f
Author: Mikael Morin <[email protected]>
Date:   Fri Aug 15 15:27:59 2025 +0200

    Refactor set_gfc_from_cfi
    
    Correction régression bind_c_optional-1
    
    Correction renseignement stride
    
    Correction régression bind-c-contiguous-3
    
    Correction motif array_reference_3
    
    Suppression code commenté
    
    Modif dump

Diff:
---
 gcc/fortran/trans-descriptor.cc                 | 174 ++++++++++++------------
 gcc/testsuite/gfortran.dg/array_reference_3.f90 |   2 +-
 2 files changed, 89 insertions(+), 87 deletions(-)

diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index 11bd8bf5b637..ab404628de86 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -1967,6 +1967,61 @@ gfc_set_descriptor_with_shape (stmtblock_t *block, tree desc, tree ptr,
 }
 
 
+static void
+set_gfc_dimension_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree idx,
+			    tree lbound, tree offset_var, tree cont_stride_var,
+			    bool contiguous)
+{
+  /* gfc->dim[i].lbound = ... */
+  lbound = fold_convert (gfc_array_index_type, lbound);
+  lbound = gfc_evaluate_now (lbound, block);
+  gfc_conv_descriptor_lbound_set (block, gfc, idx, lbound);
+
+  /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+  tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			      lbound, gfc_index_one_node);
+  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			 gfc_get_cfi_dim_extent (cfi, idx), tmp);
+  gfc_conv_descriptor_ubound_set (block, gfc, idx, tmp);
+
+  tree stride;
+  if (contiguous)
+    {
+      /* gfc->dim[i].stride
+	   = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */
+      tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				   idx, build_zero_cst (TREE_TYPE (idx)));
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
+			     idx, build_int_cst (TREE_TYPE (idx), 1));
+      tmp = gfc_get_cfi_dim_extent (cfi, tmp);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+			     tmp, cont_stride_var);
+      tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+			gfc_index_one_node, tmp);
+      stride = gfc_evaluate_now (tmp, block);
+      gfc_add_modify (block, cont_stride_var, stride);
+    }
+  else
+    {
+      /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+      tmp = gfc_get_cfi_dim_sm (cfi, idx);
+      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+			     gfc_array_index_type, tmp,
+			     fold_convert (gfc_array_index_type,
+					   gfc_get_cfi_desc_elem_len (cfi)));
+      stride = gfc_evaluate_now (tmp, block);
+    }
+  gfc_conv_descriptor_stride_set (block, gfc, idx, stride);
+
+  /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+			 stride, lbound);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			 offset_var, tmp);
+  gfc_add_modify (block, offset_var, tmp);
+}
+
+
 void
 gfc_set_gfc_from_cfi (stmtblock_t *block, tree gfc, gfc_expr *e, tree rank,
 		      tree gfc_strlen, tree cfi, gfc_symbol *fsym)
@@ -2006,42 +2061,20 @@ gfc_set_gfc_from_cfi (stmtblock_t *block, tree gfc, gfc_expr *e, tree rank,
       gfc_conv_descriptor_span_set (&block2, gfc, tmp);
 
       /* Calculate offset + set lbound, ubound and stride.  */
-      gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
+      tree offset = gfc_create_var (gfc_array_index_type, "offset");
+      gfc_add_modify (&block2, offset, gfc_index_zero_node);
       /* Loop: for (i = 0; i < rank; ++i).  */
       tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
       /* Loop body.  */
       stmtblock_t loop_body;
       gfc_init_block (&loop_body);
-      /* gfc->dim[i].lbound = ... */
-      tmp = gfc_get_cfi_dim_lbound (cfi, idx);
-      gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
-
-      /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
-      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-			     gfc_conv_descriptor_lbound_get (gfc, idx),
-			     gfc_index_one_node);
-      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-			     gfc_get_cfi_dim_extent (cfi, idx), tmp);
-      gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
-
-      /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
-      tmp = gfc_get_cfi_dim_sm (cfi, idx);
-      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
-			     gfc_array_index_type, tmp,
-			     fold_convert (gfc_array_index_type,
-					   gfc_get_cfi_desc_elem_len (cfi)));
-      gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
-
-      /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
-      tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-			     gfc_conv_descriptor_stride_get (gfc, idx),
-			     gfc_conv_descriptor_lbound_get (gfc, idx));
-      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-			     gfc_conv_descriptor_offset_get (gfc), tmp);
-      gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+      set_gfc_dimension_from_cfi (&loop_body, gfc, cfi, idx,
+				  gfc_get_cfi_dim_lbound (cfi, idx), offset,
+				  NULL_TREE, false);
       /* Generate loop.  */
       gfc_simple_for_loop (&block2, idx, gfc_rank_cst[0], rank, LT_EXPR,
 			   gfc_rank_cst[1], gfc_finish_block (&loop_body));
+      gfc_conv_descriptor_offset_set (&block2, gfc, offset);
     }
 
   if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
@@ -2069,17 +2102,14 @@ void
 gfc_set_gfc_from_cfi (stmtblock_t *block, stmtblock_t *block2, tree gfc_desc,
 		      tree rank, tree cfi, gfc_symbol *sym, bool do_copy_inout)
 {
-  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
-    {
-      /* gfc->dtype = ... (from declaration, not from cfi).  */
-      tree etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
-      gfc_conv_descriptor_dtype_set (block, gfc_desc,
-				     gfc_get_dtype_rank_type (sym->as->rank,
-							      etype));
-      /* gfc->data = cfi->base_addr. */
-      gfc_conv_descriptor_data_set (block, gfc_desc,
-				    gfc_get_cfi_desc_base_addr (cfi));
-    }
+  /* gfc->dtype = ... (from declaration, not from cfi).  */
+  tree etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
+  gfc_conv_descriptor_dtype_set (block, gfc_desc,
+				 gfc_get_dtype_rank_type (sym->as->rank,
+							  etype));
+  /* gfc->data = cfi->base_addr. */
+  gfc_conv_descriptor_data_set (block, gfc_desc,
+				gfc_get_cfi_desc_base_addr (cfi));
 
   if (sym->ts.type == BT_ASSUMED)
     {
@@ -2180,7 +2210,9 @@ gfc_set_gfc_from_cfi (stmtblock_t *block, stmtblock_t *block2, tree gfc_desc,
   gfc_conv_descriptor_span_set (block2, gfc_desc, tmp);
 
   /* Calculate offset + set lbound, ubound and stride.  */
-  gfc_conv_descriptor_offset_set (block2, gfc_desc, gfc_index_zero_node);
+  tree offset = gfc_create_var (gfc_array_index_type, "offset");
+  gfc_add_modify (block2, offset, gfc_index_zero_node);
+
   if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable)
     for (int i = 0; i < sym->as->rank; ++i)
       {
@@ -2201,62 +2233,32 @@ gfc_set_gfc_from_cfi (stmtblock_t *block, stmtblock_t *block2, tree gfc_desc,
   /* Loop: for (i = 0; i < rank; ++i).  */
   tree idx = gfc_create_var (gfc_array_dim_rank_type, "idx");
 
+  /* Stride  */
+  tree stride;
+  if (do_copy_inout)
+    stride = gfc_create_var (gfc_array_index_type, "stride");
+  else
+    stride = NULL_TREE;
+
   /* Loop body.  */
   stmtblock_t loop_body;
   gfc_init_block (&loop_body);
   /* gfc->dim[i].lbound = ... */
+  tree lbound;
   if (sym->attr.pointer || sym->attr.allocatable)
-    {
-      tmp = gfc_get_cfi_dim_lbound (cfi, idx);
-      gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, tmp);
-    }
+    lbound = gfc_get_cfi_dim_lbound (cfi, idx);
   else if (sym->as->rank < 0)
-    gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx,
-				    gfc_index_one_node);
-
-  /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
-  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-			     gfc_conv_descriptor_lbound_get (gfc_desc, idx),
-			     gfc_index_one_node);
-  tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-			     gfc_get_cfi_dim_extent (cfi, idx), tmp);
-  gfc_conv_descriptor_ubound_set (&loop_body, gfc_desc, idx, tmp);
-
-  if (do_copy_inout)
-    {
-      /* gfc->dim[i].stride
-	   = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */
-      tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
-				   idx, build_zero_cst (TREE_TYPE (idx)));
-      tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
-			     idx, build_int_cst (TREE_TYPE (idx), 1));
-      tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp);
-      tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp);
-      tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2),
-			     tmp2, tmp);
-      tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
-			gfc_index_one_node, tmp);
-    }
+    lbound = gfc_index_one_node;
   else
-    {
-      /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
-      tmp = gfc_get_cfi_dim_sm (cfi, idx);
-      tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
-			     gfc_array_index_type, tmp,
-			     fold_convert (gfc_array_index_type,
-					   gfc_get_cfi_desc_elem_len (cfi)));
-     }
-  gfc_conv_descriptor_stride_set (&loop_body, gfc_desc, idx, tmp);
-  /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
-  tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-			     gfc_conv_descriptor_stride_get (gfc_desc, idx),
-			     gfc_conv_descriptor_lbound_get (gfc_desc, idx));
-  tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-			     gfc_conv_descriptor_offset_get (gfc_desc), tmp);
-  gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp);
+    lbound = gfc_conv_descriptor_lbound_get (gfc_desc, idx);
+
+  set_gfc_dimension_from_cfi (&loop_body, gfc_desc, cfi, idx, lbound, offset,
+			      stride, do_copy_inout);
 
   /* Generate loop.  */
   gfc_simple_for_loop (block2, idx, build_zero_cst (TREE_TYPE (idx)),
 		       rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
 		       gfc_finish_block (&loop_body));
+
+  gfc_conv_descriptor_offset_set (block2, gfc_desc, offset);
 }
diff --git a/gcc/testsuite/gfortran.dg/array_reference_3.f90 b/gcc/testsuite/gfortran.dg/array_reference_3.f90
index 85fa3317d985..a10467fe3e08 100644
--- a/gcc/testsuite/gfortran.dg/array_reference_3.f90
+++ b/gcc/testsuite/gfortran.dg/array_reference_3.f90
@@ -65,7 +65,7 @@ contains
     call ccfis(x)
     if (any(x /= 13)) stop 13
     ! The cfi descriptor’s dim array is referenced with array indexing.
-    ! { dg-final { scan-tree-dump-times "cfi_descriptor->dim\\\[idx.\\d+\\\]\\.ubound = _cfi_descriptor->dim\\\[idx.\\d+\\\]\\.extent \\+ \\(cfi_descriptor->dim\\\[idx.\\d+\\\]\\.lbound \\+ -1\\);" 1 "original" } }
+    ! { dg-final { scan-tree-dump-times {cfi_descriptor->dim\[[^]]+\]\.ubound = _cfi_descriptor->dim\[[^]]+\]\.extent \+ \(D\.\d+ \+ -1\);} 1 "original" } }
   end subroutine check_cfi_dim
   subroutine css(c) bind(c)
     character :: c
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.