* [Ada] Null variant discriminant-checking functions needed for front-end layout
@ 2008-05-21 8:25 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2008-05-21 8:25 UTC (permalink / raw)
To: gcc-patches; +Cc: Gary Dismukes, Hristian Kirtchev
[-- Attachment #1: Type: text/plain, Size: 1002 bytes --]
Tested on i686-linux, commited on trunk
Discriminant-checking functions are normally not needed for a variant with
no components, so their generation was suppressed to eliminate the dead
code. However, when front-end type layout is enabled (such as for the
AAMP target), size functions are generated for variant records that depend
on being able to call the discriminant-checking functions of all variants.
Now, when the layout flag is set, the functions are now generated in all
cases.
See gnat.dg/specs/empty_variants.ads
2008-05-20 Gary Dismukes <dismukes@adacore.com>
Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb
(Expand_N_Object_Declaration): Correct the condition which triggers the
generation of a call to Displace when initializing a class-wide object.
(Build_Dcheck_Functions): Build discriminant-checking for null variants
when Frontend_Layout_On_Target is true to ensure that they're available
for calling when a record variant size function is built in Layout.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 7400 bytes --]
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 134945)
+++ exp_ch3.adb (working copy)
@@ -1027,10 +1027,14 @@ package body Exp_Ch3 is
Saved_Enclosing_Func_Id : Entity_Id;
begin
- -- Build the discriminant checking function for each variant, label
- -- all components of that variant with the function's name.
- -- We only Generate a discriminant-checking function only if the
+ -- Build the discriminant-checking function for each variant, and
+ -- label all components of that variant with the function's name.
+ -- We only Generate a discriminant-checking function when the
-- variant is not empty, to prevent the creation of dead code.
+ -- The exception to that is when Frontend_Layout_On_Target is set,
+ -- because the variant record size function generated in package
+ -- Layout needs to generate calls to all discriminant-checking
+ -- functions, including those for empty variants.
Discr_Name := Entity (Name (Variant_Part_Node));
Variant := First_Non_Pragma (Variants (Variant_Part_Node));
@@ -1038,7 +1042,9 @@ package body Exp_Ch3 is
while Present (Variant) loop
Component_List_Node := Component_List (Variant);
- if not Null_Present (Component_List_Node) then
+ if not Null_Present (Component_List_Node)
+ or else Frontend_Layout_On_Target
+ then
Func_Id := Build_Dcheck_Function (Discr_Name, Variant);
Decl :=
First_Non_Pragma (Component_Items (Component_List_Node));
@@ -4377,17 +4383,23 @@ package body Exp_Ch3 is
-- Ada 2005 (AI-251): Rewrite the expression that initializes a
-- class-wide object to ensure that we copy the full object,
- -- unless we're targetting a VM where interfaces are handled by
- -- VM itself.
+ -- unless we are targetting a VM where interfaces are handled by
+ -- VM itself. Note that if the root type of Typ is an ancestor
+ -- of Expr's type, both types share the same dispatch table and
+ -- there is no need to displace the pointer.
-- Replace
- -- CW : I'Class := Obj;
+ -- CW : I'Class := Obj;
-- by
- -- CW__1 : I'Class := I'Class (Base_Address (Obj'Address));
- -- CW : I'Class renames Displace (CW__1, I'Tag);
+ -- Temp : I'Class := I'Class (Base_Address (Obj'Address));
+ -- CW : I'Class renames Displace (Temp, I'Tag);
if Is_Interface (Typ)
- and then Is_Class_Wide_Type (Etype (Expr))
+ and then Is_Class_Wide_Type (Typ)
+ and then
+ (Is_Class_Wide_Type (Etype (Expr))
+ or else
+ not Is_Parent (Root_Type (Typ), Etype (Expr)))
and then Comes_From_Source (Def_Id)
and then VM_Target = No_VM
then
@@ -5344,7 +5356,7 @@ package body Exp_Ch3 is
and then Chars (Comp) = Chars (Old_Comp)
then
Set_Discriminant_Checking_Func (Comp,
- Discriminant_Checking_Func (Old_Comp));
+ Discriminant_Checking_Func (Old_Comp));
end if;
Next_Component (Old_Comp);
@@ -5658,8 +5670,8 @@ package body Exp_Ch3 is
null;
-- Do not add the body of the predefined primitives if we are
- -- compiling under restriction No_Dispatching_Calls of if we
- -- are compiling a CPP tagged type.
+ -- compiling under restriction No_Dispatching_Calls or if we are
+ -- compiling a CPP tagged type.
elsif not Restriction_Active (No_Dispatching_Calls) then
Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq);
@@ -6739,20 +6751,19 @@ package body Exp_Ch3 is
else
-- Don't need to set any value if this interface shares
- -- the primary dispatch table
+ -- the primary dispatch table.
if not Is_Parent (Iface, Typ) then
Append_To (Stmts_List,
Build_Set_Static_Offset_To_Top (Loc,
- Iface_Tag =>
- New_Reference_To (Iface_Tag, Loc),
+ Iface_Tag => New_Reference_To (Iface_Tag, Loc),
Offset_Value =>
Unchecked_Convert_To (RTE (RE_Storage_Offset),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name =>
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name =>
New_Reference_To (Tag_Comp, Loc)),
Attribute_Name => Name_Position))));
end if;
@@ -6772,14 +6783,12 @@ package body Exp_Ch3 is
(RTE (RE_Register_Interface_Offset), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Copy_Tree (Target),
+ Prefix => New_Copy_Tree (Target),
Attribute_Name => Name_Address),
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
- (Node (First_Elmt
- (Access_Disp_Table (Iface))),
- Loc)),
+ (Node (First_Elmt (Access_Disp_Table (Iface))), Loc)),
New_Occurrence_Of (Standard_True, Loc),
@@ -6788,7 +6797,7 @@ package body Exp_Ch3 is
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
+ Prefix => New_Copy_Tree (Target),
Selector_Name =>
New_Reference_To (Tag_Comp, Loc)),
Attribute_Name => Name_Position)),
@@ -6841,7 +6850,7 @@ package body Exp_Ch3 is
Tag_Comp => Tag_Comp,
Iface_Tag => Node (Iface_Tag_Elmt));
- -- Otherwise we generate code to initialize the tag
+ -- Otherwise generate code to initialize the tag
else
-- Check if the parent of the record type has variable size
@@ -7125,7 +7134,7 @@ package body Exp_Ch3 is
-- Make_Eq_Case --
------------------
- -- <Make_Eq_if shared components>
+ -- <Make_Eq_If shared components>
-- case X.D1 is
-- when V1 => <Make_Eq_Case> on subcomponents
-- ...
@@ -7203,7 +7212,7 @@ package body Exp_Ch3 is
-- return False;
-- end if;
- -- or a null statement if the list L is empty
+ -- or a null statement if the list L is empty.
function Make_Eq_If
(E : Entity_Id;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2008-05-21 8:24 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2008-05-21 8:25 [Ada] Null variant discriminant-checking functions needed for front-end layout Arnaud Charlet
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).