[Ada] Deallocation of controlled type implementing interface types

2019-12-13  Javier Miranda  <miranda@adacore.com>

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

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  <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
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)