From 20dc266e5a178fd87bb8ae6ebbf63e391f74e9b0 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Fri, 13 Dec 2019 09:04:18 +0000 Subject: [Ada] Deallocation of controlled type implementing interface types 2019-12-13 Javier Miranda gcc/ada/ * 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. From-SVN: r279351 --- gcc/ada/ChangeLog | 21 +++++++++++++++++++++ gcc/ada/exp_ch6.adb | 3 ++- gcc/ada/exp_disp.adb | 39 ++++++++++++++++++++++++++++++++++----- gcc/ada/exp_disp.ads | 3 ++- gcc/ada/exp_intr.adb | 28 +++++++++++++++++++++++++--- gcc/ada/gcc-interface/trans.c | 7 ++++--- 6 files changed, 88 insertions(+), 13 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 475a389..b4ed0d5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2019-12-13 Javier Miranda + + * 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 * exp_attr.adb (Is_Available): Remove this function, and replace diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3d6ef48..c03cd7c 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7607,7 +7607,8 @@ package body Exp_Ch6 is 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 ( diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 84caa92..4663a08 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1850,7 +1850,8 @@ package body Exp_Disp is 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; @@ -1912,12 +1913,38 @@ package body Exp_Disp is -- 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, @@ -4073,7 +4100,8 @@ package body Exp_Disp is 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); @@ -4379,7 +4407,8 @@ package body Exp_Disp is 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 := @@ -7507,7 +7536,7 @@ package body Exp_Disp is 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) diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 7295942..5c490df 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -242,7 +242,8 @@ package Exp_Disp is 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 diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index c28982c..78555bf 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -988,9 +988,31 @@ package body Exp_Intr is -- 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 diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 3d6f381..ef16a08 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -11287,11 +11287,12 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk) 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) -- cgit v1.1