[Ada] Wrong expansion of interface thunks for discriminated types
Arnaud Charlet
charlet@adacore.com
Wed Jan 27 12:19:00 GMT 2010
This patch modifies the profile of the interface thunks to avoid
generating code modifies the contents of the object (the thunk must
NOT change the state of the object; it must only displace the pointer
to the object to reference the field containing the pointer to the
secondary dispatch table of the target interface). After this patch
the following test runs without errors:
package Ifaces is
type L0_Iface_1 is Interface;
type L0_Iface_2 is Interface;
function Get_Use_Count (Register : L0_Iface_1) return Natural is abstract;
type L1_Iface_3 is Interface and L0_Iface_1 and L0_Iface_2;
type L2_Iface_4 is Interface and L1_Iface_3;
type Arr is array (Positive range <>) of Natural;
type L0_Register_Type (Unit_Length : Natural) is new L1_Iface_3 with
record
A : Arr (1..3);
Unit : String (1..Unit_Length);
end record;
function Get_Use_Count (Register : L0_Register_Type) return Natural;
type L1_XCP_Register_Type (Device : Natural)
is new L0_Register_Type (1) with null record;
type L2_XCP_Duplex_Register_Type is
new L1_XCP_Register_Type and L2_Iface_4 with null record;
type Register_Object_Ref is access all L2_Iface_4'Class;
procedure Create;
end;
package body Ifaces is
function Get_Use_Count (Register : L0_Register_Type) return Natural is
begin
return 0;
end;
procedure Create is
Ptr : Register_Object_Ref :=
new L2_XCP_Duplex_Register_Type (Device => 0);
N : Natural;
begin
N := Ptr.Get_Use_Count;
end;
end;
with Ifaces; use Ifaces;
procedure Check_Iface_Thunk is
begin
for Index in 1 .. 2029 loop
Create;
end loop;
end;
Command: gnatmake -gnat05 check_iface_thunk.adb; ./check_iface_thunk
Tested on x86_64-pc-linux-gnu, committed on trunk
2010-01-27 Javier Miranda <miranda@adacore.com>
* exp_disp.ads, exp_disp.adb (Expand_Interface_Thunk): Modify the
profile of interface thunks. The type of the controlling formal is now
the covered interface type (instead of the target tagged type).
-------------- next part --------------
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 156277)
+++ exp_disp.adb (working copy)
@@ -1447,27 +1447,23 @@ package body Exp_Disp is
Actuals : constant List_Id := New_List;
Decl : constant List_Id := New_List;
Formals : constant List_Id := New_List;
+ Target : constant Entity_Id := Ultimate_Alias (Prim);
Controlling_Typ : Entity_Id;
Decl_1 : Node_Id;
Decl_2 : Node_Id;
+ Expr : Node_Id;
Formal : Node_Id;
+ Ftyp : Entity_Id;
+ Iface_Formal : Node_Id;
New_Arg : Node_Id;
Offset_To_Top : Node_Id;
- Target : Entity_Id;
Target_Formal : Entity_Id;
begin
Thunk_Id := Empty;
Thunk_Code := Empty;
- -- Traverse the list of alias to find the final target
-
- Target := Prim;
- while Present (Alias (Target)) loop
- Target := Alias (Target);
- end loop;
-
-- In case of primitives that are functions without formals and
-- a controlling result there is no need to build the thunk.
@@ -1477,10 +1473,38 @@ package body Exp_Disp is
return;
end if;
- -- Duplicate the formals
+ -- Duplicate the formals of the Target primitive. In the thunk, the type
+ -- of the controlling formal is the covered interface type (instead of
+ -- the target tagged type). Done to avoid problems with discriminated
+ -- tagged types because, if the controlling type has discriminants with
+ -- default values, then the type conversions done inside the body of the
+ -- thunk (after the displacement of the pointer to the base of the
+ -- actual object) generate code that modify its contents.
+
+ -- Note: This special management is not done for predefined primitives
+ -- because???
+
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Iface_Formal := First_Formal (Interface_Alias (Prim));
+ end if;
Formal := First_Formal (Target);
while Present (Formal) loop
+ Ftyp := Etype (Formal);
+
+ -- Use the interface type as the type of the controlling formal (see
+ -- comment above)
+
+ if not Is_Controlling_Formal (Formal)
+ or else Is_Predefined_Dispatching_Operation (Prim)
+ then
+ Ftyp := Etype (Formal);
+ Expr := New_Copy_Tree (Expression (Parent (Formal)));
+ else
+ Ftyp := Etype (Iface_Formal);
+ Expr := Empty;
+ end if;
+
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
@@ -1488,9 +1512,12 @@ package body Exp_Disp is
Chars => Chars (Formal)),
In_Present => In_Present (Parent (Formal)),
Out_Present => Out_Present (Parent (Formal)),
- Parameter_Type =>
- New_Reference_To (Etype (Formal), Loc),
- Expression => New_Copy_Tree (Expression (Parent (Formal)))));
+ Parameter_Type => New_Reference_To (Ftyp, Loc),
+ Expression => Expr));
+
+ if not Is_Predefined_Dispatching_Operation (Prim) then
+ Next_Formal (Iface_Formal);
+ end if;
Next_Formal (Formal);
end loop;
@@ -1500,10 +1527,24 @@ package body Exp_Disp is
Target_Formal := First_Formal (Target);
Formal := First (Formals);
while Present (Formal) loop
+
+ -- Handle concurrent types
+
+ if Ekind (Target_Formal) = E_In_Parameter
+ and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
+ then
+ Ftyp := Directly_Designated_Type (Etype (Target_Formal));
+ else
+ Ftyp := Etype (Target_Formal);
+ end if;
+
+ if Is_Concurrent_Type (Ftyp) then
+ Ftyp := Corresponding_Record_Type (Ftyp);
+ end if;
+
if Ekind (Target_Formal) = E_In_Parameter
and then Ekind (Etype (Target_Formal)) = E_Anonymous_Access_Type
- and then Directly_Designated_Type (Etype (Target_Formal))
- = Controlling_Typ
+ and then Ftyp = Controlling_Typ
then
-- Generate:
@@ -1522,9 +1563,7 @@ package body Exp_Disp is
Null_Exclusion_Present => False,
Constant_Present => False,
Subtype_Indication =>
- New_Reference_To
- (Directly_Designated_Type
- (Etype (Target_Formal)), Loc)));
+ New_Reference_To (Ftyp, Loc)));
New_Arg :=
Unchecked_Convert_To (RTE (RE_Address),
@@ -1568,7 +1607,7 @@ package body Exp_Disp is
(Defining_Identifier (Decl_2),
New_Reference_To (Defining_Identifier (Decl_1), Loc)));
- elsif Etype (Target_Formal) = Controlling_Typ then
+ elsif Ftyp = Controlling_Typ then
-- Generate:
-- S1 : Storage_Offset := Storage_Offset!(Formal'Address)
@@ -1630,8 +1669,7 @@ package body Exp_Disp is
-- Target_Formal (S2.all)
Append_To (Actuals,
- Unchecked_Convert_To
- (Etype (Target_Formal),
+ Unchecked_Convert_To (Ftyp,
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Decl_2), Loc))));
More information about the Gcc-patches
mailing list