exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Do not add cleanup…

exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Do not add cleanup actions in thunks associated with interface types.

2013-04-11  Javier Miranda  <miranda@adacore.com>

	* exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Do
	not add cleanup actions in thunks associated with interface types.
	* exp_ch3.ad[sb] (Is_Variable_Size_Record): Move declaration to
	the package spec.
	* exp_ch4.adb (Tagged_Conversion): Update call to
	Expand_Interface_Conversion since the parameter Is_Static is no
	longer needed.
	* exp_ch6.adb (Expand_N_Extended_Return_Statement): Adding
	assertion to ensure that interface thunks are never handled by
	this routine.
	(Expand_N_Simple_Function_Return): Do not rewrite this statement
	as an extended return statement in interface thunks, and do not
	perform copy in the secondary stack if the return statement is
	located in a thunk.
	* exp_disp.adb (Expand_Dispatching_Call): No longer displace
	the pointer to the returned object in functions returning interface
	types.
	(Expand_Interface_Thunk): For functions returning interface types
	displace the pointer to the returned object.
	(Expand_Interface_Conversion): Remove formal
	Is_Static since this subprogram can now evaluate it locally.
	* sem_ch3.adb (Add_Internal_Interface_Entities): For functions
	propagate the type returned by the covered interface primitive to
	the internal interface entity. Needed by the thunk to generate
	the code which displaces "this" to reference the corresponding
	secondary dispatch table.
	* sem_disp.adb (Propagate_Tag): Update call to
	Expand_Interface_Conversion since the parameter Is_Static is no
	longer needed.
	* sem_res.adb (Resolve_Type_Conversion): Update calls to
	Expand_Interface_Conversion since the parameter Is_Static is no
	longer needed plus code cleanup.

From-SVN: r197786

gcc/ada/ChangeLog

+2013-04-11  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch11.adb (Expand_N_Handled_Sequence_Of_Statements): Do
+	not add cleanup actions in thunks associated with interface types.
+	* exp_ch3.ad[sb] (Is_Variable_Size_Record): Move declaration to
+	the package spec.
+	* exp_ch4.adb (Tagged_Conversion): Update call to
+	Expand_Interface_Conversion since the parameter Is_Static is no
+	longer needed.
+	* exp_ch6.adb (Expand_N_Extended_Return_Statement): Adding
+	assertion to ensure that interface thunks are never handled by
+	this routine.
+	(Expand_N_Simple_Function_Return): Do not rewrite this statement
+	as an extended return statement in interface thunks, and do not
+	perform copy in the secondary stack if the return statement is
+	located in a thunk.
+	* exp_disp.adb (Expand_Dispatching_Call): No longer displace
+	the pointer to the returned object in functions returning interface
+	types.
+	(Expand_Interface_Thunk): For functions returning interface types
+	displace the pointer to the returned object.
+	(Expand_Interface_Conversion): Remove formal
+	Is_Static since this subprogram can now evaluate it locally.
+	* sem_ch3.adb (Add_Internal_Interface_Entities): For functions
+	propagate the type returned by the covered interface primitive to
+	the internal interface entity. Needed by the thunk to generate
+	the code which displaces "this" to reference the corresponding
+	secondary dispatch table.
+	* sem_disp.adb (Propagate_Tag): Update call to
+	Expand_Interface_Conversion since the parameter Is_Static is no
+	longer needed.
+	* sem_res.adb (Resolve_Type_Conversion): Update calls to
+	Expand_Interface_Conversion since the parameter Is_Static is no
+	longer needed plus code cleanup.
+
 2013-04-11  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* init.c (RETURN_ADDR_OFFSET): Delete as unused.

gcc/ada/exp_ch11.adb

@@ -1402,10 +1402,16 @@ package body Exp_Ch11 is
 
       --  Add clean up actions if required
 
-      if Nkind (Parent (N)) /= N_Package_Body
-        and then Nkind (Parent (N)) /= N_Accept_Statement
-        and then Nkind (Parent (N)) /= N_Extended_Return_Statement
+      if not Nkind_In (Parent (N), N_Package_Body,
+                                   N_Accept_Statement,
+                                   N_Extended_Return_Statement)
         and then not Delay_Cleanups (Current_Scope)
+
+        --  No cleanup action needed in thunks associated with interfaces
+        --  because they only displace the pointer to the object.
+
+        and then not (Is_Subprogram (Current_Scope)
+                       and then Is_Thunk (Current_Scope))
       then
          Expand_Cleanup_Actions (Parent (N));
       else

