Re: [PATCH 1/3][PING] fort_dyn_array: Enable dynamic member types inside a structure.

["Heckel, Bernhard" <bernhard.heckel@intel.com>]

On 17/03/2016 09:43, Bernhard Heckel wrote:
> fort_dyn_array: Enable dynamic member types inside a structure.
>
> 2016-02-24  Bernhard Heckel  <bernhard.heckel@intel.com>
> 2015-03-20  Keven Boell  <keven.boell@intel.com>
>
> Before:
> (gdb) print threev%ivla(1)
> Cannot access memory at address 0x3
> (gdb) print threev%ivla(5)
> no such vector element
>
> After:
> (gdb) print threev%ivla(1)
> $9 = 1
> (gdb) print threev%ivla(5)
> $10 = 42
>
> gdb/Changelog:
>
> 	* gdbtypes.c (remove_dyn_prop): New.
> 	* gdbtypes.h: Forward declaration of new function.
> 	* value.c (value_address): Return dynamic resolved location of a value.
> 	(set_value_component_location): Adjust the value address
> 	for single value prints.
> 	(value_primitive_field): Support value types with a dynamic location.
> 	(set_internalvar): Remove dynamic location property of
> 	internal variables.
>
> gdb/testsuite/Changelog:
>
> 	* gdb.fortran/vla-type.f90: New file.
> 	* gdb.fortran/vla-type.exp: New file.
>
> ---
>   gdb/gdbtypes.c                         | 43 +++++++++++++--
>   gdb/gdbtypes.h                         |  3 ++
>   gdb/testsuite/gdb.fortran/vla-type.exp | 98 ++++++++++++++++++++++++++++++++++
>   gdb/testsuite/gdb.fortran/vla-type.f90 | 88 ++++++++++++++++++++++++++++++
>   gdb/value.c                            | 35 ++++++++++--
>   5 files changed, 261 insertions(+), 6 deletions(-)
>   create mode 100755 gdb/testsuite/gdb.fortran/vla-type.exp
>   create mode 100755 gdb/testsuite/gdb.fortran/vla-type.f90
>
> diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
> index f129b0e..066fe88 100644
> --- a/gdb/gdbtypes.c
> +++ b/gdb/gdbtypes.c
> @@ -2064,7 +2064,8 @@ resolve_dynamic_struct (struct type *type,
>   
>         pinfo.type = check_typedef (TYPE_FIELD_TYPE (type, i));
>         pinfo.valaddr = addr_stack->valaddr;
> -      pinfo.addr = addr_stack->addr;
> +      pinfo.addr = addr_stack->addr
> +              + (TYPE_FIELD_BITPOS (resolved_type, i) / TARGET_CHAR_BIT);
>         pinfo.next = addr_stack;
>   
>         TYPE_FIELD_TYPE (resolved_type, i)
> @@ -2090,8 +2091,13 @@ resolve_dynamic_struct (struct type *type,
>   	resolved_type_bit_length = new_bit_length;
>       }
>   
> -  TYPE_LENGTH (resolved_type)
> -    = (resolved_type_bit_length + TARGET_CHAR_BIT - 1) / TARGET_CHAR_BIT;
> +  /* Type length won't change for fortran. Keep what we got from DWARF.
> +     Dynamic fields might change over time but not the struct definition.
> +     If we would adapt it we run into problems when
> +     calculating the element offset for arrays of structs.  */
> +  if (current_language->la_language != language_fortran)
> +    TYPE_LENGTH (resolved_type)
> +      = (resolved_type_bit_length + TARGET_CHAR_BIT - 1) / TARGET_CHAR_BIT;
>   
>     /* The Ada language uses this field as a cache for static fixed types: reset
>        it as RESOLVED_TYPE must have its own static fixed type.  */
> @@ -2224,6 +2230,37 @@ add_dyn_prop (enum dynamic_prop_node_kind prop_kind, struct dynamic_prop prop,
>     TYPE_DYN_PROP_LIST (type) = temp;
>   }
>   
> +/* Remove dynamic property from a type in case it exist.  */
> +
> +void
> +remove_dyn_prop (enum dynamic_prop_node_kind prop_kind,
> +                 struct type *type)
> +{
> +  struct dynamic_prop_list *prev_node, *curr_node;
> +
> +  curr_node = TYPE_DYN_PROP_LIST (type);
> +  prev_node = NULL;
> +
> +  while (NULL != curr_node)
> +    {
> +      if (curr_node->prop_kind == prop_kind)
> +	{
> +	  /* Upadate the linked list but don't free anything.
> +	     The property was allocated on objstack and it is not known
> +	     if we are on top of it. Nevertheless, everything is released
> +	     when the complete objstack is freed.  */
> +	  if (NULL == prev_node)
> +	    TYPE_DYN_PROP_LIST (type) = curr_node->next;
> +	  else
> +	    prev_node->next = curr_node->next;
> +
> +	  return;
> +	}
> +
> +      prev_node = curr_node;
> +      curr_node = curr_node->next;
> +    }
> +}
>   
>   /* Find the real type of TYPE.  This function returns the real type,
>      after removing all layers of typedefs, and completing opaque or stub
> diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
> index e775a1d..b118610 100644
> --- a/gdb/gdbtypes.h
> +++ b/gdb/gdbtypes.h
> @@ -1823,6 +1823,9 @@ extern void add_dyn_prop
>     (enum dynamic_prop_node_kind kind, struct dynamic_prop prop,
>      struct type *type, struct objfile *objfile);
>   
> +extern void remove_dyn_prop (enum dynamic_prop_node_kind prop_kind,
> +                             struct type *type);
> +
>   extern struct type *check_typedef (struct type *);
>   
>   extern void check_stub_method_group (struct type *, int);
> diff --git a/gdb/testsuite/gdb.fortran/vla-type.exp b/gdb/testsuite/gdb.fortran/vla-type.exp
> new file mode 100755
> index 0000000..1d09451
> --- /dev/null
> +++ b/gdb/testsuite/gdb.fortran/vla-type.exp
> @@ -0,0 +1,98 @@
> +# Copyright 2016 Free Software Foundation, Inc.
> +
> +# This program is free software; you can redistribute it and/or modify
> +# it under the terms of the GNU General Public License as published by
> +# the Free Software Foundation; either version 3 of the License, or
> +# (at your option) any later version.
> +#
> +# This program is distributed in the hope that it will be useful,
> +# but WITHOUT ANY WARRANTY; without even the implied warranty of
> +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +# GNU General Public License for more details.
> +#
> +# You should have received a copy of the GNU General Public License
> +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
> +
> +standard_testfile ".f90"
> +
> +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
> +     {debug f90 quiet}] } {
> +    return -1
> +}
> +
> +if ![runto_main] {
> +    untested "could not run to main"
> +    return -1
> +}
> +
> +# Check if not allocated VLA in type does not break
> +# the debugger when accessing it.
> +gdb_breakpoint [gdb_get_line_number "before-allocated"]
> +gdb_continue_to_breakpoint "before-allocated"
> +gdb_test "print twov" " = \\\( <not allocated>, <not allocated> \\\)" \
> +  "print twov before allocated"
> +gdb_test "print twov%ivla1" " = <not allocated>" \
> +  "print twov%ivla1 before allocated"
> +
> +# Check type with one VLA's inside
> +gdb_breakpoint [gdb_get_line_number "onev-filled"]
> +gdb_continue_to_breakpoint "onev-filled"
> +gdb_test "print onev%ivla(5, 11, 23)" " = 1"
> +gdb_test "print onev%ivla(1, 2, 3)" " = 123"
> +gdb_test "print onev%ivla(3, 2, 1)" " = 321"
> +gdb_test "ptype onev" \
> +         [multi_line "type = Type one" \
> +                     "\\s+integer\\\(kind=4\\\) :: ivla\\\(11,22,33\\\)" \
> +                     "End Type one" ]
> +
> +# Check type with two VLA's inside
> +gdb_breakpoint [gdb_get_line_number "twov-filled"]
> +gdb_continue_to_breakpoint "twov-filled"
> +gdb_test "print twov%ivla1(5, 11, 23)" " = 1"
> +gdb_test "print twov%ivla1(1, 2, 3)" " = 123"
> +gdb_test "print twov%ivla1(3, 2, 1)" " = 321"
> +gdb_test "ptype twov" \
> +         [multi_line "type = Type two" \
> +                     "\\s+integer\\\(kind=4\\\) :: ivla1\\\(5,12,99\\\)" \
> +                     "\\s+integer\\\(kind=4\\\) :: ivla2\\\(9,12\\\)" \
> +                     "End Type two" ]
> +
> +# Check type with attribute at beginn of type
> +gdb_breakpoint [gdb_get_line_number "threev-filled"]
> +gdb_continue_to_breakpoint "threev-filled"
> +gdb_test "print threev%ivla(1)" " = 1"
> +gdb_test "print threev%ivla(5)" " = 42"
> +gdb_test "print threev%ivla(14)" " = 24"
> +gdb_test "print threev%ivar" " = 3"
> +gdb_test "ptype threev" \
> +         [multi_line "type = Type three" \
> +                     "\\s+integer\\\(kind=4\\\) :: ivar" \
> +                     "\\s+integer\\\(kind=4\\\) :: ivla\\\(20\\\)" \
> +                     "End Type three" ]
> +
> +# Check type with attribute at end of type
> +gdb_breakpoint [gdb_get_line_number "fourv-filled"]
> +gdb_continue_to_breakpoint "fourv-filled"
> +gdb_test "print fourv%ivla(1)" " = 1"
> +gdb_test "print fourv%ivla(2)" " = 2"
> +gdb_test "print fourv%ivla(7)" " = 7"
> +gdb_test "print fourv%ivla(12)" "no such vector element"
> +gdb_test "print fourv%ivar" " = 3"
> +gdb_test "ptype fourv" \
> +         [multi_line "type = Type four" \
> +                     "\\s+integer\\\(kind=4\\\) :: ivla\\\(10\\\)" \
> +                     "\\s+integer\\\(kind=4\\\) :: ivar" \
> +                     "End Type four" ]
> +
> +# Check nested types containing a VLA
> +gdb_breakpoint [gdb_get_line_number "fivev-filled"]
> +gdb_continue_to_breakpoint "fivev-filled"
> +gdb_test "print fivev%tone%ivla(5, 5, 1)" " = 1"
> +gdb_test "print fivev%tone%ivla(1, 2, 3)" " = 123"
> +gdb_test "print fivev%tone%ivla(3, 2, 1)" " = 321"
> +gdb_test "ptype fivev" \
> +         [multi_line "type = Type five" \
> +                     "\\s+Type one" \
> +                     "\\s+integer\\\(kind=4\\\) :: ivla\\\(10,10,10\\\)" \
> +                     "\\s+End Type one :: tone" \
> +                     "End Type five" ]
> diff --git a/gdb/testsuite/gdb.fortran/vla-type.f90 b/gdb/testsuite/gdb.fortran/vla-type.f90
> new file mode 100755
> index 0000000..a106617
> --- /dev/null
> +++ b/gdb/testsuite/gdb.fortran/vla-type.f90
> @@ -0,0 +1,88 @@
> +! Copyright 2016 Free Software Foundation, Inc.
> +
> +! This program is free software; you can redistribute it and/or modify
> +! it under the terms of the GNU General Public License as published by
> +! the Free Software Foundation; either version 3 of the License, or
> +! (at your option) any later version.
> +!
> +! This program is distributed in the hope that it will be useful,
> +! but WITHOUT ANY WARRANTY; without even the implied warranty of
> +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
> +! GNU General Public License for more details.
> +!
> +! You should have received a copy of the GNU General Public License
> +! along with this program.  If not, see <http://www.gnu.org/licenses/>.
> +
> +program vla_struct
> +  type :: one
> +    integer, allocatable :: ivla (:, :, :)
> +  end type one
> +  type :: two
> +    integer, allocatable :: ivla1 (:, :, :)
> +    integer, allocatable :: ivla2 (:, :)
> +  end type two
> +  type :: three
> +    integer :: ivar
> +    integer, allocatable :: ivla (:)
> +  end type three
> +  type :: four
> +    integer, allocatable :: ivla (:)
> +    integer :: ivar
> +  end type four
> +  type :: five
> +    type(one) :: tone
> +  end type five
> +
> +  type(one), target        :: onev
> +  type(two)                :: twov
> +  type(three)              :: threev
> +  type(four)               :: fourv
> +  type(five)               :: fivev
> +  logical                  :: l
> +  integer                  :: i, j
> +
> +  allocate (onev%ivla (11,22,33))         ! before-allocated
> +  l = allocated(onev%ivla)
> +
> +  onev%ivla(:, :, :) = 1
> +  onev%ivla(1, 2, 3) = 123
> +  onev%ivla(3, 2, 1) = 321
> +
> +  allocate (twov%ivla1 (5,12,99))         ! onev-filled
> +  l = allocated(twov%ivla1)
> +  allocate (twov%ivla2 (9,12))
> +  l = allocated(twov%ivla2)
> +
> +  twov%ivla1(:, :, :) = 1
> +  twov%ivla1(1, 2, 3) = 123
> +  twov%ivla1(3, 2, 1) = 321
> +
> +  twov%ivla2(:, :) = 1
> +  twov%ivla2(1, 2) = 12
> +  twov%ivla2(2, 1) = 21
> +
> +  threev%ivar = 3                      ! twov-filled
> +  allocate (threev%ivla (20))
> +  l = allocated(threev%ivla)
> +
> +  threev%ivla(:) = 1
> +  threev%ivla(5) = 42
> +  threev%ivla(14) = 24
> +
> +  allocate (fourv%ivla (10))             ! threev-filled
> +  l = allocated(fourv%ivla)
> +
> +  fourv%ivar = 3
> +  fourv%ivla(:) = 1
> +  fourv%ivla(2) = 2
> +  fourv%ivla(7) = 7
> +
> +  allocate (fivev%tone%ivla (10, 10, 10))         ! fourv-filled
> +  l = allocated(fivev%tone%ivla)
> +  fivev%tone%ivla(:, :, :) = 1
> +  fivev%tone%ivla(1, 2, 3) = 123
> +  fivev%tone%ivla(3, 2, 1) = 321
> +
> +  ! dummy statement for bp
> +  l = allocated(fivev%tone%ivla)                  ! fivev-filled
> +end program vla_struct
> diff --git a/gdb/value.c b/gdb/value.c
> index 738b2b2..e7b01cf 100644
> --- a/gdb/value.c
> +++ b/gdb/value.c
> @@ -1530,8 +1530,13 @@ value_address (const struct value *value)
>       return 0;
>     if (value->parent != NULL)
>       return value_address (value->parent) + value->offset;
> -  else
> -    return value->location.address + value->offset;
> +  if (TYPE_DATA_LOCATION (value_type (value)))
> +    {
> +      gdb_assert (PROP_CONST == TYPE_DATA_LOCATION_KIND (value_type (value)));
> +      return TYPE_DATA_LOCATION_ADDR (value_type (value));
> +    }
> +
> +  return value->location.address + value->offset;
>   }
>   
>   CORE_ADDR
> @@ -1846,6 +1851,8 @@ void
>   set_value_component_location (struct value *component,
>   			      const struct value *whole)
>   {
> +  struct type *type;
> +
>     gdb_assert (whole->lval != lval_xcallable);
>   
>     if (whole->lval == lval_internalvar)
> @@ -1861,9 +1868,14 @@ set_value_component_location (struct value *component,
>         if (funcs->copy_closure)
>           component->location.computed.closure = funcs->copy_closure (whole);
>       }
> +
> +  /* If type has a dynamic resolved location property update it's value address.  */
> +  type = value_type (whole);
> +  if (TYPE_DATA_LOCATION (type)
> +      && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
> +    set_value_address (component, TYPE_DATA_LOCATION_ADDR (type));
>   }
>   
> -\f
>   /* Access to the value history.  */
>   
>   /* Record a new value in the value history.
> @@ -2416,6 +2428,12 @@ set_internalvar (struct internalvar *var, struct value *val)
>   	 call error () until new_data is installed into the var->u to avoid
>   	 leaking memory.  */
>         release_value (new_data.value);
> +
> +      /* Internal variables which are created from values with a dynamic location
> +         don't need the location property of the origin anymore.
> +         Remove the location property in case it exist.  */
> +      remove_dyn_prop(DYN_PROP_DATA_LOCATION, value_type(new_data.value));
> +
>         break;
>       }
>   
> @@ -3157,6 +3175,17 @@ value_primitive_field (struct value *arg1, int offset,
>         v->offset = value_offset (arg1);
>         v->embedded_offset = offset + value_embedded_offset (arg1) + boffset;
>       }
> +  else if (TYPE_DATA_LOCATION (type))
> +    {
> +      /* Field is a dynamic data member.  */
> +
> +      gdb_assert (0 == offset);
> +      /* We expect an already resolved data location.  */
> +      gdb_assert (PROP_CONST == TYPE_DATA_LOCATION_KIND (type));
> +      /* For dynamic data types defer memory allocation
> +         until we actual access the value.  */
> +      v = allocate_value_lazy (type);
> +    }
>     else
>       {
>         /* Plain old data member */

-- 

Intel Deutschland GmbH
Registered Address: Am Campeon 10-12, 85579 Neubiberg, Germany
Tel: +49 89 99 8853-0, www.intel.de
Managing Directors: Christin Eisenschmid, Christian Lamprechter
Chairperson of the Supervisory Board: Nicole Lau
Registered Office: Munich
Commercial Register: Amtsgericht Muenchen HRB 186928

Intel Deutschland GmbH
Registered Address: Am Campeon 10-12, 85579 Neubiberg, Germany
Tel: +49 89 99 8853-0, www.intel.de
Managing Directors: Christin Eisenschmid, Christian Lamprechter
Chairperson of the Supervisory Board: Nicole Lau
Registered Office: Munich
Commercial Register: Amtsgericht Muenchen HRB 186928