[RFC PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[RFC PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Jakub Jelinek]

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

Hi!

gfortran since my last patch at least emits useful debug info
for normal multi-dimensional arrays and arrays with lower bound different
than 0, including I believe assumed size arrays.
But it doesn't handle assumed shape arrays, allocatable and pointer arrays
that use descriptors.
For these DWARF3 has quite detailed example how can they be efficiently
described in D.2.1.  The following patch tries to implement that.
I chose to use a langhook, because this would be terribly hard to express
in a generic way, we'd need new tree types for that and, as we want to
describe it using the DW_push_object_address magic, quite cumbersome.

Say for `vary' two dimensional assumed shape argument gfortran with this
patch emits something like below.
DW_OP_push_object_address will insert an address of the variable of that
type, assumed shape argument is a pointer (reference) to the descriptor
structure, so we compute:
(*vary)->data + ((*vary)->offset + (*vary)->dim[0].stride * (*vary)->dim[0].lower_bound
		 + (*vary)->dim[1].stride * (*vary)->dim[1].lower_bound) * sizeof (element_type)
to get at the actual data location (address of vary(low0, low1)).
The addition of stride multiplied lower bounds is needed because gfortran's
data + offset * sizeof (element_type) points to vary (0, 0) rather than
field with all indexes equal to lower bounds.

        .uleb128 0xe    # (DIE (0x254) DW_TAG_array_type)
        .byte   0x17    # DW_AT_data_location
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x6     # DW_OP_deref
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x8
        .byte   0x6     # DW_OP_deref
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x18
        .byte   0x6     # DW_OP_deref
        .byte   0x22    # DW_OP_plus
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x30
        .byte   0x6     # DW_OP_deref
        .byte   0x22    # DW_OP_plus
        .byte   0x34    # DW_OP_lit4
        .byte   0x1e    # DW_OP_mul
        .byte   0x22    # DW_OP_plus
        .long   0x14c   # DW_AT_type
        .long   0x2a0   # DW_AT_sibling
        .uleb128 0xa    # (DIE (0x275) DW_TAG_subrange_type)
        .byte   0x5     # DW_AT_lower_bound
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x20
        .byte   0x6     # DW_OP_deref
        .byte   0x5     # DW_AT_upper_bound
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x28
        .byte   0x6     # DW_OP_deref
        .byte   0x7     # DW_AT_byte_stride
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x18
        .byte   0x6     # DW_OP_deref
        .byte   0x34    # DW_OP_lit4
        .byte   0x1e    # DW_OP_mul
        .uleb128 0xa    # (DIE (0x28a) DW_TAG_subrange_type)
        .byte   0x5     # DW_AT_lower_bound
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x38
        .byte   0x6     # DW_OP_deref
        .byte   0x5     # DW_AT_upper_bound
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x40
        .byte   0x6     # DW_OP_deref
        .byte   0x7     # DW_AT_byte_stride
        .byte   0x97    # DW_OP_push_object_address
        .byte   0x6     # DW_OP_deref
        .byte   0x23    # DW_OP_plus_uconst
        .uleb128 0x30
        .byte   0x6     # DW_OP_deref
        .byte   0x34    # DW_OP_lit4
        .byte   0x1e    # DW_OP_mul

gdb doesn't unfortunately support several constructs used there, Jan made a patch
for preliminary DW_OP_push_object_address support over this weekend at least,
but e.g. strides aren't supported at all.  So I'd just appreciate if anybody
could either eyeball this to verify its correct, or try it with some debugger
that already supports both DW_OP_push_object_address and DW_OP_byte_stride
to verify it.

	Jakub

[-- Attachment #2: Z40b --]
[-- Type: text/plain, Size: 16663 bytes --]

2007-11-12  Jakub Jelinek  <jakub@redhat.com>

	PR fortran/22244
	* langhooks-def.h (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.
	(LANG_HOOKS_FOR_TYPES_INITIALIZER): Add it.
	* langhooks.h (struct array_descr_info): Forward declaration.
	(struct lang_hooks_for_types): Add get_array_descr_info field.
	* dwarf2.h (DW_AT_bit_stride, DW_AT_byte_stride): New.
	(DW_AT_stride_size, DW_AT_stride): Keep around for Dwarf2
	compatibility.
	* dwarf2out.h (struct array_descr_info): New type.
	* dwarf2out.c (dwarf_attr_name): Rename DW_AT_stride to
	DW_AT_byte_stride and DW_AT_stride_size to DW_AT_bit_size.
	(descr_info_loc, add_descr_info_field, gen_descr_array_type_die):
	New functions.
	(gen_type_die_with_usage): Call lang_hooks.types.get_array_descr_info
	and gen_descr_array_type_die.

	* trans.h (struct array_descr_info): Forward declaration.
	(gfc_get_array_descr_info): New prototype.
	* trans-types.c: Include dwarf2out.h.
	(gfc_get_array_descr_info): New function.
	* Make-lang.in (fortran/trans-types.o): Depend on dwarf2out.h.
	* f95-lang.c (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.

--- gcc/fortran/trans.h.jj	2007-10-08 10:45:01.000000000 +0200
+++ gcc/fortran/trans.h	2007-11-09 21:35:05.000000000 +0100
@@ -483,6 +483,8 @@ tree poplevel (int, int, int);
 tree getdecls (void);
 tree gfc_truthvalue_conversion (tree);
 tree gfc_builtin_function (tree);
+struct array_descr_info;
+bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
 
 /* In trans-openmp.c */
 bool gfc_omp_privatize_by_reference (const_tree);
--- gcc/fortran/trans-types.c.jj	2007-11-05 09:05:44.000000000 +0100
+++ gcc/fortran/trans-types.c	2007-11-10 01:02:44.000000000 +0100
@@ -37,6 +37,7 @@ along with GCC; see the file COPYING3.  
 #include "trans-const.h"
 #include "real.h"
 #include "flags.h"
+#include "dwarf2out.h"
 \f
 
 #if (GFC_MAX_DIMENSIONS < 10)
@@ -2121,4 +2122,107 @@ gfc_type_for_mode (enum machine_mode mod
   return NULL_TREE;
 }
 
+/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
+   in that case.  */
+
+bool
+gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
+{
+  int rank, dim;
+  bool indirect = false;
+  tree etype, ptype, field, t, off_total, base_decl;
+  tree data_off, offset_off, dim_off, dim_size, elem_size;
+  tree lower_suboff, upper_suboff, stride_suboff;
+
+  if (! GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      if (! POINTER_TYPE_P (type))
+	return false;
+      type = TREE_TYPE (type);
+      if (! GFC_DESCRIPTOR_TYPE_P (type))
+	return false;
+      indirect = true;
+    }
+
+  rank = GFC_TYPE_ARRAY_RANK (type);
+  if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
+    return false;
+
+  etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+  gcc_assert (POINTER_TYPE_P (etype));
+  etype = TREE_TYPE (etype);
+  gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
+  etype = TREE_TYPE (etype);
+  if (int_size_in_bytes (etype) <= 0)
+    return false;
+
+  memset (info, '\0', sizeof (*info));
+  info->ndimensions = rank;
+  info->element_type = etype;
+  ptype = build_pointer_type (gfc_array_index_type);
+  if (indirect)
+    {
+      info->base_decl = build_decl (VAR_DECL, NULL_TREE,
+				    build_pointer_type (ptype));
+      base_decl = build1 (INDIRECT_REF, ptype, info->base_decl);
+    }
+  else
+    info->base_decl = base_decl = build_decl (VAR_DECL, NULL_TREE, ptype);
+
+  elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+  field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
+  data_off = byte_position (field);
+  field = TREE_CHAIN (field);
+  offset_off = byte_position (field);
+  field = TREE_CHAIN (field);
+  field = TREE_CHAIN (field);
+  dim_off = byte_position (field);
+  dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
+  field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
+  stride_suboff = byte_position (field);
+  field = TREE_CHAIN (field);
+  lower_suboff = byte_position (field);
+  field = TREE_CHAIN (field);
+  upper_suboff = byte_position (field);
+
+  t = base_decl;
+  if (!integer_zerop (data_off))
+    t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
+  t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
+  info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
+  t = build2 (POINTER_PLUS_EXPR, ptype, base_decl, offset_off);
+  off_total = build1 (INDIRECT_REF, gfc_array_index_type, t);
+
+  for (dim = 0; dim < rank; dim++)
+    {
+      t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+		  size_binop (PLUS_EXPR, dim_off, lower_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      info->dimen[dim].lower_bound = t;
+      t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+		  size_binop (PLUS_EXPR, dim_off, upper_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      info->dimen[dim].upper_bound = t;
+      t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+		  size_binop (PLUS_EXPR, dim_off, stride_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      off_total = build2 (PLUS_EXPR, gfc_array_index_type, off_total, t);
+      t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
+      info->dimen[dim].stride = t;
+      dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
+    }
+
+  /* DWARF3 expects to use
+     data_location + (index0 - low0) * stride0 + (index1 - low1) * stride1 ...
+     but gfortran uses:
+     d.data + d.offset * sizeof (elem)
+     + index0 * d.dim[0].stride * sizeof (elem)
+     + index1 * d.dim[1].stride * sizeof (elem).  */
+  off_total = build2 (MULT_EXPR, gfc_array_index_type, off_total, elem_size);
+  info->data_location = build2 (POINTER_PLUS_EXPR, ptr_type_node,
+				info->data_location,
+				fold_convert (sizetype, off_total));
+  return true;
+}
+
 #include "gt-fortran-trans-types.h"
--- gcc/fortran/Make-lang.in.jj	2007-10-08 10:45:01.000000000 +0200
+++ gcc/fortran/Make-lang.in	2007-11-09 22:01:34.000000000 +0100
@@ -312,7 +312,7 @@ fortran/trans-decl.o: $(GFORTRAN_TRANS_D
   $(CGRAPH_H) $(TARGET_H) $(FUNCTION_H) $(FLAGS_H) $(RTL_H) $(TREE_GIMPLE_H) \
   $(TREE_DUMP_H)
 fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
-  $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H)
+  $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H) dwarf2out.h
 fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
 fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
 fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
--- gcc/fortran/f95-lang.c.jj	2007-09-14 11:54:35.000000000 +0200
+++ gcc/fortran/f95-lang.c	2007-11-09 21:33:18.000000000 +0100
@@ -120,6 +120,7 @@ static alias_set_type gfc_get_alias_set 
 #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
 #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
 #undef LANG_HOOKS_BUILTIN_FUNCTION
+#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
 
 /* Define lang hooks.  */
 #define LANG_HOOKS_NAME                 "GNU F95"
@@ -143,6 +144,7 @@ static alias_set_type gfc_get_alias_set 
 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
   gfc_omp_firstprivatize_type_sizes
 #define LANG_HOOKS_BUILTIN_FUNCTION          gfc_builtin_function
+#define LANG_HOOKS_GET_ARRAY_DESCR_INFO	     gfc_get_array_descr_info
 
 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 
--- gcc/langhooks-def.h.jj	2007-11-02 19:02:47.000000000 +0100
+++ gcc/langhooks-def.h	2007-11-09 17:39:23.000000000 +0100
@@ -180,6 +180,7 @@ extern tree lhd_make_node (enum tree_cod
 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
   lhd_omp_firstprivatize_type_sizes
 #define LANG_HOOKS_TYPE_HASH_EQ		NULL
+#define LANG_HOOKS_GET_ARRAY_DESCR_INFO	NULL
 #define LANG_HOOKS_HASH_TYPES		true
 
 #define LANG_HOOKS_FOR_TYPES_INITIALIZER { \
@@ -193,6 +194,7 @@ extern tree lhd_make_node (enum tree_cod
   LANG_HOOKS_TYPE_MAX_SIZE, \
   LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES, \
   LANG_HOOKS_TYPE_HASH_EQ, \
+  LANG_HOOKS_GET_ARRAY_DESCR_INFO, \
   LANG_HOOKS_HASH_TYPES \
 }
 
--- gcc/dwarf2out.c.jj	2007-11-09 14:29:04.000000000 +0100
+++ gcc/dwarf2out.c	2007-11-10 00:40:24.000000000 +0100
@@ -4263,6 +4263,7 @@ static tree member_declared_type (const_
 static const char *decl_start_label (tree);
 #endif
 static void gen_array_type_die (tree, dw_die_ref);
+static void gen_descr_array_type_die (tree, struct array_descr_info *, dw_die_ref);
 #if 0
 static void gen_entry_point_die (tree, dw_die_ref);
 #endif
@@ -4669,8 +4670,8 @@ dwarf_attr_name (unsigned int attr)
       return "DW_AT_return_addr";
     case DW_AT_start_scope:
       return "DW_AT_start_scope";
-    case DW_AT_stride_size:
-      return "DW_AT_stride_size";
+    case DW_AT_bit_stride:
+      return "DW_AT_bit_stride";
     case DW_AT_upper_bound:
       return "DW_AT_upper_bound";
     case DW_AT_abstract_origin:
@@ -4738,8 +4739,8 @@ dwarf_attr_name (unsigned int attr)
       return "DW_AT_associated";
     case DW_AT_data_location:
       return "DW_AT_data_location";
-    case DW_AT_stride:
-      return "DW_AT_stride";
+    case DW_AT_byte_stride:
+      return "DW_AT_byte_stride";
     case DW_AT_entry_pc:
       return "DW_AT_entry_pc";
     case DW_AT_use_UTF8:
@@ -11695,6 +11696,151 @@ gen_array_type_die (tree type, dw_die_re
     add_pubtype (type, array_die);
 }
 
+static dw_loc_descr_ref
+descr_info_loc (tree val, tree base_decl)
+{
+  HOST_WIDE_INT size;
+  dw_loc_descr_ref loc, loc2;
+
+  if (val == base_decl)
+    return new_loc_descr (DW_OP_push_object_address, 0, 0);
+
+  switch (TREE_CODE (val))
+    {
+    case NOP_EXPR:
+    case CONVERT_EXPR:
+      return descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+    case INTEGER_CST:
+      if (host_integerp (val, 0))
+	return int_loc_descriptor (tree_low_cst (val, 0));
+      break;
+    case INDIRECT_REF:
+      size = int_size_in_bytes (TREE_TYPE (val));
+      if (size < 0)
+	break;
+      loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+      if (!loc)
+	break;
+      if (size == DWARF2_ADDR_SIZE)
+	add_loc_descr (&loc, new_loc_descr (DW_OP_deref, 0, 0));
+      else
+	add_loc_descr (&loc, new_loc_descr (DW_OP_deref_size, size, 0));
+      return loc;
+    case POINTER_PLUS_EXPR:
+    case PLUS_EXPR:
+      loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+      if (!loc)
+	break;
+      if (host_integerp (TREE_OPERAND (val, 1), 1)
+	  && (unsigned HOST_WIDE_INT) tree_low_cst (TREE_OPERAND (val, 1), 1)
+	     < 16384)
+	add_loc_descr (&loc,
+		       new_loc_descr (DW_OP_plus_uconst,
+				      tree_low_cst (TREE_OPERAND (val, 1),
+				      1), 0));
+      else
+	{
+	  loc2 = descr_info_loc (TREE_OPERAND (val, 1), base_decl);
+	  if (!loc2)
+	    break;
+	  add_loc_descr (&loc, loc2);
+	  add_loc_descr (&loc2, new_loc_descr (DW_OP_plus, 0, 0));
+	}
+      return loc;
+    case MULT_EXPR:
+      loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+      loc2 = descr_info_loc (TREE_OPERAND (val, 1), base_decl);
+      if (!loc || !loc2)
+	break;
+      add_loc_descr (&loc, loc2);
+      add_loc_descr (&loc2, new_loc_descr (DW_OP_mul, 0, 0));
+      return loc;
+    default:
+      break;
+    }
+  return NULL;
+}
+
+static void
+add_descr_info_field (dw_die_ref die, enum dwarf_attribute attr,
+		      tree val, tree base_decl)
+{
+  dw_loc_descr_ref loc;
+
+  if (host_integerp (val, 0))
+    {
+      add_AT_unsigned (die, attr, tree_low_cst (val, 0));
+      return;
+    }
+
+  loc = descr_info_loc (val, base_decl);
+  if (!loc)
+    return;
+
+  add_AT_loc (die, attr, loc);
+}
+
+/* This routine generates DIE for array with hidden descriptor, details
+   are filled into *info by a langhook.  */
+
+static void
+gen_descr_array_type_die (tree type, struct array_descr_info *info,
+			  dw_die_ref context_die)
+{
+  dw_die_ref scope_die = scope_die_for (type, context_die);
+  dw_die_ref array_die;
+  int dim;
+
+  array_die = new_die (DW_TAG_array_type, scope_die, type);
+  add_name_attribute (array_die, type_tag (type));
+  equate_type_number_to_die (type, array_die);
+
+  if (info->associated)
+    add_descr_info_field (array_die, DW_AT_associated, info->associated,
+			  info->base_decl);
+  if (info->allocated)
+    add_descr_info_field (array_die, DW_AT_allocated, info->allocated,
+			  info->base_decl);
+  if (info->data_location)
+    add_descr_info_field (array_die, DW_AT_data_location, info->data_location,
+			  info->base_decl);
+
+  for (dim = 0; dim < info->ndimensions; dim++)
+    {
+      dw_die_ref subrange_die
+	= new_die (DW_TAG_subrange_type, array_die, NULL);
+
+      if (info->dimen[dim].lower_bound)
+	{
+	  /* If it is the default value, omit it.  */
+	  if ((is_c_family () || is_java ())
+	      && integer_zerop (info->dimen[dim].lower_bound))
+	    ;
+	  else if (is_fortran ()
+		   && integer_onep (info->dimen[dim].lower_bound))
+	    ;
+	  else
+	    add_descr_info_field (subrange_die, DW_AT_lower_bound,
+				  info->dimen[dim].lower_bound,
+				  info->base_decl);
+	}
+      if (info->dimen[dim].upper_bound)
+	add_descr_info_field (subrange_die, DW_AT_upper_bound,
+			      info->dimen[dim].upper_bound,
+			      info->base_decl);
+      if (info->dimen[dim].stride)
+	add_descr_info_field (subrange_die, DW_AT_byte_stride,
+			      info->dimen[dim].stride,
+			      info->base_decl);
+    }
+
+  gen_type_die (info->element_type, context_die);
+  add_type_attribute (array_die, info->element_type, 0, 0, context_die);
+
+  if (get_AT (array_die, DW_AT_name))
+    add_pubtype (type, array_die);
+}
+
 #if 0
 static void
 gen_entry_point_die (tree decl, dw_die_ref context_die)
@@ -13071,6 +13217,7 @@ gen_type_die_with_usage (tree type, dw_d
 				enum debug_info_usage usage)
 {
   int need_pop;
+  struct array_descr_info info;
 
   if (type == NULL_TREE || type == error_mark_node)
     return;
@@ -13089,6 +13236,16 @@ gen_type_die_with_usage (tree type, dw_d
       return;
     }
 
+  /* If this is an array type with hidden descriptor, handle it first.  */
+  if (!TREE_ASM_WRITTEN (type)
+      && lang_hooks.types.get_array_descr_info
+      && lang_hooks.types.get_array_descr_info (type, &info))
+    {
+      gen_descr_array_type_die (type, &info, context_die);
+      TREE_ASM_WRITTEN (type) = 1;
+      return;
+    }
+
   /* We are going to output a DIE to represent the unqualified version
      of this type (i.e. without any const or volatile qualifiers) so
      get the main variant (i.e. the unqualified version) of this type
--- gcc/dwarf2out.h.jj	2007-08-13 15:11:18.000000000 +0200
+++ gcc/dwarf2out.h	2007-11-09 17:47:55.000000000 +0100
@@ -25,3 +25,19 @@ extern void debug_dwarf (void);
 struct die_struct;
 extern void debug_dwarf_die (struct die_struct *);
 extern void dwarf2out_set_demangle_name_func (const char *(*) (const char *));
+
+struct array_descr_info
+{
+  int ndimensions;
+  tree element_type;
+  tree base_decl;
+  tree data_location;
+  tree allocated;
+  tree associated;
+  struct array_descr_dimen
+    {
+      tree lower_bound;
+      tree upper_bound;
+      tree stride;
+    } dimen[10];
+};
--- gcc/langhooks.h.jj	2007-11-02 19:02:47.000000000 +0100
+++ gcc/langhooks.h	2007-11-09 17:37:44.000000000 +0100
@@ -28,6 +28,8 @@ struct diagnostic_info;
 
 struct gimplify_omp_ctx;
 
+struct array_descr_info;
+
 /* A print hook for print_tree ().  */
 typedef void (*lang_print_tree_hook) (FILE *, tree, int indent);
 
@@ -136,6 +138,10 @@ struct lang_hooks_for_types
      FUNCTION_TYPEs.  */
   bool (*type_hash_eq) (const_tree, const_tree);
 
+  /* Return TRUE if TYPE uses a hidden descriptor and fills in information
+     for the debugger about the array bounds, strides, etc.  */
+  bool (*get_array_descr_info) (const_tree, struct array_descr_info *);
+
   /* Nonzero if types that are identical are to be hashed so that only
      one copy is kept.  If a language requires unique types for each
      user-specified type, such as Ada, this should be set to TRUE.  */
--- gcc/dwarf2.h.jj	2007-08-13 15:11:18.000000000 +0200
+++ gcc/dwarf2.h	2007-11-09 18:02:44.000000000 +0100
@@ -274,7 +274,8 @@ enum dwarf_attribute
     DW_AT_prototyped = 0x27,
     DW_AT_return_addr = 0x2a,
     DW_AT_start_scope = 0x2c,
-    DW_AT_stride_size = 0x2e,
+    DW_AT_bit_stride = 0x2e,
+    DW_AT_stride_size = DW_AT_bit_stride,
     DW_AT_upper_bound = 0x2f,
     DW_AT_abstract_origin = 0x31,
     DW_AT_accessibility = 0x32,
@@ -309,7 +310,8 @@ enum dwarf_attribute
     DW_AT_allocated     = 0x4e,
     DW_AT_associated    = 0x4f,
     DW_AT_data_location = 0x50,
-    DW_AT_stride        = 0x51,
+    DW_AT_byte_stride   = 0x51,
+    DW_AT_stride        = DW_AT_byte_stride,
     DW_AT_entry_pc      = 0x52,
     DW_AT_use_UTF8      = 0x53,
     DW_AT_extension     = 0x54,

[-- Attachment #3: a4.f90 --]
[-- Type: text/plain, Size: 1291 bytes --]

subroutine baz
  real, allocatable :: varx (:, :, :)
  allocate (varx (1:6, 5:15, 17:28))
  varx(:, :, :) = 6
  varx(1, 5, 17) = 7
  varx(2, 6, 18) = 8
  varx(6, 15, 28) = 9
  deallocate (varx)
end subroutine baz
subroutine foo (vary, varw)
  real :: vary (:, :)
  real :: varw (:, :, :)
  vary(:, :) = 4
  vary(1, 1) = 8
  vary(2, 2) = 9
  vary(1, 3) = 10
  varw(:, :, :) = 5
  varw(1, 1, 1) = 6
  varw(2, 2, 2) = 7
end subroutine foo
subroutine bar (varz)
  real :: varz (*)
  varz(1:3) = 4
  varz(2) = 5
end subroutine bar
program test
  interface
    subroutine foo (vary, varw)
    real :: vary (:, :)
    real :: varw (:, :, :)
    end subroutine
  end interface
  interface
    subroutine bar (varz)
    real :: varz (*)
    end subroutine
  end interface
  real :: x (10, 10), y (5), z(8, 8, 8)
  x(:,:) = 1
  y(:) = 2
  z(:,:,:) = 3
  call baz
  call foo (x, z(2:6, 4:7, 6:8))
  call bar (y)
  if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort
  if (x (1, 3) .ne. 10) call abort
  if (z (2, 4, 6) .ne. 6 .or. z (3, 5, 7) .ne. 7 .or. z (2, 4, 7) .ne. 5) call abort
  if (any (y .ne. (/4, 5, 4, 2, 2/))) call abort
  call foo (transpose (x), z)
  if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort
  if (x (3, 1) .ne. 10) call abort
end

[-- Attachment #4: a4.s.bz2 --]
[-- Type: application/x-bzip2, Size: 6027 bytes --]

[PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Jakub Jelinek]

Hi!

On Mon, Nov 12, 2007 at 05:46:03AM -0500, Jakub Jelinek wrote:
> gfortran since my last patch at least emits useful debug info
> for normal multi-dimensional arrays and arrays with lower bound different
> than 0, including I believe assumed size arrays.
> But it doesn't handle assumed shape arrays, allocatable and pointer arrays
> that use descriptors.
> For these DWARF3 has quite detailed example how can they be efficiently
> described in D.2.1.  The following patch tries to implement that.
> I chose to use a langhook, because this would be terribly hard to express
> in a generic way, we'd need new tree types for that and, as we want to
> describe it using the DW_push_object_address magic, quite cumbersome.

Here is the final version of the patch which fixes a bunch of errors in the
debuginfo emitted by earlier patch, add supports for DW_AT_associated and
DW_AT_allocated DWARF3 attributes and also adds support for assumed-size
arrays.
Jan Kratochvil posted a series of corresponding GDB patches in
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00317.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00315.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00316.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00318.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00319.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00320.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00322.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00321.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00326.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00323.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00324.html
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00325.html

Bootstrapped/regtested on i686-linux and ppc64-linux (and x86_64-linux
bootstrap is pending), ok for trunk?

2007-11-16  Jakub Jelinek  <jakub@redhat.com>

	PR fortran/22244
	* langhooks-def.h (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.
	(LANG_HOOKS_FOR_TYPES_INITIALIZER): Add it.
	* langhooks.h (struct array_descr_info): Forward declaration.
	(struct lang_hooks_for_types): Add get_array_descr_info field.
	* dwarf2.h (DW_AT_bit_stride, DW_AT_byte_stride): New.
	(DW_AT_stride_size, DW_AT_stride): Keep around for Dwarf2
	compatibility.
	* dwarf2out.h (struct array_descr_info): New type.
	* dwarf2out.c (dwarf_attr_name): Rename DW_AT_stride to
	DW_AT_byte_stride and DW_AT_stride_size to DW_AT_bit_size.
	(descr_info_loc, add_descr_info_field, gen_descr_array_type_die):
	New functions.
	(gen_type_die_with_usage): Call lang_hooks.types.get_array_descr_info
	and gen_descr_array_type_die.

	* trans.h (struct array_descr_info): Forward declaration.
	(gfc_get_array_descr_info): New prototype.
	(enum gfc_array_kind): New type.
	(struct lang_type): Add akind field.
	(GFC_TYPE_ARRAY_AKIND): Define.
	* trans-types.c: Include dwarf2out.h.
	(gfc_build_array_type): Add akind argument.  Adjust
	gfc_get_array_type_bounds call.
	(gfc_get_nodesc_array_type): Include proper debug info even for
	assumed-size arrays.
	(gfc_get_array_type_bounds): Add akind argument, set
	GFC_TYPE_ARRAY_AKIND to it.
	(gfc_sym_type, gfc_get_derived_type): Adjust gfc_build_array_type
	callers.
	(gfc_get_array_descr_info): New function.
	* trans-array.c (gfc_trans_create_temp_array,
	gfc_conv_expr_descriptor): Adjust gfc_get_array_type_bounds
	callers.
	* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Likewise.
	* trans-types.h (gfc_get_array_type_bounds): Adjust prototype.
	* Make-lang.in (fortran/trans-types.o): Depend on dwarf2out.h.
	* f95-lang.c (LANG_HOOKS_GET_ARRAY_DESCR_INFO): Define.

--- gcc/fortran/trans.h.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/fortran/trans.h	2007-11-13 17:10:08.000000000 +0100
@@ -483,6 +483,8 @@ tree poplevel (int, int, int);
 tree getdecls (void);
 tree gfc_truthvalue_conversion (tree);
 tree gfc_builtin_function (tree);
+struct array_descr_info;
+bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
 
 /* In trans-openmp.c */
 bool gfc_omp_privatize_by_reference (const_tree);
@@ -569,10 +571,19 @@ extern GTY(()) tree gfor_fndecl_sr_kind;
 
 /* G95-specific declaration information.  */
 
+enum gfc_array_kind
+{
+  GFC_ARRAY_UNKNOWN,
+  GFC_ARRAY_ASSUMED_SHAPE,
+  GFC_ARRAY_ALLOCATABLE,
+  GFC_ARRAY_POINTER
+};
+
 /* Array types only.  */
 struct lang_type		GTY(())
 {
   int rank;
+  enum gfc_array_kind akind;
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
   tree stride[GFC_MAX_DIMENSIONS];
@@ -626,7 +637,8 @@ struct lang_decl		GTY(())
 #define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank)
 #define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size)
 #define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset)
-/* Code should use gfc_get_dtype instead of accesig this directly.  It may
+#define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind)
+/* Code should use gfc_get_dtype instead of accesing this directly.  It may
    not be known when the type is created.  */
 #define GFC_TYPE_ARRAY_DTYPE(node) (TYPE_LANG_SPECIFIC(node)->dtype)
 #define GFC_TYPE_ARRAY_DATAPTR_TYPE(node) \
--- gcc/fortran/trans-stmt.c.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/fortran/trans-stmt.c	2007-11-13 17:10:08.000000000 +0100
@@ -2525,7 +2525,8 @@ gfc_trans_pointer_assign_need_temp (gfc_
       /* Make a new descriptor.  */
       parmtype = gfc_get_element_type (TREE_TYPE (desc));
       parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
-                                            loop.from, loop.to, 1);
+                                            loop.from, loop.to, 1,
+					    GFC_ARRAY_UNKNOWN);
 
       /* Allocate temporary for nested forall construct.  */
       tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
--- gcc/fortran/f95-lang.c.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/fortran/f95-lang.c	2007-11-13 17:10:08.000000000 +0100
@@ -120,6 +120,7 @@ static alias_set_type gfc_get_alias_set 
 #undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
 #undef LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES
 #undef LANG_HOOKS_BUILTIN_FUNCTION
+#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
 
 /* Define lang hooks.  */
 #define LANG_HOOKS_NAME                 "GNU F95"
@@ -143,6 +144,7 @@ static alias_set_type gfc_get_alias_set 
 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
   gfc_omp_firstprivatize_type_sizes
 #define LANG_HOOKS_BUILTIN_FUNCTION          gfc_builtin_function
+#define LANG_HOOKS_GET_ARRAY_DESCR_INFO	     gfc_get_array_descr_info
 
 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
 
--- gcc/fortran/Make-lang.in.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/fortran/Make-lang.in	2007-11-13 17:10:08.000000000 +0100
@@ -312,7 +312,7 @@ fortran/trans-decl.o: $(GFORTRAN_TRANS_D
   $(CGRAPH_H) $(TARGET_H) $(FUNCTION_H) $(FLAGS_H) $(RTL_H) $(TREE_GIMPLE_H) \
   $(TREE_DUMP_H)
 fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
-  $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H)
+  $(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H) dwarf2out.h
 fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
 fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
 fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
--- gcc/fortran/trans-types.c.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/fortran/trans-types.c	2007-11-14 15:24:57.000000000 +0100
@@ -37,6 +37,7 @@ along with GCC; see the file COPYING3.  
 #include "trans-const.h"
 #include "real.h"
 #include "flags.h"
+#include "dwarf2out.h"
 \f
 
 #if (GFC_MAX_DIMENSIONS < 10)
@@ -1047,7 +1048,8 @@ gfc_is_nodesc_array (gfc_symbol * sym)
 /* Create an array descriptor type.  */
 
 static tree
-gfc_build_array_type (tree type, gfc_array_spec * as)
+gfc_build_array_type (tree type, gfc_array_spec * as,
+		      enum gfc_array_kind akind)
 {
   tree lbound[GFC_MAX_DIMENSIONS];
   tree ubound[GFC_MAX_DIMENSIONS];
@@ -1063,7 +1065,9 @@ gfc_build_array_type (tree type, gfc_arr
       ubound[n] = gfc_conv_array_bound (as->upper[n]);
     }
 
-  return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
+  if (as->type == AS_ASSUMED_SHAPE)
+    akind = GFC_ARRAY_ASSUMED_SHAPE;
+  return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind);
 }
 \f
 /* Returns the struct descriptor_dimension type.  */
@@ -1246,7 +1250,7 @@ gfc_get_nodesc_array_type (tree etype, g
       if (expr->expr_type == EXPR_CONSTANT)
         {
           tmp = gfc_conv_mpz_to_tree (expr->value.integer,
-                                  gfc_index_integer_kind);
+				      gfc_index_integer_kind);
         }
       else
         {
@@ -1338,7 +1342,7 @@ gfc_get_nodesc_array_type (tree etype, g
   /* In debug info represent packed arrays as multi-dimensional
      if they have rank > 1 and with proper bounds, instead of flat
      arrays.  */
-  if (known_stride && write_symbols != NO_DEBUG)
+  if (known_offset && write_symbols != NO_DEBUG)
     {
       tree gtype = etype, rtype, type_decl;
 
@@ -1428,7 +1432,8 @@ gfc_get_array_descriptor_base (int dimen
 
 tree
 gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
-			   tree * ubound, int packed)
+			   tree * ubound, int packed,
+			   enum gfc_array_kind akind)
 {
   char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
   tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
@@ -1455,6 +1460,7 @@ gfc_get_array_type_bounds (tree etype, i
 
   GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
   GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
+  GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
 
   /* Build an array descriptor record type.  */
   if (packed != 0)
@@ -1573,9 +1579,14 @@ gfc_sym_type (gfc_symbol * sym)
 	    }
         }
       else
-      {
-	type = gfc_build_array_type (type, sym->as);
-    }
+	{
+	  enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
+	  if (sym->attr.pointer)
+	    akind = GFC_ARRAY_POINTER;
+	  else if (sym->attr.allocatable)
+	    akind = GFC_ARRAY_ALLOCATABLE;
+	  type = gfc_build_array_type (type, sym->as, akind);
+	}
     }
   else
     {
@@ -1801,9 +1812,14 @@ gfc_get_derived_type (gfc_symbol * deriv
 	{
 	  if (c->pointer || c->allocatable)
 	    {
+	      enum gfc_array_kind akind;
+	      if (c->pointer)
+		akind = GFC_ARRAY_POINTER;
+	      else
+		akind = GFC_ARRAY_ALLOCATABLE;
 	      /* Pointers to arrays aren't actually pointer types.  The
 	         descriptors are separate, but the data is common.  */
-	      field_type = gfc_build_array_type (field_type, c->as);
+	      field_type = gfc_build_array_type (field_type, c->as, akind);
 	    }
 	  else
 	    field_type = gfc_get_nodesc_array_type (field_type, c->as,
@@ -2121,4 +2137,124 @@ gfc_type_for_mode (enum machine_mode mod
   return NULL_TREE;
 }
 
+/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
+   in that case.  */
+
+bool
+gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
+{
+  int rank, dim;
+  bool indirect = false;
+  tree etype, ptype, field, t, base_decl;
+  tree data_off, offset_off, dim_off, dim_size, elem_size;
+  tree lower_suboff, upper_suboff, stride_suboff;
+
+  if (! GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      if (! POINTER_TYPE_P (type))
+	return false;
+      type = TREE_TYPE (type);
+      if (! GFC_DESCRIPTOR_TYPE_P (type))
+	return false;
+      indirect = true;
+    }
+
+  rank = GFC_TYPE_ARRAY_RANK (type);
+  if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
+    return false;
+
+  etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+  gcc_assert (POINTER_TYPE_P (etype));
+  etype = TREE_TYPE (etype);
+  gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
+  etype = TREE_TYPE (etype);
+  /* Can't handle variable sized elements yet.  */
+  if (int_size_in_bytes (etype) <= 0)
+    return false;
+  /* Nor non-constant lower bounds in assumed shape arrays.  */
+  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+    {
+      for (dim = 0; dim < rank; dim++)
+	if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
+	    || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
+	  return false;
+    }
+
+  memset (info, '\0', sizeof (*info));
+  info->ndimensions = rank;
+  info->element_type = etype;
+  ptype = build_pointer_type (gfc_array_index_type);
+  if (indirect)
+    {
+      info->base_decl = build_decl (VAR_DECL, NULL_TREE,
+				    build_pointer_type (ptype));
+      base_decl = build1 (INDIRECT_REF, ptype, info->base_decl);
+    }
+  else
+    info->base_decl = base_decl = build_decl (VAR_DECL, NULL_TREE, ptype);
+
+  elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+  field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
+  data_off = byte_position (field);
+  field = TREE_CHAIN (field);
+  offset_off = byte_position (field);
+  field = TREE_CHAIN (field);
+  field = TREE_CHAIN (field);
+  dim_off = byte_position (field);
+  dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
+  field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
+  stride_suboff = byte_position (field);
+  field = TREE_CHAIN (field);
+  lower_suboff = byte_position (field);
+  field = TREE_CHAIN (field);
+  upper_suboff = byte_position (field);
+
+  t = base_decl;
+  if (!integer_zerop (data_off))
+    t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
+  t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
+  info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
+  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+    info->allocated = build2 (NE_EXPR, boolean_type_node,
+			      info->data_location, null_pointer_node);
+  else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
+    info->associated = build2 (NE_EXPR, boolean_type_node,
+			       info->data_location, null_pointer_node);
+
+  for (dim = 0; dim < rank; dim++)
+    {
+      t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+		  size_binop (PLUS_EXPR, dim_off, lower_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      info->dimen[dim].lower_bound = t;
+      t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+		  size_binop (PLUS_EXPR, dim_off, upper_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      info->dimen[dim].upper_bound = t;
+      if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+	{
+	  /* Assumed shape arrays have known lower bounds.  */
+	  info->dimen[dim].upper_bound
+	    = build2 (MINUS_EXPR, gfc_array_index_type,
+		      info->dimen[dim].upper_bound,
+		      info->dimen[dim].lower_bound);
+	  info->dimen[dim].lower_bound
+	    = fold_convert (gfc_array_index_type,
+			    GFC_TYPE_ARRAY_LBOUND (type, dim));
+	  info->dimen[dim].upper_bound
+	    = build2 (PLUS_EXPR, gfc_array_index_type,
+		      info->dimen[dim].lower_bound,
+		      info->dimen[dim].upper_bound);
+	}
+      t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+		  size_binop (PLUS_EXPR, dim_off, stride_suboff));
+      t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+      t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
+      info->dimen[dim].stride = t;
+      dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
+    }
+
+  return true;
+}
+
 #include "gt-fortran-trans-types.h"
--- gcc/fortran/trans-array.c.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/fortran/trans-array.c	2007-11-13 17:10:08.000000000 +0100
@@ -608,7 +608,8 @@ gfc_trans_create_temp_array (stmtblock_t
 
   /* Initialize the descriptor.  */
   type =
-    gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1);
+    gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
+			       GFC_ARRAY_UNKNOWN);
   desc = gfc_create_var (type, "atmp");
   GFC_DECL_PACKED_ARRAY (desc) = 1;
 
@@ -4788,7 +4789,8 @@ gfc_conv_expr_descriptor (gfc_se * se, g
 	  /* Otherwise make a new one.  */
 	  parmtype = gfc_get_element_type (TREE_TYPE (desc));
 	  parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
-						loop.from, loop.to, 0);
+						loop.from, loop.to, 0,
+						GFC_ARRAY_UNKNOWN);
 	  parm = gfc_create_var (parmtype, "parm");
 	}
 
--- gcc/fortran/trans-types.h.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/fortran/trans-types.h	2007-11-13 17:10:08.000000000 +0100
@@ -67,7 +67,8 @@ tree gfc_type_for_size (unsigned, int);
 tree gfc_type_for_mode (enum machine_mode, int);
 
 tree gfc_get_element_type (tree);
-tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int);
+tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int,
+				enum gfc_array_kind);
 tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed);
 
 /* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE.  */
--- gcc/dwarf2.h.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/dwarf2.h	2007-11-13 17:10:08.000000000 +0100
@@ -274,7 +274,8 @@ enum dwarf_attribute
     DW_AT_prototyped = 0x27,
     DW_AT_return_addr = 0x2a,
     DW_AT_start_scope = 0x2c,
-    DW_AT_stride_size = 0x2e,
+    DW_AT_bit_stride = 0x2e,
+    DW_AT_stride_size = DW_AT_bit_stride,
     DW_AT_upper_bound = 0x2f,
     DW_AT_abstract_origin = 0x31,
     DW_AT_accessibility = 0x32,
@@ -309,7 +310,8 @@ enum dwarf_attribute
     DW_AT_allocated     = 0x4e,
     DW_AT_associated    = 0x4f,
     DW_AT_data_location = 0x50,
-    DW_AT_stride        = 0x51,
+    DW_AT_byte_stride   = 0x51,
+    DW_AT_stride        = DW_AT_byte_stride,
     DW_AT_entry_pc      = 0x52,
     DW_AT_use_UTF8      = 0x53,
     DW_AT_extension     = 0x54,
--- gcc/langhooks.h.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/langhooks.h	2007-11-13 17:10:08.000000000 +0100
@@ -28,6 +28,8 @@ struct diagnostic_info;
 
 struct gimplify_omp_ctx;
 
+struct array_descr_info;
+
 /* A print hook for print_tree ().  */
 typedef void (*lang_print_tree_hook) (FILE *, tree, int indent);
 
@@ -136,6 +138,10 @@ struct lang_hooks_for_types
      FUNCTION_TYPEs.  */
   bool (*type_hash_eq) (const_tree, const_tree);
 
+  /* Return TRUE if TYPE uses a hidden descriptor and fills in information
+     for the debugger about the array bounds, strides, etc.  */
+  bool (*get_array_descr_info) (const_tree, struct array_descr_info *);
+
   /* Nonzero if types that are identical are to be hashed so that only
      one copy is kept.  If a language requires unique types for each
      user-specified type, such as Ada, this should be set to TRUE.  */
--- gcc/langhooks-def.h.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/langhooks-def.h	2007-11-13 17:10:08.000000000 +0100
@@ -180,6 +180,7 @@ extern tree lhd_make_node (enum tree_cod
 #define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
   lhd_omp_firstprivatize_type_sizes
 #define LANG_HOOKS_TYPE_HASH_EQ		NULL
+#define LANG_HOOKS_GET_ARRAY_DESCR_INFO	NULL
 #define LANG_HOOKS_HASH_TYPES		true
 
 #define LANG_HOOKS_FOR_TYPES_INITIALIZER { \
@@ -193,6 +194,7 @@ extern tree lhd_make_node (enum tree_cod
   LANG_HOOKS_TYPE_MAX_SIZE, \
   LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES, \
   LANG_HOOKS_TYPE_HASH_EQ, \
+  LANG_HOOKS_GET_ARRAY_DESCR_INFO, \
   LANG_HOOKS_HASH_TYPES \
 }
 
--- gcc/dwarf2out.c.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/dwarf2out.c	2007-11-13 17:10:08.000000000 +0100
@@ -4263,6 +4263,7 @@ static tree member_declared_type (const_
 static const char *decl_start_label (tree);
 #endif
 static void gen_array_type_die (tree, dw_die_ref);
+static void gen_descr_array_type_die (tree, struct array_descr_info *, dw_die_ref);
 #if 0
 static void gen_entry_point_die (tree, dw_die_ref);
 #endif
@@ -4669,8 +4670,8 @@ dwarf_attr_name (unsigned int attr)
       return "DW_AT_return_addr";
     case DW_AT_start_scope:
       return "DW_AT_start_scope";
-    case DW_AT_stride_size:
-      return "DW_AT_stride_size";
+    case DW_AT_bit_stride:
+      return "DW_AT_bit_stride";
     case DW_AT_upper_bound:
       return "DW_AT_upper_bound";
     case DW_AT_abstract_origin:
@@ -4738,8 +4739,8 @@ dwarf_attr_name (unsigned int attr)
       return "DW_AT_associated";
     case DW_AT_data_location:
       return "DW_AT_data_location";
-    case DW_AT_stride:
-      return "DW_AT_stride";
+    case DW_AT_byte_stride:
+      return "DW_AT_byte_stride";
     case DW_AT_entry_pc:
       return "DW_AT_entry_pc";
     case DW_AT_use_UTF8:
@@ -11675,6 +11676,163 @@ gen_array_type_die (tree type, dw_die_re
     add_pubtype (type, array_die);
 }
 
+static dw_loc_descr_ref
+descr_info_loc (tree val, tree base_decl)
+{
+  HOST_WIDE_INT size;
+  dw_loc_descr_ref loc, loc2;
+  enum dwarf_location_atom op;
+
+  if (val == base_decl)
+    return new_loc_descr (DW_OP_push_object_address, 0, 0);
+
+  switch (TREE_CODE (val))
+    {
+    case NOP_EXPR:
+    case CONVERT_EXPR:
+      return descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+    case INTEGER_CST:
+      if (host_integerp (val, 0))
+	return int_loc_descriptor (tree_low_cst (val, 0));
+      break;
+    case INDIRECT_REF:
+      size = int_size_in_bytes (TREE_TYPE (val));
+      if (size < 0)
+	break;
+      loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+      if (!loc)
+	break;
+      if (size == DWARF2_ADDR_SIZE)
+	add_loc_descr (&loc, new_loc_descr (DW_OP_deref, 0, 0));
+      else
+	add_loc_descr (&loc, new_loc_descr (DW_OP_deref_size, size, 0));
+      return loc;
+    case POINTER_PLUS_EXPR:
+    case PLUS_EXPR:
+      if (host_integerp (TREE_OPERAND (val, 1), 1)
+	  && (unsigned HOST_WIDE_INT) tree_low_cst (TREE_OPERAND (val, 1), 1)
+	     < 16384)
+	{
+	  loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+	  if (!loc)
+	    break;
+	  add_loc_descr (&loc,
+			 new_loc_descr (DW_OP_plus_uconst,
+					tree_low_cst (TREE_OPERAND (val, 1),
+						      1), 0));
+	}
+      else
+	{
+	  op = DW_OP_plus;
+	do_binop:
+	  loc = descr_info_loc (TREE_OPERAND (val, 0), base_decl);
+	  if (!loc)
+	    break;
+	  loc2 = descr_info_loc (TREE_OPERAND (val, 1), base_decl);
+	  if (!loc2)
+	    break;
+	  add_loc_descr (&loc, loc2);
+	  add_loc_descr (&loc2, new_loc_descr (op, 0, 0));
+	}
+      return loc;
+    case MINUS_EXPR:
+      op = DW_OP_minus;
+      goto do_binop;
+    case MULT_EXPR:
+      op = DW_OP_mul;
+      goto do_binop;
+    case EQ_EXPR:
+      op = DW_OP_eq;
+      goto do_binop;
+    case NE_EXPR:
+      op = DW_OP_ne;
+      goto do_binop;
+    default:
+      break;
+    }
+  return NULL;
+}
+
+static void
+add_descr_info_field (dw_die_ref die, enum dwarf_attribute attr,
+		      tree val, tree base_decl)
+{
+  dw_loc_descr_ref loc;
+
+  if (host_integerp (val, 0))
+    {
+      add_AT_unsigned (die, attr, tree_low_cst (val, 0));
+      return;
+    }
+
+  loc = descr_info_loc (val, base_decl);
+  if (!loc)
+    return;
+
+  add_AT_loc (die, attr, loc);
+}
+
+/* This routine generates DIE for array with hidden descriptor, details
+   are filled into *info by a langhook.  */
+
+static void
+gen_descr_array_type_die (tree type, struct array_descr_info *info,
+			  dw_die_ref context_die)
+{
+  dw_die_ref scope_die = scope_die_for (type, context_die);
+  dw_die_ref array_die;
+  int dim;
+
+  array_die = new_die (DW_TAG_array_type, scope_die, type);
+  add_name_attribute (array_die, type_tag (type));
+  equate_type_number_to_die (type, array_die);
+
+  if (info->data_location)
+    add_descr_info_field (array_die, DW_AT_data_location, info->data_location,
+			  info->base_decl);
+  if (info->associated)
+    add_descr_info_field (array_die, DW_AT_associated, info->associated,
+			  info->base_decl);
+  if (info->allocated)
+    add_descr_info_field (array_die, DW_AT_allocated, info->allocated,
+			  info->base_decl);
+
+  for (dim = 0; dim < info->ndimensions; dim++)
+    {
+      dw_die_ref subrange_die
+	= new_die (DW_TAG_subrange_type, array_die, NULL);
+
+      if (info->dimen[dim].lower_bound)
+	{
+	  /* If it is the default value, omit it.  */
+	  if ((is_c_family () || is_java ())
+	      && integer_zerop (info->dimen[dim].lower_bound))
+	    ;
+	  else if (is_fortran ()
+		   && integer_onep (info->dimen[dim].lower_bound))
+	    ;
+	  else
+	    add_descr_info_field (subrange_die, DW_AT_lower_bound,
+				  info->dimen[dim].lower_bound,
+				  info->base_decl);
+	}
+      if (info->dimen[dim].upper_bound)
+	add_descr_info_field (subrange_die, DW_AT_upper_bound,
+			      info->dimen[dim].upper_bound,
+			      info->base_decl);
+      if (info->dimen[dim].stride)
+	add_descr_info_field (subrange_die, DW_AT_byte_stride,
+			      info->dimen[dim].stride,
+			      info->base_decl);
+    }
+
+  gen_type_die (info->element_type, context_die);
+  add_type_attribute (array_die, info->element_type, 0, 0, context_die);
+
+  if (get_AT (array_die, DW_AT_name))
+    add_pubtype (type, array_die);
+}
+
 #if 0
 static void
 gen_entry_point_die (tree decl, dw_die_ref context_die)
@@ -13051,6 +13209,7 @@ gen_type_die_with_usage (tree type, dw_d
 				enum debug_info_usage usage)
 {
   int need_pop;
+  struct array_descr_info info;
 
   if (type == NULL_TREE || type == error_mark_node)
     return;
@@ -13069,6 +13228,16 @@ gen_type_die_with_usage (tree type, dw_d
       return;
     }
 
+  /* If this is an array type with hidden descriptor, handle it first.  */
+  if (!TREE_ASM_WRITTEN (type)
+      && lang_hooks.types.get_array_descr_info
+      && lang_hooks.types.get_array_descr_info (type, &info))
+    {
+      gen_descr_array_type_die (type, &info, context_die);
+      TREE_ASM_WRITTEN (type) = 1;
+      return;
+    }
+
   /* We are going to output a DIE to represent the unqualified version
      of this type (i.e. without any const or volatile qualifiers) so
      get the main variant (i.e. the unqualified version) of this type
--- gcc/dwarf2out.h.jj	2007-11-13 17:06:40.000000000 +0100
+++ gcc/dwarf2out.h	2007-11-13 17:10:08.000000000 +0100
@@ -25,3 +25,19 @@ extern void debug_dwarf (void);
 struct die_struct;
 extern void debug_dwarf_die (struct die_struct *);
 extern void dwarf2out_set_demangle_name_func (const char *(*) (const char *));
+
+struct array_descr_info
+{
+  int ndimensions;
+  tree element_type;
+  tree base_decl;
+  tree data_location;
+  tree allocated;
+  tree associated;
+  struct array_descr_dimen
+    {
+      tree lower_bound;
+      tree upper_bound;
+      tree stride;
+    } dimen[10];
+};


	Jakub

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Tobias Burnus]

Hi Jakub,

Jakub Jelinek wrote:
> Here is the final version of the patch which fixes a bunch of errors in the
> debuginfo emitted by earlier patch, add supports for DW_AT_associated and
> DW_AT_allocated DWARF3 attributes and also adds support for assumed-size
> arrays.
>   
I applied the GCC patch and tried the example with the Intel Debugger
10. Tested was "a4.f90" of
http://gcc.gnu.org/ml/gcc-patches/2007-11/msg00612.html.

Using ifort10, I get in "baz":

(idb) ptype varx
type = REAL(4)(6)(11)(12)
(idb) p varx
$1 = {{{7, 6, 6, 6, 6, 6}, {6 ...

And using the patched gfortran:

(idb) ptype varx
type = REAL(4)(12)(11)(6)
(idb) p varx
$1 = {{{<no value>, <no value>, <no value>,

I don't know whether this is a deficit in idb or in gcc/gfortran. Note:
Not only does idb show "no value", it has also problems with the array
extent.

Accoding to
http://sources.redhat.com/ml/gdb-patches/2007-11/msg00317.html the
output of patched gcc + patched gdb is:

(gdb) ptype varx
type = real*4 (6,5:15,17:28)
(gdb) p varx
$1 = (( ( 7, 6, 6, 6, 6, 6) ( 6, 6, 6, 6, 6, 6) ( 6, [cut ...]

which is ok.


> Bootstrapped/regtested on i686-linux and ppc64-linux (and x86_64-linux
> bootstrap is pending), ok for trunk?
>   
The Fortran part looks OK.

Tobias

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Jakub Jelinek]

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

On Fri, Nov 16, 2007 at 12:45:02PM +0100, Tobias Burnus wrote:
> I applied the GCC patch and tried the example with the Intel Debugger
> 10. Tested was "a4.f90" of
> http://gcc.gnu.org/ml/gcc-patches/2007-11/msg00612.html.
> 
> Using ifort10, I get in "baz":
> 
> (idb) ptype varx
> type = REAL(4)(6)(11)(12)
> (idb) p varx
> $1 = {{{7, 6, 6, 6, 6, 6}, {6 ...

There is DW_AT_ordering attribute with { DW_ORD_col_major, DW_ORD_row_major }
possible values.  The standard says the default (if DW_AT_ordering is
missing) depends on the language, but I couldn't find the default values for each
language anywhere.  GCC outputs arrays in the same order for all languages
and GDB seems to default to DW_ORD_row_major if DW_AT_ordering is not
present.

Can you look at with idb on gfortran (vanilla or patched) generated MAIN__
x and y arrays after the bar subroutine returns and see if they are
displayed in the expected order or not?

Perhaps we should for all fortran multidimensional arrays output
DW_AT_ordering with DW_ORD_row_major?

	Jakub

[-- Attachment #2: a5.f90 --]
[-- Type: text/plain, Size: 1890 bytes --]

subroutine baz
  real, target, allocatable :: varx (:, :, :)
  real, pointer :: varv (:, :, :)
  real, target :: varu (1, 2, 3)
  logical :: l
  allocate (varx (1:6, 5:15, 17:28))
  l = allocated (varx)
  varx(:, :, :) = 6
  varx(1, 5, 17) = 7
  varx(2, 6, 18) = 8
  varx(6, 15, 28) = 9
  varv => varx
  l = associated (varv)
  varv(3, 7, 19) = 10
  varv => null ()
  l = associated (varv)
  deallocate (varx)
  l = allocated (varx)
  varu(:, :, :) = 10
  allocate (varv (1:6, 5:15, 17:28))
  l = associated (varv)
  varv(:, :, :) = 6
  varv(1, 5, 17) = 7
  varv(2, 6, 18) = 8
  varv(6, 15, 28) = 9
  deallocate (varv)
  l = associated (varv)
  varv => varu
  varv(1, 1, 1) = 6
  varv(1, 2, 3) = 7
  l = associated (varv)
end subroutine baz
subroutine foo (vary, varw)
  real :: vary (:, :)
  real :: varw (:, :, :)
  vary(:, :) = 4
  vary(1, 1) = 8
  vary(2, 2) = 9
  vary(1, 3) = 10
  varw(:, :, :) = 5
  varw(1, 1, 1) = 6
  varw(2, 2, 2) = 7
end subroutine foo
subroutine bar (varz, vart)
  real :: varz (*)
  real :: vart (2:11, 7:*)
  varz(1:3) = 4
  varz(2) = 5
end subroutine bar
program test
  interface
    subroutine foo (vary, varw)
    real :: vary (:, :)
    real :: varw (:, :, :)
    end subroutine
  end interface
  interface
    subroutine bar (varz, vart)
    real :: varz (*)
    real :: vart (2:11, 7:*)
    end subroutine
  end interface
  real :: x (10, 10), y (5), z(8, 8, 8)
  x(:,:) = 1
  y(:) = 2
  z(:,:,:) = 3
  call baz
  call foo (x, z(2:6, 4:7, 6:8))
  call bar (y, x)
  if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort
  if (x (1, 3) .ne. 10) call abort
  if (z (2, 4, 6) .ne. 6 .or. z (3, 5, 7) .ne. 7 .or. z (2, 4, 7) .ne. 5) call abort
  if (any (y .ne. (/4, 5, 4, 2, 2/))) call abort
  call foo (transpose (x), z)
  if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4) call abort
  if (x (3, 1) .ne. 10) call abort
end

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Tobias Burnus]

Jakub Jelinek wrote:
> Can you look at with idb on gfortran (vanilla or patched) generated MAIN__
> x and y arrays after the bar subroutine returns and see if they are
> displayed in the expected order or not?
>   
For the a5.f90 test case, compiled with ifort (!) I get:

Breakpoint 1, test () at a5.f90:70
70        if (x (1, 1) .ne. 8 .or. x (2, 2) .ne. 9 .or. x (1, 2) .ne. 4)
call abort
(idb) p x
$1 = {{<no value>,  <no value>, ...
(idb) p y
$2 = <no value>
(idb) ptype x
type = REAL(4)(10)(10)
(idb) ptype y
type = REAL(4)(5)

while using gdb and ifort (!):

(gdb) p x
$1 = (( 8, 4, 4, 4, 4, 4, 4, 4, 4, 4) ( 4, 9, 4, ...
(gdb) p y
$2 = (4, 5, 4, 2, 2)
(gdb) ptype y
type = real*4 (5)
(gdb) ptype x
type = real*4 (10,10)

But now to your question, using (an unpatched) gfortran -g and idb:

(idb) p x
$1 = {{8, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4}, {9, 4, 4, 4, 4, 4, 4, 4, 4, 10,
4}, {4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4}, {4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4}, {4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4}, {4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4}, {4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4}, {4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4}, {4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4}, {4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8.11898326e-11}}
(idb) p y
$2 = {4, 5, 4, 2, 2, 0}
(idb) ptype x
type = REAL(4)(11)(11)
(idb) ptype y
type = REAL(4)(6)

While with the same binary and gdb:

(gdb) p x
$1 = (( 8, 4, 4, 4, 4, 4, 4, 4, 4, 4) ( 4, 9, 4, 4, 4, 4, 4, 4, 4, 4) (
10, 4, 4, 4, 4, 4, 4, 4, 4, 4) ( 4, 4, 4, 4, 4, 4, 4, 4, 4, 4) ( 4, 4,
4, 4, 4, 4, 4, 4, 4, 4) ( 4, 4, 4, 4, 4, 4, 4, 4, 4, 4) ( 4, 4, 4, 4, 4,
4, 4, 4, 4, 4) ( 4, 4, 4, 4, 4, 4, 4, 4, 4, 4) ( 4, 4, 4, 4, 4, 4, 4, 4,
4, 4) ( 4, 4, 4, 4, 4, 4, 4, 4, 4, 4) )
(gdb) p y
$2 = (4, 5, 4, 2, 2)
(gdb) ptype x
type = real*4 (10,10)
(gdb) ptype y
type = real*4 (5)

Tobias

(PS: The gdb is w/o the patches.)

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Jakub Jelinek]

On Fri, Nov 16, 2007 at 02:06:42PM +0100, Tobias Burnus wrote:
> Jakub Jelinek wrote:
> > Can you look at with idb on gfortran (vanilla or patched) generated MAIN__
> > x and y arrays after the bar subroutine returns and see if they are
> > displayed in the expected order or not?
> >   
> For the a5.f90 test case, compiled with ifort (!) I get:

Ok, can you retry with the following additional patch on top of the previous
one?
It seems ifort emits DW_AT_subrange_type's in the same order as GCC, i.e.
for (1:5, 4:7, 8:9) there is
DW_AT_subrange_type
  DW_AT_lower_bound 1
  DW_AT_upper_bound 5
DW_AT_subrange_type
  DW_AT_lower_bound 4
  DW_AT_upper_bound 7
DW_AT_subrange_type
  DW_AT_lower_bound 8
  DW_AT_upper_bound 9
but GCC doesn't add any DW_AT_ordering, while ifort adds
DW_AT_ordering DW_ORD_col_major.

Wonder what gdb will do in presence of DW_ORD_col_major, I fear that
DW_ORD_col_major means it just reverses the order of DW_AT_subrange_type
notes and has hardcoded another reordering for Fortran or something, Jan?

--- gcc/dwarf2out.c.jj	2007-11-15 20:05:54.000000000 +0100
+++ gcc/dwarf2out.c	2007-11-16 14:16:13.000000000 +0100
@@ -11636,6 +11636,12 @@ gen_array_type_die (tree type, dw_die_re
       add_AT_flag (array_die, DW_AT_GNU_vector, 1);
     }
 
+  /* For Fortran multidimensional arrays use DW_ORD_col_major ordering.  */
+  if (is_fortran ()
+      && TREE_CODE (type) == ARRAY_TYPE
+      && TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
+    add_AT_unsigned (array_die, DW_AT_ordering, DW_ORD_col_major);
+
 #if 0
   /* We default the array ordering.  SDB will probably do
      the right things even if DW_AT_ordering is not present.  It's not even
@@ -11787,6 +11793,11 @@ gen_descr_array_type_die (tree type, str
   add_name_attribute (array_die, type_tag (type));
   equate_type_number_to_die (type, array_die);
 
+  /* For Fortran multidimensional arrays use DW_ORD_col_major ordering.  */
+  if (is_fortran ()
+      && info->ndimensions >= 2)
+    add_AT_unsigned (array_die, DW_AT_ordering, DW_ORD_col_major);
+
   if (info->data_location)
     add_descr_info_field (array_die, DW_AT_data_location, info->data_location,
 			  info->base_decl);

	Jakub

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Tobias Burnus]

Jakub Jelinek wrote:
> On Fri, Nov 16, 2007 at 02:06:42PM +0100, Tobias Burnus wrote:
>   
>> Jakub Jelinek wrote:
>>     
>>> Can you look at with idb on gfortran (vanilla or patched) generated MAIN__
>>> x and y arrays after the bar subroutine returns and see if they are
>>> displayed in the expected order or not?  
>>>       
>> For the a5.f90 test case, compiled with ifort (!) I get:
>>     
> Ok, can you retry with the following additional patch on top of the previous
> one?

Now I get with gfortran (both patches) and idb (using a4.f90):

(idb) ptype varx
type = REAL(4)(6)(11)(12)

Which looks ok. The problem with the <no value> seems to be that the
deallocate comes too early - or that I cannot operate the debugger:

(idb) next
6         varx(2, 6, 18) = 8
(idb) p varx
$6 = {{{7, 6, 6, 6, 6, 6}, {6
(idb) next
7         varx(6, 15, 28) = 9
(idb) p varx
$8 = {{{7, 6, 6, 6, 6, 6}, {6
(idb) next
8         deallocate (varx)
(idb) p varx
$9 = {{{<no value>, <no value>,

 * * *

Regarding the test case a4.f90 and a4.f90: I get for x(3,1) with
gfortran a "10.0" but with g95, nag f95 and ifort a "4.0", which
indicates a bug in gfortran.

Tobias

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Jakub Jelinek]

On Fri, Nov 16, 2007 at 05:14:14PM +0100, Tobias Burnus wrote:
> Regarding the test case a4.f90 and a4.f90: I get for x(3,1) with
> gfortran a "10.0" but with g95, nag f95 and ifort a "4.0", which
> indicates a bug in gfortran.

That depends.  There are two foo calls, one is called with x,
one with transpose(x).  So, x(3,1) is supposed to be 4.0 after
the first foo and 10.0 after the second foo call.
And it works just fine for me with gfortran.

	Jakub

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Tobias Burnus]

Tobias Burnus wrote:
> Regarding the test case a4.f90 and a4.f90: I get for x(3,1) with
> gfortran a "10.0" but with g95, nag f95 and ifort a "4.0", which
> indicates a bug in gfortran.
>   

This is not a bug in gfortran but a bug in the program. A minimal test
case is:

program prog
  implicit none
  integer :: a(2,2)
  a = 0
  call test(transpose(a))
  print *, a
contains
  subroutine test(x)
    ! intent(out) :: x ! uncommenting this gives a compile error
    integer :: x(:,:)
    x = 3
  end subroutine test
end program prog


Here, the question is whether one can assign to "tranpose(a)" or not.
gfortran does not create a copy of the variable "a" as the other
compilers seem to do, but works with strides. Therefore, gfortran prints
"3 3 3 3" and ifort, NAG f95, g95 and openf95 print "0 0 0 0".

Turning on all debugging, NAG f95 prints at run time:

Dummy argument X is associated with an expression - cannot assign

And all compiler reject this example if one adds "INTENT(OUT)" for the
dummy "x" in "test".

Thus: If the example is for the test suite, please fix it. One way to do
so is to change the subroutine into a function and returning the
function. Or doing "x = tranpose(x)" before the call or ...

Tobias

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Jakub Jelinek]

On Fri, Nov 16, 2007 at 05:36:53PM +0100, Tobias Burnus wrote:
> Tobias Burnus wrote:
> > Regarding the test case a4.f90 and a4.f90: I get for x(3,1) with
> > gfortran a "10.0" but with g95, nag f95 and ifort a "4.0", which
> > indicates a bug in gfortran.
> >   
> 
> This is not a bug in gfortran but a bug in the program. A minimal test
> case is:
> 
> program prog
>   implicit none
>   integer :: a(2,2)
>   a = 0
>   call test(transpose(a))
>   print *, a
> contains
>   subroutine test(x)
>     ! intent(out) :: x ! uncommenting this gives a compile error
>     integer :: x(:,:)
>     x = 3
>   end subroutine test
> end program prog

Ok.  The testcase was definitely meant to see the array with the swapped
strides to see if the debugger can see it.  If it can't assign it, it should
just take another (say logical) argument and for the second case just
read/compare the values rather than testing what ended up in the caller's
array.  The testcase isn't meant for gcc testsuite anyway.
Or if you have better ideas how to get arrays with really weird stride
setups, I think Jan will appreciate that for GDB testsuite.

	Jakub

Re: [PATCH] Debug support for Fortran 90 assumed shape and other descriptor using arrays (PR fortran/22244)

[Richard Guenther]

On Nov 16, 2007 2:28 PM, Jakub Jelinek <jakub@redhat.com> wrote:
> On Fri, Nov 16, 2007 at 02:06:42PM +0100, Tobias Burnus wrote:
> > Jakub Jelinek wrote:
> > > Can you look at with idb on gfortran (vanilla or patched) generated MAIN__
> > > x and y arrays after the bar subroutine returns and see if they are
> > > displayed in the expected order or not?
> > >
> > For the a5.f90 test case, compiled with ifort (!) I get:
>
> Ok, can you retry with the following additional patch on top of the previous
> one?
> It seems ifort emits DW_AT_subrange_type's in the same order as GCC, i.e.
> for (1:5, 4:7, 8:9) there is
> DW_AT_subrange_type
>   DW_AT_lower_bound 1
>   DW_AT_upper_bound 5
> DW_AT_subrange_type
>   DW_AT_lower_bound 4
>   DW_AT_upper_bound 7
> DW_AT_subrange_type
>   DW_AT_lower_bound 8
>   DW_AT_upper_bound 9
> but GCC doesn't add any DW_AT_ordering, while ifort adds
> DW_AT_ordering DW_ORD_col_major.
>
> Wonder what gdb will do in presence of DW_ORD_col_major, I fear that
> DW_ORD_col_major means it just reverses the order of DW_AT_subrange_type
> notes and has hardcoded another reordering for Fortran or something, Jan?

This is ok if properly tested.

Thanks,
Richard.

> --- gcc/dwarf2out.c.jj  2007-11-15 20:05:54.000000000 +0100
> +++ gcc/dwarf2out.c     2007-11-16 14:16:13.000000000 +0100
> @@ -11636,6 +11636,12 @@ gen_array_type_die (tree type, dw_die_re
>        add_AT_flag (array_die, DW_AT_GNU_vector, 1);
>      }
>
> +  /* For Fortran multidimensional arrays use DW_ORD_col_major ordering.  */
> +  if (is_fortran ()
> +      && TREE_CODE (type) == ARRAY_TYPE
> +      && TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
> +    add_AT_unsigned (array_die, DW_AT_ordering, DW_ORD_col_major);
> +
>  #if 0
>    /* We default the array ordering.  SDB will probably do
>       the right things even if DW_AT_ordering is not present.  It's not even
> @@ -11787,6 +11793,11 @@ gen_descr_array_type_die (tree type, str
>    add_name_attribute (array_die, type_tag (type));
>    equate_type_number_to_die (type, array_die);
>
> +  /* For Fortran multidimensional arrays use DW_ORD_col_major ordering.  */
> +  if (is_fortran ()
> +      && info->ndimensions >= 2)
> +    add_AT_unsigned (array_die, DW_AT_ordering, DW_ORD_col_major);
> +
>
>    if (info->data_location)
>      add_descr_info_field (array_die, DW_AT_data_location, info->data_location,
>                           info->base_decl);
>
>         Jakub
>