gcc/ada/exp_ch3.adb

@@ -232,9 +232,6 @@ package body Exp_Ch3 is
    function Is_Variable_Size_Array (E : Entity_Id) return Boolean;
    --  Returns true if E has variable size components
 
-   function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
-   --  Returns true if E has variable size components
-
    function Make_Eq_Body
      (Typ     : Entity_Id;
       Eq_Name : Name_Id) return Node_Id;

gcc/ada/exp_ch3.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -104,6 +104,9 @@ package Exp_Ch3 is
    --  then tags components located at variable positions of Target are
    --  initialized.
 
+   function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
+   --  Returns true if E has variable size components (move to sem_util???)
+
    function Needs_Simple_Initialization
      (T           : Entity_Id;
       Consider_IS : Boolean := True) return Boolean;

gcc/ada/exp_ch4.adb

@@ -10376,7 +10376,7 @@ package body Exp_Ch4 is
             --  Ada 2005 (AI-251): Handle interface type conversion
 
             if Is_Interface (Actual_Op_Typ) then
-               Expand_Interface_Conversion (N, Is_Static => False);
+               Expand_Interface_Conversion (N);
                goto Done;
             end if;
 

gcc/ada/exp_ch6.adb

@@ -5489,6 +5489,13 @@ package body Exp_Ch6 is
    --  Start of processing for Expand_N_Extended_Return_Statement
 
    begin
+      --  Given that functionality of interface thunks is simple (just displace
+      --  the pointer to the object) they are always handled by means of
+      --  simple return statements.
+
+      pragma Assert (not Is_Subprogram (Current_Scope)
+                      or else not Is_Thunk (Current_Scope));
+
       if Nkind (Ret_Obj_Decl) = N_Object_Declaration then
          Exp := Expression (Ret_Obj_Decl);
       else
@@ -7132,18 +7139,27 @@ package body Exp_Ch6 is
         and then Is_Immutably_Limited_Type (Etype (Expression (N)))
         and then Ada_Version >= Ada_2005
         and then not Debug_Flag_Dot_L
+
+         --  The functionality of interface thunks is simple and it is always
+         --  handled by means of simple return statements. This leaves their
+         --  expansion simple and clean.
+
+        and then not (Is_Subprogram (Current_Scope)
+                       and then Is_Thunk (Current_Scope))
       then
          declare
             Return_Object_Entity : constant Entity_Id :=
                                      Make_Temporary (Loc, 'R', Exp);
+
             Obj_Decl : constant Node_Id :=
                          Make_Object_Declaration (Loc,
                            Defining_Identifier => Return_Object_Entity,
                            Object_Definition   => Subtype_Ind,
                            Expression          => Exp);
 
-            Ext : constant Node_Id := Make_Extended_Return_Statement (Loc,
-                    Return_Object_Declarations => New_List (Obj_Decl));
+            Ext : constant Node_Id :=
+                    Make_Extended_Return_Statement (Loc,
+                      Return_Object_Declarations => New_List (Obj_Decl));
             --  Do not perform this high-level optimization if the result type
             --  is an interface because the "this" pointer must be displaced.
 
@@ -7205,6 +7221,16 @@ package body Exp_Ch6 is
       then
          null;
 
+      --  No copy needed for thunks returning interface type objects since
+      --  the object is returned by reference and the maximum functionality
+      --  required is just to displace the pointer.
+
+      elsif Is_Subprogram (Current_Scope)
+        and then Is_Thunk (Current_Scope)
+        and then Is_Interface (Exptyp)
+      then
+         null;
+
       elsif not Requires_Transient_Scope (R_Type) then
 
          --  Mutable records with no variable length components are not

gcc/ada/exp_disp.adb

@@ -30,6 +30,7 @@ with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Atag; use Exp_Atag;
+with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_CG;   use Exp_CG;
 with Exp_Dbug; use Exp_Dbug;
@@ -1072,89 +1073,93 @@ package body Exp_Disp is
       --  to avoid the generation of spurious warnings under ZFP run-time.
 
       Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
