+2019-12-13 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.ads (Expand_Interface_Thunk): Adding one formal (the
+ interface type).
+ * exp_disp.adb (Expand_Interface_Thunk): Using the added formal
+ to ensure the correct profile of the thunk generated for
+ predefined primitives; in addition, the added formal is also
+ used to perform a check that ensures that the controlling type
+ of the thunk is the one expected by the GCC backend.
+ (Make_Secondary_DT, Register_Primitive): Adding the new formal
+ to the calls to Expand_Interface_Thunk.
+ * exp_ch6.adb (Register_Predefined_DT_Entry): Adding the new
+ formal to the call to Expand_Interface_Thunk.
+ * exp_intr.adb (Expand_Unc_Deallocation): When deallocating a
+ controlled type and the call to unchecked deallocation is
+ performed with a pointer to one of the convered interface types,
+ displace the pointer to the object to reference the base of the
+ object to deallocate its memory.
+ * gcc-interface/trans.c (maybe_make_gnu_thunk): Assert that the
+ controlling type of the thunk is an interface type.
+
2019-12-13 Bob Duff <duff@adacore.com>
* exp_attr.adb (Is_Available): Remove this function, and replace
and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
loop
pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
- Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code,
+ Iface => Related_Type (Node (Iface_DT_Ptr)));
if Present (Thunk_Code) then
Insert_Actions_After (N, New_List (
procedure Expand_Interface_Thunk
(Prim : Node_Id;
Thunk_Id : out Entity_Id;
- Thunk_Code : out Node_Id)
+ Thunk_Code : out Node_Id;
+ Iface : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Prim);
Actuals : constant List_Id := New_List;
-- Use the interface type as the type of the controlling formal (see
-- comment above).
- if not Is_Controlling_Formal (Formal) or else Is_Predef_Op then
+ if not Is_Controlling_Formal (Formal) then
Ftyp := Etype (Formal);
Expr := New_Copy_Tree (Expression (Parent (Formal)));
+
+ -- For predefined primitives the controlling type of the thunk is
+ -- the interface type passed by the caller (since they don't have
+ -- available the Interface_Alias attribute; see comment above).
+
+ elsif Is_Predef_Op then
+ Ftyp := Iface;
+ Expr := Empty;
+
else
Ftyp := Etype (Iface_Formal);
Expr := Empty;
+
+ -- Sanity check performed to ensure the proper controlling type
+ -- when the thunk has exactly one controlling parameter and it
+ -- comes first. In such case the GCC backend reuses the C++
+ -- thunks machinery which perform a computation equivalent to
+ -- the code generated by the expander; for other cases the GCC
+ -- backend translates the expanded code unmodified. However, as
+ -- a generalization, the check is performed for all controlling
+ -- types.
+
+ if Is_Access_Type (Ftyp) then
+ pragma Assert (Base_Type (Designated_Type (Ftyp)) = Iface);
+ null;
+ else
+ Ftyp := Base_Type (Ftyp);
+ pragma Assert (Ftyp = Iface);
+ end if;
end if;
Append_To (Formals,
Alias (Prim);
else
- Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+ Expand_Interface_Thunk
+ (Prim, Thunk_Id, Thunk_Code, Iface);
if Present (Thunk_Id) then
Append_To (Result, Thunk_Code);
Prim_Table (Prim_Pos) := Alias (Prim);
else
- Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+ Expand_Interface_Thunk
+ (Prim, Thunk_Id, Thunk_Code, Iface);
if Present (Thunk_Id) then
Prim_Pos :=
return L;
end if;
- Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
+ Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, Iface_Typ);
if not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
and then Present (Thunk_Code)
procedure Expand_Interface_Thunk
(Prim : Node_Id;
Thunk_Id : out Entity_Id;
- Thunk_Code : out Node_Id);
+ Thunk_Code : out Node_Id;
+ Iface : Entity_Id);
-- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
-- generate additional subprograms (thunks) associated with each primitive
-- Prim to have a layout compatible with the C++ ABI. The thunk displaces
-- are allowed, the generated code may lack block statements.
if Needs_Fin then
- Obj_Ref :=
- Make_Explicit_Dereference (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (Arg));
+
+ -- Ada 2005 (AI-251): In case of abstract interface type we displace
+ -- the pointer to reference the base of the object to deallocate its
+ -- memory, unless we're targetting a VM, in which case no special
+ -- processing is required.
+
+ if Is_Interface (Directly_Designated_Type (Typ))
+ and then Tagged_Type_Expansion
+ then
+ Obj_Ref :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_Address),
+ Duplicate_Subexpr_No_Checks (Arg))))));
+
+ else
+ Obj_Ref :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => Duplicate_Subexpr_No_Checks (Arg));
+ end if;
-- If the designated type is tagged, the finalization call must
-- dispatch because the designated type may not be the actual type
const Entity_Id gnat_controlling_type = get_controlling_type (gnat_target);
const Entity_Id gnat_interface_type = get_controlling_type (gnat_thunk);
+ /* We must have an interface type at this point. */
+ gcc_assert (Is_Interface (gnat_interface_type));
+
/* Now compute whether the former covers the latter. */
const Entity_Id gnat_interface_tag
- = Is_Interface (gnat_interface_type)
- ? Find_Interface_Tag (gnat_controlling_type, gnat_interface_type)
- : Empty;
+ = Find_Interface_Tag (gnat_controlling_type, gnat_interface_type);
tree gnu_interface_tag
= Present (gnat_interface_tag)
? gnat_to_gnu_field_decl (gnat_interface_tag)
projects / gcc.git / commitdiff