From b50d69b5aa88f7d46a360d4d4a5b088f3370ad9d Mon Sep 17 00:00:00 2001 From: Jerome Guitton Date: Thu, 29 Nov 2012 16:28:10 +0000 Subject: [PATCH] Full view of interface-wide types For displaying the full view of a class-wide object, GDB relies on the assumption that this view will have the same address as the address of the object. In the case of simple inheritance, this assumption is correct; the proper type is deduced by decoding the tag of the object and converting the result to this full-view type. Consider for example an abstract class Shape, a child Circle which implements an interface Drawable, and the corresponding following objects: My_Circle : Circle := ((1, 2), 3); My_Shape : Shape'Class := Shape'Class (My_Circle); My_Drawable : Drawable'Class := Drawable'Class (My_Circle); To display My_Shape, the debugger first extracts the tag (an internal field, usually the first one of the record): (gdb) p my_shape'address $2 = (system.address) 0x8063e28 (gdb) x/x my_shape'address 0x8063e28 : 0x08059ec4 Then the type specific data and the expanded name of the tag is read from there: (gdb) p my_shape'tag $3 = (access ada.tags.dispatch_table) 0x8059ec4 (classes.circle) To get the full view, the debugger converts to the corresponding type: (gdb) p {classes.circle}0x8063e28 $4 = (center => (x => 1, y => 2), radius => 3) Now, in the case of multiple inheritance, the assumption does not hold anymore. The address that we have usually points to some place lower. The offset to the original address is saved in the field Offset_To_Top of the metadata that are above the tag, at address obj'tag - 8. In the case of my_shape, this offset is 0: (gdb) x/x my_shape'tag - 8 0x8059ebc : 0x00000000 ...but in the case of an interface-wide object, it is not null: (gdb) x/x my_drawable'tag - 8 0x8063b28 : 0x00000004 (gdb) p {classes.circle}(my_drawable'address - 4) $7 = (center => (x => 1, y => 2), radius => 3) The following change handles this relocation in the most common cases. Remaining cases that are still to be investigated are signaled by comments. gdb/ChangeLog: * ada-lang.h (ada_tag_value_at_base_address): New function declaration. * ada-lang.c (is_ada95_tag, ada_tag_value_at_base_address): New functions. (ada_to_fixed_type_1, ada_evaluate_subexp): Let ada_tag_base_address relocate the class-wide value if need be. (ada_value_struct_elt, ada_value_ind, ada_coerce_ref): Let ada_tag_value_at_base_address relocate the class-wide access/ref before dereferencing it. * ada-valprint.c (ada_val_print_1): Relocate to base address before displaying the content of an interface-wide ref. gdb/testsuite/ChangeLog: * gdb.ada/ptype_tagged_param.exp: Adjust expected output in ptype test. --- gdb/ChangeLog | 14 ++ gdb/ada-lang.c | 158 ++++++++++++++++--- gdb/ada-lang.h | 2 + gdb/ada-valprint.c | 6 + gdb/testsuite/ChangeLog | 5 + gdb/testsuite/gdb.ada/ptype_tagged_param.exp | 2 +- 6 files changed, 165 insertions(+), 22 deletions(-) diff --git a/gdb/ChangeLog b/gdb/ChangeLog index cd86c848b94..60d4dc3032c 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,17 @@ +2012-11-29 Jerome Guitton + + * ada-lang.h (ada_tag_value_at_base_address): New function + declaration. + * ada-lang.c (is_ada95_tag, ada_tag_value_at_base_address): + New functions. + (ada_to_fixed_type_1, ada_evaluate_subexp): Let ada_tag_base_address + relocate the class-wide value if need be. + (ada_value_struct_elt, ada_value_ind, ada_coerce_ref): + Let ada_tag_value_at_base_address relocate the class-wide access/ref + before dereferencing it. + * ada-valprint.c (ada_val_print_1): Relocate to base address + before displaying the content of an interface-wide ref. + 2012-11-29 Jerome Guitton * ada-lang.c (ada_evaluate_subexp): Unwrap only in EVAL_NORMAL. diff --git a/gdb/ada-lang.c b/gdb/ada-lang.c index ee2f76529da..a34ba29dcad 100644 --- a/gdb/ada-lang.c +++ b/gdb/ada-lang.c @@ -6009,6 +6009,15 @@ ada_tag_type (struct value *val) return ada_lookup_struct_elt_type (value_type (val), "_tag", 1, 0, NULL); } +/* Return 1 if TAG follows the old scheme for Ada tags (used for Ada 95, + retired at Ada 05). */ + +static int +is_ada95_tag (struct value *tag) +{ + return ada_value_struct_elt (tag, "tsd", 1) != NULL; +} + /* The value of the tag on VAL. */ struct value * @@ -6052,6 +6061,88 @@ type_from_tag (struct value *tag) return NULL; } +/* Given a value OBJ of a tagged type, return a value of this + type at the base address of the object. The base address, as + defined in Ada.Tags, it is the address of the primary tag of + the object, and therefore where the field values of its full + view can be fetched. */ + +struct value * +ada_tag_value_at_base_address (struct value *obj) +{ + volatile struct gdb_exception e; + struct value *val; + LONGEST offset_to_top = 0; + struct type *ptr_type, *obj_type; + struct value *tag; + CORE_ADDR base_address; + + obj_type = value_type (obj); + + /* It is the responsability of the caller to deref pointers. */ + + if (TYPE_CODE (obj_type) == TYPE_CODE_PTR + || TYPE_CODE (obj_type) == TYPE_CODE_REF) + return obj; + + tag = ada_value_tag (obj); + if (!tag) + return obj; + + /* Base addresses only appeared with Ada 05 and multiple inheritance. */ + + if (is_ada95_tag (tag)) + return obj; + + ptr_type = builtin_type (target_gdbarch ())->builtin_data_ptr; + ptr_type = lookup_pointer_type (ptr_type); + val = value_cast (ptr_type, tag); + if (!val) + return obj; + + /* It is perfectly possible that an exception be raised while + trying to determine the base address, just like for the tag; + see ada_tag_name for more details. We do not print the error + message for the same reason. */ + + TRY_CATCH (e, RETURN_MASK_ERROR) + { + offset_to_top = value_as_long (value_ind (value_ptradd (val, -2))); + } + + if (e.reason < 0) + return obj; + + /* If offset is null, nothing to do. */ + + if (offset_to_top == 0) + return obj; + + /* -1 is a special case in Ada.Tags; however, what should be done + is not quite clear from the documentation. So do nothing for + now. */ + + if (offset_to_top == -1) + return obj; + + base_address = value_address (obj) - offset_to_top; + tag = value_tag_from_contents_and_address (obj_type, NULL, base_address); + + /* Make sure that we have a proper tag at the new address. + Otherwise, offset_to_top is bogus (which can happen when + the object is not initialized yet). */ + + if (!tag) + return obj; + + obj_type = type_from_tag (tag); + + if (!obj_type) + return obj; + + return value_from_contents_and_address (obj_type, NULL, base_address); +} + /* Return the "ada__tags__type_specific_data" type. */ static struct type * @@ -6707,9 +6798,9 @@ ada_value_struct_elt (struct value *arg, char *name, int no_err) CORE_ADDR address; if (TYPE_CODE (t) == TYPE_CODE_PTR) - address = value_as_address (arg); + address = value_address (ada_value_ind (arg)); else - address = unpack_pointer (t, value_contents (arg)); + address = value_address (ada_coerce_ref (arg)); t1 = ada_to_fixed_type (ada_get_base_type (t1), NULL, address, NULL, 1); if (find_struct_field (name, t1, 0, @@ -6985,6 +7076,9 @@ ada_value_ind (struct value *val0) { struct value *val = value_ind (val0); + if (ada_is_tagged_type (value_type (val), 0)) + val = ada_tag_value_at_base_address (val); + return ada_to_fixed_value (val); } @@ -6999,6 +7093,10 @@ ada_coerce_ref (struct value *val0) struct value *val = val0; val = coerce_ref (val); + + if (ada_is_tagged_type (value_type (val), 0)) + val = ada_tag_value_at_base_address (val); + return ada_to_fixed_value (val); } else @@ -7982,14 +8080,20 @@ ada_to_fixed_type_1 (struct type *type, const gdb_byte *valaddr, if (check_tag && address != 0 && ada_is_tagged_type (static_type, 0)) { - struct type *real_type = - type_from_tag (value_tag_from_contents_and_address - (fixed_record_type, - valaddr, - address)); - + struct value *tag = + value_tag_from_contents_and_address + (fixed_record_type, + valaddr, + address); + struct type *real_type = type_from_tag (tag); + struct value *obj = + value_from_contents_and_address (fixed_record_type, + valaddr, + address); if (real_type != NULL) - return to_fixed_record_type (real_type, valaddr, address, NULL); + return to_fixed_record_type + (real_type, NULL, + value_address (ada_tag_value_at_base_address (obj)), NULL); } /* Check to see if there is a parallel ___XVZ variable. @@ -9692,19 +9796,31 @@ ada_evaluate_subexp (struct type *expect_type, struct expression *exp, a fixed type would result in the loss of that type name, thus preventing us from printing the name of the ancestor type in the type description. */ - struct type *actual_type; - arg1 = evaluate_subexp (NULL_TYPE, exp, pos, EVAL_NORMAL); - actual_type = type_from_tag (ada_value_tag (arg1)); - if (actual_type == NULL) - /* If, for some reason, we were unable to determine - the actual type from the tag, then use the static - approximation that we just computed as a fallback. - This can happen if the debugging information is - incomplete, for instance. */ - actual_type = type; - - return value_zero (actual_type, not_lval); + + if (TYPE_CODE (type) != TYPE_CODE_REF) + { + struct type *actual_type; + + actual_type = type_from_tag (ada_value_tag (arg1)); + if (actual_type == NULL) + /* If, for some reason, we were unable to determine + the actual type from the tag, then use the static + approximation that we just computed as a fallback. + This can happen if the debugging information is + incomplete, for instance. */ + actual_type = type; + return value_zero (actual_type, not_lval); + } + else + { + /* In the case of a ref, ada_coerce_ref takes care + of determining the actual type. But the evaluation + should return a ref as it should be valid to ask + for its address; so rebuild a ref after coerce. */ + arg1 = ada_coerce_ref (arg1); + return value_ref (arg1); + } } *pos += 4; diff --git a/gdb/ada-lang.h b/gdb/ada-lang.h index fa6934bc62a..f6154fde09a 100644 --- a/gdb/ada-lang.h +++ b/gdb/ada-lang.h @@ -278,6 +278,8 @@ extern struct value *ada_value_tag (struct value *); extern const char *ada_tag_name (struct value *); +extern struct value *ada_tag_value_at_base_address (struct value *obj); + extern int ada_is_parent_field (struct type *, int); extern int ada_is_wrapper_field (struct type *, int); diff --git a/gdb/ada-valprint.c b/gdb/ada-valprint.c index ca30e42c5d7..20bb12e0839 100644 --- a/gdb/ada-valprint.c +++ b/gdb/ada-valprint.c @@ -891,6 +891,9 @@ ada_val_print_1 (struct type *type, const gdb_byte *valaddr, deref_val = coerce_ref_if_computed (original_value); if (deref_val) { + if (ada_is_tagged_type (value_type (deref_val), 1)) + deref_val = ada_tag_value_at_base_address (deref_val); + common_val_print (deref_val, stream, recurse + 1, options, current_language); break; @@ -904,6 +907,9 @@ ada_val_print_1 (struct type *type, const gdb_byte *valaddr, (lookup_pointer_type (elttype), deref_val_int)); + if (ada_is_tagged_type (value_type (deref_val), 1)) + deref_val = ada_tag_value_at_base_address (deref_val); + val_print (value_type (deref_val), value_contents_for_printing (deref_val), value_embedded_offset (deref_val), diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index c831c015ed8..7c79f605ab2 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2012-11-29 Jerome Guitton + + * gdb.ada/ptype_tagged_param.exp: Adjust expected output in + ptype test. + 2012-11-29 Jerome Guitton * gdb.ada/variant_record_packed_array.exp: Test expressions of the diff --git a/gdb/testsuite/gdb.ada/ptype_tagged_param.exp b/gdb/testsuite/gdb.ada/ptype_tagged_param.exp index e538b980d48..98ee5480355 100644 --- a/gdb/testsuite/gdb.ada/ptype_tagged_param.exp +++ b/gdb/testsuite/gdb.ada/ptype_tagged_param.exp @@ -31,6 +31,6 @@ set eol "\[\r\n\]+" set sp "\[ \t\]*" gdb_test "ptype s" \ - "type = new pck.shape with record${eol}${sp}r: integer;${eol}end record" \ + "type = new pck.shape with record${eol}${sp}r: integer;${eol}end record" \ "ptype s" -- 2.30.2