-
-      --  For functions returning interface types add implicit conversion to
-      --  force the displacement of the pointer to the object to reference
-      --  the corresponding secondary dispatch table. This is needed to
-      --  handle well nested calls through secondary dispatch tables
-      --  (for example Obj.Prim1.Prim2).
-
-      if Is_Interface (Res_Typ) then
-         Rewrite (Call_Node,
-           Make_Type_Conversion (Loc,
-             Subtype_Mark => New_Occurrence_Of (Res_Typ, Loc),
-             Expression => Relocate_Node (Call_Node)));
-         Set_Etype (Call_Node, Res_Typ);
-         Expand_Interface_Conversion (Call_Node, Is_Static => False);
-         Force_Evaluation (Call_Node);
-
-         pragma Assert (Nkind (Call_Node) = N_Explicit_Dereference
-           and then Nkind (Prefix (Call_Node)) = N_Identifier
-           and then Nkind (Parent (Entity (Prefix (Call_Node))))
-                             = N_Object_Declaration);
-         Set_Assignment_OK (Parent (Entity (Prefix (Call_Node))));
-
-         if Nkind (Parent (Call_Node)) = N_Object_Declaration then
-            Set_Assignment_OK (Parent (Call_Node));
-         end if;
-      end if;
    end Expand_Dispatching_Call;
 
    ---------------------------------
    -- Expand_Interface_Conversion --
    ---------------------------------
 
-   procedure Expand_Interface_Conversion
-     (N         : Node_Id;
-      Is_Static : Boolean := True)
-   is
-      Loc         : constant Source_Ptr := Sloc (N);
-      Etyp        : constant Entity_Id  := Etype (N);
-      Operand     : constant Node_Id    := Expression (N);
-      Operand_Typ : Entity_Id           := Etype (Operand);
-      Func        : Node_Id;
-      Iface_Typ   : Entity_Id           := Etype (N);
-      Iface_Tag   : Entity_Id;
+   procedure Expand_Interface_Conversion (N : Node_Id) is
+      function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id;
+      --  Return the underlying record type of Typ.
 
-   begin
-      --  Ada 2005 (AI-345): Handle synchronized interface type derivations
+      ----------------------------
+      -- Underlying_Record_Type --
+      ----------------------------
 
-      if Is_Concurrent_Type (Operand_Typ) then
-         Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
-      end if;
+      function Underlying_Record_Type (Typ : Entity_Id) return Entity_Id is
+         E : Entity_Id := Typ;
 
-      --  Handle access to class-wide interface types
+      begin
+         --  Handle access to class-wide interface types
 
-      if Is_Access_Type (Iface_Typ) then
-         Iface_Typ := Etype (Directly_Designated_Type (Iface_Typ));
-      end if;
+         if Is_Access_Type (E) then
+            E := Etype (Directly_Designated_Type (E));
+         end if;
 
-      --  Handle class-wide interface types. This conversion can appear
-      --  explicitly in the source code. Example: I'Class (Obj)
+         --  Handle class-wide types. This conversion can appear explicitly in
+         --  the source code. Example: I'Class (Obj)
 
-      if Is_Class_Wide_Type (Iface_Typ) then
-         Iface_Typ := Root_Type (Iface_Typ);
-      end if;
+         if Is_Class_Wide_Type (E) then
+            E := Root_Type (E);
+         end if;
 
-      --  If the target type is a tagged synchronized type, the dispatch table
-      --  info is in the corresponding record type.
+         --  If the target type is a tagged synchronized type, the dispatch
+         --  table info is in the corresponding record type.
 
-      if Is_Concurrent_Type (Iface_Typ) then
-         Iface_Typ := Corresponding_Record_Type (Iface_Typ);
-      end if;
+         if Is_Concurrent_Type (E) then
+            E := Corresponding_Record_Type (E);
+         end if;
 
-      --  Handle private types
+         --  Handle private types
+
+         E := Underlying_Type (E);
+
+         --  Handle subtypes
 
-      Iface_Typ := Underlying_Type (Iface_Typ);
+         return Base_Type (E);
+      end Underlying_Record_Type;
 
+      --  Local variables
+
+      Loc         : constant Source_Ptr := Sloc (N);
+      Etyp        : constant Entity_Id  := Etype (N);
+      Operand     : constant Node_Id    := Expression (N);
+      Operand_Typ : Entity_Id           := Etype (Operand);
+      Func        : Node_Id;
+      Iface_Typ   : constant Entity_Id  := Underlying_Record_Type (Etype (N));
+      Iface_Tag   : Entity_Id;
+      Is_Static   : Boolean;
+
+   --  Start of processing for Expand_Interface_Conversion
+
+   begin
       --  Freeze the entity associated with the target interface to have
       --  available the attribute Access_Disp_Table.
 
       Freeze_Before (N, Iface_Typ);
 
