From patchwork Thu Nov 5 15:56:31 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Keven Boell X-Patchwork-Id: 9563 Received: (qmail 85051 invoked by alias); 5 Nov 2015 15:56:39 -0000 Mailing-List: contact gdb-patches-help@sourceware.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Subscribe: List-Archive: List-Post: List-Help: , Sender: gdb-patches-owner@sourceware.org Delivered-To: mailing list gdb-patches@sourceware.org Received: (qmail 85035 invoked by uid 89); 5 Nov 2015 15:56:39 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.4 required=5.0 tests=AWL, BAYES_00, KAM_LAZY_DOMAIN_SECURITY, T_RP_MATCHES_RCVD, UNSUBSCRIBE_BODY autolearn=no version=3.3.2 X-HELO: mga03.intel.com Received: from mga03.intel.com (HELO mga03.intel.com) (134.134.136.65) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 05 Nov 2015 15:56:37 +0000 Received: from fmsmga001.fm.intel.com ([10.253.24.23]) by orsmga103.jf.intel.com with ESMTP; 05 Nov 2015 07:56:35 -0800 X-ExtLoop1: 1 Received: from irvmail001.ir.intel.com ([163.33.26.43]) by fmsmga001.fm.intel.com with ESMTP; 05 Nov 2015 07:56:33 -0800 Received: from ullecvh004g04.iul.intel.com (ullecvh004g04.iul.intel.com [172.28.50.14]) by irvmail001.ir.intel.com (8.14.3/8.13.6/MailSET/Hub) with ESMTP id tA5FuWWY018490; Thu, 5 Nov 2015 15:56:32 GMT Received: from ullecvh004g04.iul.intel.com (ullecvh004g04.iul.intel.com [127.0.0.1]) by ullecvh004g04.iul.intel.com (8.13.8/8.13.8) with ESMTP id tA5FuW0f023994; Thu, 5 Nov 2015 16:56:32 +0100 Received: (from kboell@localhost) by ullecvh004g04.iul.intel.com (8.13.8/8.13.8/Submit) id tA5FuW5w023993; Thu, 5 Nov 2015 16:56:32 +0100 From: Keven Boell To: gdb-patches@sourceware.org Cc: Keven Boell Subject: [PATCH] fort_dyn_array: enable dynamic array of types Date: Thu, 5 Nov 2015 16:56:31 +0100 Message-Id: <1446738991-23962-1-git-send-email-keven.boell@intel.com> This patch enables dynamic arrays of types in Fortran. 2015-03-20 Keven Boell * gdbtypes.c (resolve_dyn_properties): New. (resolve_dynamic_range): Add call to resolve_dyn_properties to resolve data_location. (resolve_dynamic_array): Add call to resolve_dyn_properties to resolve data_location. (resolve_dynamic_union): Add call to resolve_dyn_properties to resolve_data_location. (resolve_dynamic_struct): Add call to resolve_dyn_properties to resolve_data_location. Adjust address of inner types of a struct to reflect the offset of the inner's type data_location. (resolve_dynamic_type_internal): Remove data_location computation. * value.c (set_value_component_location): Adjust the value address for single value prints. (value_primitive_field): Use lazy fetch to re-evaluate a field to get the actual value. (value_fetch_lazy): Use address provided by DWARF data_location attribute if present. testsuite/gdb.fortran: * vla-type.exp: New file. * vla-type.f90: New file. --- gdb/gdbtypes.c | 33 ++++++++++- gdb/testsuite/gdb.fortran/vla-type.exp | 94 ++++++++++++++++++++++++++++++++ gdb/testsuite/gdb.fortran/vla-type.f90 | 89 ++++++++++++++++++++++++++++++ gdb/value.c | 47 +++++++++++++--- 4 files changed, 253 insertions(+), 10 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 b9850cf..4a9cae8 100644 --- a/gdb/gdbtypes.c +++ b/gdb/gdbtypes.c @@ -1878,6 +1878,21 @@ is_dynamic_type (struct type *type) static struct type *resolve_dynamic_type_internal (struct type *type, struct property_addr_info *addr_stack, int top_level); +static void +resolve_dyn_properties (struct type *type, struct property_addr_info *addr_stack) +{ + CORE_ADDR value; + struct dynamic_prop *prop; + + /* Resolve data_location attribute. */ + prop = TYPE_DATA_LOCATION (type); + if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value)) + { + TYPE_DYN_PROP_ADDR (prop) = value; + TYPE_DYN_PROP_KIND (prop) = PROP_CONST; + } +} + /* Given a dynamic range type (dyn_range_type) and a stack of struct property_addr_info elements, return a static version of that type. */ @@ -1929,6 +1944,7 @@ resolve_dynamic_range (struct type *dyn_range_type, static_target_type, &low_bound, &high_bound); TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1; + resolve_dyn_properties (static_range_type, addr_stack); return static_range_type; } @@ -1945,6 +1961,7 @@ resolve_dynamic_array (struct type *type, struct type *range_type; struct type *ary_dim; struct dynamic_prop *prop; + struct type *return_type; gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY); @@ -1976,8 +1993,10 @@ resolve_dynamic_array (struct type *type, else elt_type = TYPE_TARGET_TYPE (type); - return create_array_type_with_stride (type, elt_type, range_type, - TYPE_FIELD_BITSIZE (type, 0)); + return_type = create_array_type_with_stride (type, + elt_type, range_type, TYPE_FIELD_BITSIZE (type, 0)); + resolve_dyn_properties (return_type, addr_stack); + return return_type; } /* Resolve dynamic bounds of members of the union TYPE to static @@ -2017,6 +2036,7 @@ resolve_dynamic_union (struct type *type, } TYPE_LENGTH (resolved_type) = max_len; + resolve_dyn_properties (resolved_type, addr_stack); return resolved_type; } @@ -2043,6 +2063,9 @@ resolve_dynamic_struct (struct type *type, memcpy (TYPE_FIELDS (resolved_type), TYPE_FIELDS (type), TYPE_NFIELDS (resolved_type) * sizeof (struct field)); + + resolve_dyn_properties (resolved_type, addr_stack); + for (i = 0; i < TYPE_NFIELDS (resolved_type); ++i) { unsigned new_bit_length; @@ -2064,7 +2087,11 @@ 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; + if (TYPE_CODE (TYPE_FIELD_TYPE (resolved_type, i)) != TYPE_CODE_RANGE) + pinfo.addr = addr_stack->addr + + (TYPE_FIELD_BITPOS (resolved_type, i) / 8); + else + pinfo.addr = addr_stack->addr; pinfo.next = addr_stack; TYPE_FIELD_TYPE (resolved_type, i) diff --git a/gdb/testsuite/gdb.fortran/vla-type.exp b/gdb/testsuite/gdb.fortran/vla-type.exp new file mode 100755 index 0000000..ffd0ab4 --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-type.exp @@ -0,0 +1,94 @@ +# Copyright 2015 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 . + +standard_testfile ".f90" + +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ + {debug f90 quiet}] } { + return -1 +} + +if ![runto MAIN__] then { + perror "couldn't run to breakpoint MAIN__" + continue +} + +# 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" "\\$\\d+ = \\\( , \\\)" \ + "print twov before allocated" +gdb_test "print twov%ivla1" "\\$\\d+ = " \ + "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)" "\\$\\d+ = 1" "print onev%ivla(5, 11, 23)" +gdb_test "print onev%ivla(1, 2, 3)" "\\$\\d+ = 123" "print onev%ivla(1, 2, 3)" +gdb_test "print onev%ivla(3, 2, 1)" "\\$\\d+ = 321" "print onev%ivla(3, 2, 1)" +gdb_test "ptype onev" \ + "type = Type one\r\n\\s+real\\\(kind=4\\\) :: ivla\\\(11,22,33\\\)\r\nEnd Type one" \ + "ptype onev" + +# 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)" "\\$\\d+ = 1" \ + "print twov%ivla1(5, 11, 23)" +gdb_test "print twov%ivla1(1, 2, 3)" "\\$\\d+ = 123" \ + "print twov%ivla1(1, 2, 3)" +gdb_test "print twov%ivla1(3, 2, 1)" "\\$\\d+ = 321" \ + "print twov%ivla1(3, 2, 1)" +gdb_test "ptype twov" \ + "type = Type two\r\n\\s+real\\\(kind=4\\\) :: ivla1\\\(5,12,99\\\)\r\n\\s+real\\\(kind=4\\\) :: ivla2\\\(9,12\\\)\r\nEnd Type two" \ + "ptype twov" + +# 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)" "\\$\\d+ = 1" "print threev%ivla(1)" +gdb_test "print threev%ivla(5)" "\\$\\d+ = 42" "print threev%ivla(5)" +gdb_test "print threev%ivla(14)" "\\$\\d+ = 24" "print threev%ivla(14)" +gdb_test "print threev%ivar" "\\$\\d+ = 3.14\\d+?" "print threev%ivar" +gdb_test "ptype threev" \ + "type = Type three\r\n\\s+real\\\(kind=4\\\) :: ivar\r\n\\s+real\\\(kind=4\\\) :: ivla\\\(20\\\)\r\nEnd Type three" \ + "ptype threev" + +# 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)" "\\$\\d+ = 1" "print fourv%ivla(1)" +gdb_test "print fourv%ivla(2)" "\\$\\d+ = 2" "print fourv%ivla(2)" +gdb_test "print fourv%ivla(7)" "\\$\\d+ = 7" "print fourv%ivla(7)" +gdb_test "print fourv%ivla(12)" "no such vector element" "print fourv%ivla(12)" +gdb_test "print fourv%ivar" "\\$\\d+ = 3.14\\d+?" "print fourv%ivar" +gdb_test "ptype fourv" \ + "type = Type four\r\n\\s+real\\\(kind=4\\\) :: ivla\\\(10\\\)\r\n\\s+real\\\(kind=4\\\) :: ivar\r\nEnd Type four" \ + "ptype fourv" + +# 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)" "\\$\\d+ = 1" \ + "print fivev%tone%ivla(5, 5, 1)" +gdb_test "print fivev%tone%ivla(1, 2, 3)" "\\$\\d+ = 123" \ + "print fivev%tone%ivla(1, 2, 3)" +gdb_test "print fivev%tone%ivla(3, 2, 1)" "\\$\\d+ = 321" \ + "print fivev%tone%ivla(3, 2, 1)" +gdb_test "ptype fivev" \ + "type = Type five\r\n\\s+Type one\r\n\\s+real\\\(kind=4\\\) :: ivla\\\(10,10,10\\\)\r\n\\s+End Type one :: tone\r\nEnd Type five" \ + "ptype fivev" diff --git a/gdb/testsuite/gdb.fortran/vla-type.f90 b/gdb/testsuite/gdb.fortran/vla-type.f90 new file mode 100755 index 0000000..cf3f24b --- /dev/null +++ b/gdb/testsuite/gdb.fortran/vla-type.f90 @@ -0,0 +1,89 @@ +! Copyright 2015 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 2 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, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +program vla_struct + type :: one + real, allocatable :: ivla (:, :, :) + end type one + type :: two + real, allocatable :: ivla1 (:, :, :) + real, allocatable :: ivla2 (:, :) + end type two + type :: three + real :: ivar + real, allocatable :: ivla (:) + end type three + type :: four + real, allocatable :: ivla (:) + real :: 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.14 ! 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.14 + 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 91bf49e..365cbaf 100644 --- a/gdb/value.c +++ b/gdb/value.c @@ -1788,6 +1788,25 @@ set_value_component_location (struct value *component, if (funcs->copy_closure) component->location.computed.closure = funcs->copy_closure (whole); } + + /* For dynamic types compute the address of the component value location in + sub range types based on the location of the sub range type, if not being + an internal GDB variable or parts of it. */ + if (VALUE_LVAL (component) != lval_internalvar + && VALUE_LVAL (component) != lval_internalvar_component) + { + CORE_ADDR addr; + struct type *type = value_type (whole); + + addr = value_raw_address (component); + + if (TYPE_DATA_LOCATION (type) + && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST) + { + addr = TYPE_DATA_LOCATION_ADDR (type); + set_value_address (component, addr); + } + } } @@ -3095,13 +3114,21 @@ value_primitive_field (struct value *arg1, int offset, v = allocate_value_lazy (type); else { - v = allocate_value (type); - value_contents_copy_raw (v, value_embedded_offset (v), - arg1, value_embedded_offset (arg1) + offset, - type_length_units (type)); + if (TYPE_DATA_LOCATION (type) + && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST) + v = value_at_lazy (type, value_address (arg1) + offset); + else + { + v = allocate_value (type); + value_contents_copy_raw (v, value_embedded_offset (v), + arg1, value_embedded_offset (arg1) + offset, + TYPE_LENGTH (type)); + } } - v->offset = (value_offset (arg1) + offset - + value_embedded_offset (arg1)); + if (!TYPE_DATA_LOCATION (type) + || !TYPE_DATA_LOCATION_KIND (type) == PROP_CONST) + v->offset = (value_offset (arg1) + offset + + value_embedded_offset (arg1)); } set_value_component_location (v, arg1); VALUE_REGNUM (v) = VALUE_REGNUM (arg1); @@ -3834,9 +3861,15 @@ value_fetch_lazy (struct value *val) } else if (VALUE_LVAL (val) == lval_memory) { - CORE_ADDR addr = value_address (val); + CORE_ADDR addr; struct type *type = check_typedef (value_enclosing_type (val)); + if (TYPE_DATA_LOCATION (type) != NULL + && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST) + addr = TYPE_DATA_LOCATION_ADDR (type); + else + addr = value_address (val); + if (TYPE_LENGTH (type)) read_value_memory (val, 0, value_stack (val), addr, value_contents_all_raw (val),