-      pragma Assert (not Is_Static
-        or else (not Is_Class_Wide_Type (Iface_Typ)
-                  and then Is_Interface (Iface_Typ)));
+      --  Ada 2005 (AI-345): Handle synchronized interface type derivations
+
+      if Is_Concurrent_Type (Operand_Typ) then
+         Operand_Typ := Base_Type (Corresponding_Record_Type (Operand_Typ));
+      end if;
+
+      --  Evaluate if we can statically displace the pointer to the object
+
+      declare
+         Opnd_Typ : constant Node_Id := Underlying_Record_Type (Operand_Typ);
+
+      begin
+         Is_Static :=
+            not Is_Interface (Opnd_Typ)
+              and then Interface_Present_In_Ancestor
+                         (Typ   => Opnd_Typ,
+                          Iface => Iface_Typ)
+              and then (Etype (Opnd_Typ) = Opnd_Typ
+                         or else not
+                           Is_Variable_Size_Record (Etype (Opnd_Typ)));
+      end;
 
       if not Tagged_Type_Expansion then
          if VM_Target /= No_VM then
@@ -1166,16 +1171,14 @@ package body Exp_Disp is
                Operand_Typ := Root_Type (Operand_Typ);
             end if;
 
-            if not Is_Static
-              and then Operand_Typ /= Iface_Typ
-            then
+            if not Is_Static and then Operand_Typ /= Iface_Typ then
                Insert_Action (N,
                  Make_Procedure_Call_Statement (Loc,
                    Name => New_Occurrence_Of
                             (RTE (RE_Check_Interface_Conversion), Loc),
                    Parameter_Associations => New_List (
                      Make_Attribute_Reference (Loc,
-                       Prefix => Duplicate_Subexpr (Expression (N)),
+                       Prefix         => Duplicate_Subexpr (Expression (N)),
                        Attribute_Name => Name_Tag),
                      Make_Attribute_Reference (Loc,
                        Prefix         => New_Reference_To (Iface_Typ, Loc),
@@ -1904,22 +1907,69 @@ package body Exp_Disp is
       --  Function case
 
       else pragma Assert (Ekind (Target) = E_Function);
-         Thunk_Code :=
-           Make_Subprogram_Body (Loc,
-              Specification =>
-                Make_Function_Specification (Loc,
-                  Defining_Unit_Name       => Thunk_Id,
-                  Parameter_Specifications => Formals,
-                  Result_Definition =>
-                    New_Copy (Result_Definition (Parent (Target)))),
-              Declarations => Decl,
-              Handled_Statement_Sequence =>
-                Make_Handled_Sequence_Of_Statements (Loc,
-                  Statements => New_List (
-                    Make_Simple_Return_Statement (Loc,
-                      Make_Function_Call (Loc,
-                        Name => New_Occurrence_Of (Target, Loc),
-                        Parameter_Associations => Actuals)))));
+         declare
+            Result_Def : Node_Id;
+            Call_Node  : Node_Id;
+
+         begin
+            Call_Node :=
+              Make_Function_Call (Loc,
+                Name                   => New_Occurrence_Of (Target, Loc),
+                Parameter_Associations => Actuals);
+
+            if not Is_Interface (Etype (Prim)) then
+               Result_Def := New_Copy (Result_Definition (Parent (Target)));
+
+            --  Thunk of function returning a class-wide interface object. No
+            --  extra displacement needed since the displacement is generated
+            --  in the return statement of Prim. Example:
+
+            --    type Iface is interface ...
+            --    function F (O : Iface) return Iface'Class;
+
+            --    type T is new ... and Iface with ...
+            --    function F (O : T) return Iface'Class;
+
+            elsif Is_Class_Wide_Type (Etype (Prim)) then
+               Result_Def := New_Occurrence_Of (Etype (Prim), Loc);
+
+            --  Thunk of function returning an interface object. Displacement
+            --  needed. Example:
+
+            --    type Iface is interface ...
+            --    function F (O : Iface) return Iface;
+
+            --    type T is new ... and Iface with ...
+            --    function F (O : T) return T;
+
+            else
+               Result_Def :=
+                 New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc);
+
+               --  Adding implicit conversion to force the displacement of
+               --  the pointer to the object to reference the corresponding
+               --  secondary dispatch table.
+
+               Call_Node :=
+                 Make_Type_Conversion (Loc,
+                   Subtype_Mark =>
+                     New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc),
+                   Expression   => Relocate_Node (Call_Node));
+            end if;
+
+            Thunk_Code :=
+              Make_Subprogram_Body (Loc,
+                Specification =>
+                  Make_Function_Specification (Loc,
+                    Defining_Unit_Name       => Thunk_Id,
+                    Parameter_Specifications => Formals,
+                    Result_Definition        => Result_Def),
+                Declarations => Decl,
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc,
+                    Statements => New_List (
+                      Make_Simple_Return_Statement (Loc, Call_Node))));
+         end;
       end if;
    end Expand_Interface_Thunk;
 

gcc/ada/exp_disp.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -222,12 +222,10 @@ package Exp_Disp is
    --  Ada 2005 (AI-251): Displace all the actuals corresponding to class-wide
    --  interfaces to reference the interface tag of the actual object
 
-   procedure Expand_Interface_Conversion
-     (N         : Node_Id;
-      Is_Static : Boolean := True);
-   --  Ada 2005 (AI-251): N is a type-conversion node. Reference the base of
-   --  the object to give access to the interface tag associated with the
-   --  secondary dispatch table.
+   procedure Expand_Interface_Conversion (N : Node_Id);
+   --  Ada 2005 (AI-251): N is a type-conversion node. Displace the pointer
+   --  to the object to give access to the interface tag associated with the
+   --  dispatch table of the target type.
 
    procedure Expand_Interface_Thunk
      (Prim       : Node_Id;

gcc/ada/sem_ch3.adb

@@ -1661,6 +1661,15 @@ package body Sem_Ch3 is
                  (New_Subp, Is_Abstract_Subprogram (Prim));
                Set_Interface_Alias (New_Subp, Iface_Prim);
 
+               --  If the returned type is an interface then propagate it to
+               --  the returned type. Needed by the thunk to generate the code
+               --  which displaces "this" to reference the corresponding
+               --  secondary dispatch table in the returned object.
+
+               if Is_Interface (Etype (Iface_Prim)) then
+                  Set_Etype (New_Subp, Etype (Iface_Prim));
+               end if;
+
                --  Internal entities associated with interface types are
                --  only registered in the list of primitives of the tagged
                --  type. They are only used to fill the contents of the

gcc/ada/sem_disp.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -2445,7 +2445,7 @@ package body Sem_Disp is
                Set_Etype (Call_Node, Etype (Control));
                Set_Analyzed (Call_Node);
 
-               Expand_Interface_Conversion (Call_Node, Is_Static => False);
+               Expand_Interface_Conversion (Call_Node);
             end if;
          end;
 

gcc/ada/sem_res.adb

@@ -9757,7 +9757,7 @@ package body Sem_Res is
                      N);
 
                else
-                  Expand_Interface_Conversion (N, Is_Static => False);
+                  Expand_Interface_Conversion (N);
                end if;
 
             --  Conversion to interface type
@@ -9770,29 +9770,18 @@ package body Sem_Res is
                   Opnd := Etype (Opnd);
                end if;
 
-               if not Interface_Present_In_Ancestor
-                        (Typ   => Opnd,
-                         Iface => Target)
+               if Is_Class_Wide_Type (Opnd)
+                 or else Interface_Present_In_Ancestor
+                           (Typ   => Opnd,
+                            Iface => Target)
                then
-                  if Is_Class_Wide_Type (Opnd) then
-
-                     --  The static analysis is not enough to know if the
-                     --  interface is implemented or not. Hence we must pass
-                     --  the work to the expander to generate code to evaluate
-                     --  the conversion at run time.
-
-                     Expand_Interface_Conversion (N, Is_Static => False);
-
-                  else
-                     Error_Msg_Name_1 := Chars (Etype (Target));
-                     Error_Msg_Name_2 := Chars (Opnd);
-                     Error_Msg_N
-                       ("wrong interface conversion (% is not a progenitor "
-                        & "of %)", N);
-                  end if;
-
-               else
                   Expand_Interface_Conversion (N);
+               else
+                  Error_Msg_Name_1 := Chars (Etype (Target));
+                  Error_Msg_Name_2 := Chars (Opnd);
+                  Error_Msg_N
+                    ("wrong interface conversion (% is not a progenitor "
+                     & "of %)", N);
                end if;
             end if;
          end;