[Ada] Get rid of secondary stack for most calls returning tagged types

This eliminates the use of the secondary stack to return specific tagged
types from functions in calls that are not dispatching on result, which
comprises returning controlled types, by introducing thunks whose only
purpose is to move the result from the primary to the secondary stack
for primitive functions that are controlling on result, and referencing
them in the dispatch table in lieu of the primitive functions.

The implementation reuses the existing machinery of interface thunks and
thus creates another kind of thunks, secondary stack thunks, which only
perform a call to the primitive function and return the result.

gcc/ada/

	* einfo.ads (Has_Controlling_Result): Document new usage.
	(Is_Thunk): Document secondary stack thunks.
	(Returns_By_Ref): Adjust.
	* exp_ch6.adb (Caller_Known_Size): Return true for tagged types.
	(Expand_N_Extended_Return_Statement): Do not call Set_By_Ref.
	(Expand_Simple_Function_Return): For a BIP return with an Alloc_Form
	parameter, mark the node as returning on the secondary stack.
	Replace call to Is_Limited_Interface with Is_Limited_View.  Deal wit
	secondary stack thunks.  Do not call Set_By_Ref.  Optimize the case
	of a call to a function whose type also needs finalization.
	(Needs_BIP_Task_Actuals): Replace Thunk_Entity with Thunk_Target.
	(Needs_BIP_Finalization_Master): Cosmetic fixes.
	(Needs_BIP_Alloc_Form): Check No_Secondary_Stack restriction and
	return true for tagged types.
	* exp_ch7.adb (Transient Scope Management): Update description.
	* exp_disp.adb (Expand_Dispatching_Call): Always set Returns_By_Ref
	on designated type if the call is dispatching on result.  Tidy up.
	(Expand_Interface_Thunk): Change type of Thunk_Code from Node_Id to
	List_Id.  Change type of local variables from Node_Id to Entity_Id.
	Propagate Aliased_Present flag to create the formals and explicitly
	set Has_Controlling_Result to False.  Build a secondary stack thunk
	if necessary in the function case.
	(Expand_Secondary_Stack_Thunk): New function.
	(Make_Secondary_DT): Build secondary stack thunks if necessary.
	(Make_DT): Likewise.
	(Register_Predefined_Primitive): Likewise.
	(Register_Primitive): Likewise.
	* exp_util.ads (Is_Secondary_Stack_Thunk): Declare.
	(Thunk_Target): Likewise.
	* exp_util.adb (Is_Secondary_Stack_Thunk): New function.
	(Thunk_Target): Likewise.
	* fe.h (Is_Secondary_Stack_Thunk): Declare.
	(Thunk_Target): Likewise.
	* gen_il-fields.ads (Opt_Field_Enum): Remove By_Ref.
	* gen_il-gen-gen_nodes.adb (N_Simple_Return_Statement): Likewise.
	(N_Extended_Return_Statement): Likewise.
	* sem_ch6.adb (Analyze_Subprogram_Specification): Skip check for
	abstract return type in the thunk case.
	(Create_Extra_Formals): Replace Thunk_Entity with Thunk_Target.
	* sem_disp.adb (Check_Controlling_Formals): Skip in the thunk case.
	* sem_util.adb: Add use and with clauses for Exp_Ch6.
	(Compute_Returns_By_Ref): Do not process procedures and only set
	the flag for direct return by reference.
	(Needs_Secondary_Stack): Do not return true for specific tagged
	types and adjust comments accordingly.
	* sinfo.ads (By_Ref): Delete.
	(N_Simple_Return_Statement): Remove By_Ref.
	(N_Extended_Return_Statement): Likewise.
	* gcc-interface/ada-tree.h (TYPE_RETURN_UNCONSTRAINED_P): Delete.
	* gcc-interface/decl.cc (gnat_to_gnu_subprog_type): Do not use it.
	Return by direct reference if the return type needs the secondary
	stack as well as for secondary stack thunks.
	* gcc-interface/gigi.h (fntype_same_flags_p): Remove parameter.
	* gcc-interface/misc.cc (gnat_type_hash_eq): Adjust to above change.
	* gcc-interface/trans.cc (finalize_nrv): Replace test on
	TYPE_RETURN_UNCONSTRAINED_P with TYPE_RETURN_BY_DIRECT_REF_P.
	(Subprogram_Body_to_gnu): Do not call maybe_make_gnu_thunk for
	secondary stack thunks.
	(Call_to_gnu): Do not test TYPE_RETURN_UNCONSTRAINED_P.
	(gnat_to_gnu) <N_Simple_Return_Statement>: In the return by direct
	reference case, test for the presence of Storage_Pool on the node
	to build an allocator.
	(maybe_make_gnu_thunk): Deal with Thunk_Entity and Thunk_Target.
	* gcc-interface/utils.cc (fntype_same_flags_p): Remove parameter.

19 files changed, 558 insertions, 299 deletions

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 6182724d707..c5843f2903f 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1576,7 +1576,8 @@ package Einfo is
 
 --    Has_Controlling_Result
 --       Defined in E_Function entities. Set if the function is a primitive
---       function of a tagged type which can dispatch on result.
+--       function of a tagged type which can dispatch on result. Also set on
+--       secondary stack thunks built for such a primitive function.
 
 --    Has_Convention_Pragma
 --       Defined in all entities. Set for an entity for which a valid pragma
@@ -3322,17 +3323,29 @@ package Einfo is
 --       Applies to all entities. True for task types and subtypes
 
 --    Is_Thunk
---       Defined in all entities. True for subprograms that are thunks: that is
---       small subprograms built by the expander for tagged types that cover
---       interface types. As part of the runtime call to an interface, thunks
+--       Defined in all entities. True for subprograms that are thunks, that is
+--       small subprograms built by the expander for particular tagged types.
+--       There are two different kinds of thunk: interface thunk and secondary
+--       stack thunk. Interface thunks are built for tagged types that cover
+--       interface types. As part of the runtime call to an interface, they
 --       displace the pointer to the object (pointer named "this" in the C++
 --       terminology) from a secondary dispatch table to the primary dispatch
 --       table associated with a given tagged type; if the thunk is a function
 --       that returns an object which covers an interface type then the thunk
 --       displaces the pointer to the object from the primary dispatch table to
---       the secondary dispatch table associated with the interface type. Set
---       by Expand_Interface_Thunk and used by Expand_Call to handle extra
---       actuals associated with accessibility level.
+--       the secondary dispatch table associated with the interface type.
+
+--       Secondary stack thunks are built for tagged types that do not need to
+--       be returned on the secondary stack but have primitive functions which
+--       can dispatch on result. In this case, dispatching calls made to these
+--       primitive functions nevertheless need to return on the secondary stack
+--       and a thunk is built to move the result from the primary stack onto
+--       the secondary stack on return from the primitive function. The flag
+--       Has_Controlling_Result is set on secondary stack thunks but not on
+--       interface thunks.
+
+--       Thunks may be chained in a single way: an interface thunk may point to
+--       a secondary stack thunk, which points to the final thunk target.
 
 --    Is_Trivial_Subprogram
 --       Defined in all entities. Set in subprograms where either the body
@@ -4241,8 +4254,7 @@ package Einfo is
 --    Returns_By_Ref
 --       Defined in subprogram type entities and functions. Set if a function
 --       (or an access-to-function type) returns a result by reference, either
---       because its return type is a by-reference-type or because the function
---       explicitly uses the secondary stack.
+--       because the result is built in place, or its type is by-reference.
 
 --    Reverse_Bit_Order [base type only]
 --       Defined in all record type entities. Set if entity has a Bit_Order
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 3fcf51a18bb..15a20392457 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -164,7 +164,7 @@ package body Exp_Ch6 is
    function Caller_Known_Size
      (Func_Call   : Node_Id;
       Result_Subt : Entity_Id) return Boolean;
-   --  True if result subtype is definite, or has a size that does not require
+   --  True if result subtype is definite or has a size that does not require
    --  secondary stack usage (i.e. no variant part or components whose type
    --  depends on discriminants). In particular, untagged types with only
    --  access discriminants do not require secondary stack use. Note we must
@@ -1055,12 +1055,12 @@ package body Exp_Ch6 is
      (Func_Call   : Node_Id;
       Result_Subt : Entity_Id) return Boolean
    is
-      Ctrl : constant Node_Id   := Controlling_Argument (Func_Call);
       Utyp : constant Entity_Id := Underlying_Type (Result_Subt);
 
    begin
-      return (No (Ctrl) and then Is_Definite_Subtype (Utyp))
-        or else not Needs_Secondary_Stack (Utyp);
+      return not Needs_Secondary_Stack (Utyp)
+        and then not (Is_Tagged_Type (Utyp)
+                       and then Present (Controlling_Argument (Func_Call)));
    end Caller_Known_Size;
 
    -----------------------
@@ -5549,10 +5549,6 @@ package body Exp_Ch6 is
                     Present (Unqual_BIP_Iface_Function_Call
                               (Expression (Original_Node (Ret_Obj_Decl))))));
 
-            --  Return the build-in-place result by reference
-
-            Set_By_Ref (Return_Stmt);
-
          elsif Is_BIP_Func then
 
             --  Locate the implicit access parameter associated with the
@@ -5586,10 +5582,6 @@ package body Exp_Ch6 is
                Obj_Alloc_Formal : Entity_Id;
 
             begin
-               --  Build-in-place results must be returned by reference
-
-               Set_By_Ref (Return_Stmt);
-
                --  Retrieve the implicit access parameter passed by the caller
 
                Obj_Acc_Formal :=
@@ -7316,13 +7308,18 @@ package body Exp_Ch6 is
 
       --  Deal with returning variable length objects and controlled types
 
-      --  Nothing to do if we are returning by reference, or this is not a
-      --  type that requires special processing (indicated by the fact that
-      --  it requires a cleanup scope for the secondary stack case).
+      --  Nothing to do if we are returning by reference
 
-      if Is_Build_In_Place_Function (Scope_Id)
-        or else Is_Limited_Interface (Exp_Typ)
-      then
+      if Is_Build_In_Place_Function (Scope_Id) then
+         --  Prevent the reclamation of the secondary stack by all enclosing
+         --  blocks and loops as well as the related function; otherwise the
+         --  result would be reclaimed too early.
+
+         if Needs_BIP_Alloc_Form (Scope_Id) then
+            Set_Enclosing_Sec_Stack_Return (N);
+         end if;
+
+      elsif Is_Limited_View (R_Type) then
          null;
 
       --  No copy needed for thunks returning interface type objects since
@@ -7333,7 +7330,7 @@ package body Exp_Ch6 is
          null;
 
       --  If the call is within a thunk and the type is a limited view, the
-      --  backend will eventually see the non-limited view of the type.
+      --  back end will eventually see the non-limited view of the type.
 
       elsif Is_Thunk (Scope_Id) and then Is_Incomplete_Type (Exp_Typ) then
          return;
@@ -7341,7 +7338,8 @@ package body Exp_Ch6 is
       --  A return statement from an ignored Ghost function does not use the
       --  secondary stack (or any other one).
 
-      elsif not Needs_Secondary_Stack (R_Type)
+      elsif (not Needs_Secondary_Stack (R_Type)
+              and then not Is_Secondary_Stack_Thunk (Scope_Id))
         or else Is_Ignored_Ghost_Entity (Scope_Id)
       then
          --  Mutable records with variable-length components are not returned
@@ -7380,8 +7378,9 @@ package body Exp_Ch6 is
          --    return Rnn.all;
 
          --  but optimize the case where the result is a function call that
-         --  also needs finalization. In this case the result is already on
-         --  the return stack and no further processing is required.
+         --  also needs finalization. In this case the result can directly be
+         --  allocated on the the return stack of the caller and no further
+         --  processing is required.
 
          if Present (Utyp)
            and then Needs_Finalization (Utyp)
@@ -7448,17 +7447,11 @@ package body Exp_Ch6 is
 
          --  Optimize the case where the result is a function call that also
          --  returns on the secondary stack. In this case the result is already
-         --  on the secondary stack and no further processing is required
-         --  except to set the By_Ref flag to ensure that gigi does not attempt
-         --  an extra unnecessary copy. (Actually not just unnecessary but
-         --  wrong in the case of a controlled type, where gigi does not know
-         --  how to do a copy.)
+         --  on the secondary stack and no further processing is required.
 
          if Exp_Is_Function_Call
            and then Needs_Secondary_Stack (Exp_Typ)
          then
-            Set_By_Ref (N);
-
             --  Remove side effects from the expression now so that other parts
             --  of the expander do not have to reanalyze this node without this
             --  optimization
@@ -7488,7 +7481,15 @@ package body Exp_Ch6 is
          --  controlled (by the virtue of restriction No_Finalization) because
          --  gigi is not able to properly allocate class-wide types.
 
-         elsif CW_Or_Needs_Finalization (Utyp) then
+         --  But optimize the case where the result is a function call that
+         --  also needs finalization. In this case the result can directly be
+         --  allocated on the secondary stack and no further processing is
+         --  required.
+
+         elsif CW_Or_Needs_Finalization (Utyp)
+           and then not (Exp_Is_Function_Call
+                          and then Needs_Finalization (Exp_Typ))
+         then
             declare
                Loc        : constant Source_Ptr := Sloc (N);
                Acc_Typ    : constant Entity_Id := Make_Temporary (Loc, 'A');
@@ -10047,7 +10048,7 @@ package body Exp_Ch6 is
       --  formals.
 
       if Is_Thunk (Func_Id) then
-         Subp_Id := Thunk_Entity (Func_Id);
+         Subp_Id := Thunk_Target (Func_Id);
 
       --  Common case
 
@@ -10091,26 +10092,25 @@ package body Exp_Ch6 is
    -- Needs_BIP_Finalization_Master --
    -----------------------------------
 
-   function Needs_BIP_Finalization_Master
-     (Func_Id : Entity_Id) return Boolean
+   function Needs_BIP_Finalization_Master (Func_Id : Entity_Id) return Boolean
    is
-      pragma Assert (Is_Build_In_Place_Function (Func_Id));
-      Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+      Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+
    begin
+      pragma Assert (Is_Build_In_Place_Function (Func_Id));
+
       --  A formal giving the finalization master is needed for build-in-place
       --  functions whose result type needs finalization or is a tagged type.
       --  Tagged primitive build-in-place functions need such a formal because
       --  they can be called by a dispatching call, and extensions may require
-      --  finalization even if the root type doesn't. This means they're also
-      --  needed for tagged nonprimitive build-in-place functions with tagged
-      --  results, since such functions can be called via access-to-function
-      --  types, and those can be used to call primitives, so masters have to
-      --  be passed to all such build-in-place functions, primitive or not.
-
-      return
-        not Restriction_Active (No_Finalization)
-          and then (Needs_Finalization (Func_Typ)
-                     or else Is_Tagged_Type (Func_Typ));
+      --  finalization even if the root type doesn't. This means nonprimitive
+      --  build-in-place functions with tagged results also need it, since such
+      --  functions can be called via access-to-function types, and those can
+      --  be used to call primitives, so the formal needs to be passed to all
+      --  such build-in-place functions, primitive or not.
+
+      return not Restriction_Active (No_Finalization)
+        and then (Needs_Finalization (Typ) or else Is_Tagged_Type (Typ));
    end Needs_BIP_Finalization_Master;
 
    --------------------------
@@ -10118,10 +10118,23 @@ package body Exp_Ch6 is
    --------------------------
 
    function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is
-      pragma Assert (Is_Build_In_Place_Function (Func_Id));
-      Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+      Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
+
    begin
-      return Needs_Secondary_Stack (Func_Typ);
+      pragma Assert (Is_Build_In_Place_Function (Func_Id));
+
+      --  A formal giving the allocation method is needed for build-in-place
+      --  functions whose result type is returned on the secondary stack or
+      --  is a tagged type. Tagged primitive build-in-place functions need
+      --  such a formal because they can be called by a dispatching call, and
+      --  the secondary stack is always used for dispatching-on-result calls.
+      --  This means nonprimitive build-in-place functions with tagged results
+      --  also need it, as such functions can be called via access-to-function
+      --  types, and those can be used to call primitives, so the formal needs
+      --  to be passed to all such build-in-place functions, primitive or not.
+
+      return not Restriction_Active (No_Secondary_Stack)
+        and then (Needs_Secondary_Stack (Typ) or else Is_Tagged_Type (Typ));
    end Needs_BIP_Alloc_Form;
 
    -------------------------------------
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 206f46aa8e1..b6fc62d2b80 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -76,15 +76,15 @@ package body Exp_Ch7 is
    -- Transient Scope Management --
    --------------------------------
 
-   --  A transient scope is created when temporary objects are created by the
-   --  compiler. These temporary objects are allocated on the secondary stack
-   --  and the transient scope is responsible for finalizing the object when
-   --  appropriate and reclaiming the memory at the right time. The temporary
-   --  objects are generally the objects allocated to store the result of a
-   --  function returning an unconstrained or a tagged value. Expressions
-   --  needing to be wrapped in a transient scope (functions calls returning
-   --  unconstrained or tagged values) may appear in 3 different contexts which
-   --  lead to 3 different kinds of transient scope expansion:
+   --  A transient scope is needed when certain temporary objects are created
+   --  by the compiler. These temporary objects are allocated on the secondary
+   --  stack and/or need finalization, and the transient scope is responsible
+   --  for finalizing the objects and reclaiming the memory of the secondary
+   --  stack at the appropriate time. They are generally objects allocated to
+   --  store the result of a function returning an unconstrained or controlled
+   --  value. Expressions needing to be wrapped in a transient scope may appear
+   --  in three different contexts which lead to different kinds of transient
+   --  scope expansion:
 
    --   1. In a simple statement (procedure call, assignment, ...). In this
    --      case the instruction is wrapped into a transient block. See
@@ -99,29 +99,6 @@ package body Exp_Ch7 is
    --      declaration and the secondary stack deallocation is done in the
    --      proper enclosing scope. See Wrap_Transient_Declaration for details.
 
-   --  Note about functions returning tagged types: it has been decided to
-   --  always allocate their result in the secondary stack, even though is not
-   --  absolutely mandatory when the tagged type is constrained because the
-   --  caller knows the size of the returned object and thus could allocate the
-   --  result in the primary stack. An exception to this is when the function
-   --  builds its result in place, as is done for functions with inherently
-   --  limited result types for Ada 2005. In that case, certain callers may
-   --  pass the address of a constrained object as the target object for the
-   --  function result.
-
-   --  By always allocating tagged results in the secondary stack, a couple of
-   --  implementation difficulties are avoided:
-
-   --    - If this is a dispatching function call, the computation of the size
-   --      of the result is possible but complex from the outside.
-
-   --    - If the result type is class-wide, it is unconstrained anyway.
-
-   --  Furthermore, the small loss in efficiency which is the result of this
-   --  decision is not such a big deal because functions returning tagged types
-   --  are not as common in practice compared to functions returning access to
-   --  a tagged type.
-
    --------------------------------------------------
    -- Transient Blocks and Finalization Management --
    --------------------------------------------------
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 7f6bb819030..ddb0cedc048 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -83,7 +83,7 @@ package body Exp_Disp is
    procedure Expand_Interface_Thunk
      (Prim       : Entity_Id;
       Thunk_Id   : out Entity_Id;
-      Thunk_Code : out Node_Id;
+      Thunk_Code : out List_Id;
       Iface      : Entity_Id);
    --  Ada 2005 (AI-251): When a tagged type implements abstract interfaces we
    --  generate additional subprograms (thunks) associated with each primitive
@@ -94,6 +94,21 @@ package body Exp_Disp is
    --  is set to the defining identifier of the thunk and Thunk_Code to the
    --  code generated for the thunk respectively.
 
+   procedure Expand_Secondary_Stack_Thunk
+     (Prim       : Entity_Id;
+      Thunk_Id   : out Entity_Id;
+      Thunk_Code : out Node_Id);
+   --  When a primitive function of a tagged type can dispatch on result and
+   --  the tagged type is not returned on the secondary stack, we generate an
+   --  additional function (thunk) that calls the primitive function with the
+   --  same actuals and move its result onto the secondary stack. This thunk
+   --  is intended to be put into the slot of the primitive function in the
+   --  dispatch table, so as to be invoked in lieu of the primitive function
+   --  in dispatching calls. If there is no need to generate the thunk, then
+   --  Thunk_Id is set to Empty. Otherwise Thunk_Id is set to the defining
+   --  identifier of the thunk and Thunk_Code to the code generated for the
+   --  thunk respectively.
+
    function Has_DT (Typ : Entity_Id) return Boolean;
    pragma Inline (Has_DT);
    --  Returns true if we generate a dispatch table for tagged type Typ
@@ -727,7 +742,6 @@ package body Exp_Disp is
       New_Call_Name   : Node_Id;
       New_Params      : List_Id := No_List;
       Param           : Node_Id;
-      Res_Typ         : Entity_Id;
       Subp_Ptr_Typ    : Entity_Id;
       Subp_Typ        : Entity_Id;
       Typ             : Entity_Id;
@@ -875,21 +889,20 @@ package body Exp_Disp is
          end loop;
       end if;
 
-      --  Generate the appropriate subprogram pointer type
+      --  Generate the appropriate subprogram designated type
+
+      Subp_Typ := Create_Itype (E_Subprogram_Type, Call_Node);
+      Copy_Strub_Mode (Subp_Typ, Subp);
+      Set_Convention  (Subp_Typ, Convention (Subp));
 
       if Etype (Subp) = Typ then
-         Res_Typ := CW_Typ;
+         Set_Etype          (Subp_Typ, CW_Typ);
+         Set_Returns_By_Ref (Subp_Typ, True);
       else
-         Res_Typ := Etype (Subp);
+         Set_Etype          (Subp_Typ, Etype (Subp));
+         Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
       end if;
 
-      Subp_Typ     := Create_Itype (E_Subprogram_Type, Call_Node);
-      Copy_Strub_Mode (Subp_Typ, Subp);
-      Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
-      Set_Etype          (Subp_Typ, Res_Typ);
-      Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
-      Set_Convention     (Subp_Typ, Convention (Subp));
-
       --  Notify gigi that the designated type is a dispatching primitive
 
       Set_Is_Dispatch_Table_Entity (Subp_Typ);
@@ -986,14 +999,13 @@ package body Exp_Disp is
          end if;
       end;
 
-      --  Complete description of pointer type, including size information, as
-      --  must be done with itypes to prevent order-of-elaboration anomalies
-      --  in gigi.
+      --  Generate the appropriate subprogram pointer type and decorate it
 
-      Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ);
+      Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
+      Set_Etype                    (Subp_Ptr_Typ, Subp_Ptr_Typ);
       Set_Directly_Designated_Type (Subp_Ptr_Typ, Subp_Typ);
-      Set_Convention (Subp_Ptr_Typ, Convention (Subp_Typ));
-      Layout_Type    (Subp_Ptr_Typ);
+      Set_Convention               (Subp_Ptr_Typ, Convention (Subp_Typ));
+      Layout_Type                  (Subp_Ptr_Typ);
 
       --  If the controlling argument is a value of type Ada.Tag or an abstract
       --  interface class-wide type then use it directly. Otherwise, the tag
@@ -1770,7 +1782,7 @@ package body Exp_Disp is
    procedure Expand_Interface_Thunk
      (Prim       : Entity_Id;
       Thunk_Id   : out Entity_Id;
-      Thunk_Code : out Node_Id;
+      Thunk_Code : out List_Id;
       Iface      : Entity_Id)
    is
       Actuals      : constant List_Id    := New_List;
@@ -1785,16 +1797,16 @@ package body Exp_Disp is
       Decl_1        : Node_Id;
       Decl_2        : Node_Id;
       Expr          : Node_Id;
-      Formal        : Node_Id;
+      Formal        : Entity_Id;
       Ftyp          : Entity_Id;
-      Iface_Formal  : Node_Id;
+      Iface_Formal  : Entity_Id;
       New_Arg       : Node_Id;
       Offset_To_Top : Node_Id;
       Target_Formal : Entity_Id;
 
    begin
       Thunk_Id   := Empty;
-      Thunk_Code := Empty;
+      Thunk_Code := Empty_List;
 
       --  No thunk needed if the primitive has been eliminated
 
@@ -1873,6 +1885,7 @@ package body Exp_Disp is
              Defining_Identifier =>
                Make_Defining_Identifier (Sloc (Formal),
                  Chars => Chars (Formal)),
+             Aliased_Present => Aliased_Present (Parent (Formal)),
              In_Present => In_Present (Parent (Formal)),
              Out_Present => Out_Present (Parent (Formal)),
              Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
@@ -2062,14 +2075,17 @@ package body Exp_Disp is
 
       Mutate_Ekind (Thunk_Id, Ekind (Prim));
       Set_Is_Thunk (Thunk_Id);
+      Set_Has_Controlling_Result (Thunk_Id, False);
       Set_Convention (Thunk_Id, Convention (Prim));
       Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Target));
       Set_Thunk_Entity (Thunk_Id, Target);
 
+      Thunk_Code := New_List;
+
       --  Procedure case
 
       if Ekind (Target) = E_Procedure then
-         Thunk_Code :=
+         Append_To (Thunk_Code,
            Make_Subprogram_Body (Loc,
               Specification =>
                 Make_Procedure_Specification (Loc,
@@ -2081,14 +2097,16 @@ package body Exp_Disp is
                   Statements => New_List (
                     Make_Procedure_Call_Statement (Loc,
                       Name => New_Occurrence_Of (Target, Loc),
-                      Parameter_Associations => Actuals))));
+                      Parameter_Associations => Actuals)))));
 
       --  Function case
 
       else pragma Assert (Ekind (Target) = E_Function);
          declare
-            Result_Def : Node_Id;
-            Call_Node  : Node_Id;
+            Call_Node     : Node_Id;
+            Result_Def    : Node_Id;
+            SS_Thunk_Id   : Entity_Id;
+            SS_Thunk_Code : Node_Id;
 
          begin
             Call_Node :=
@@ -2122,6 +2140,19 @@ package body Exp_Disp is
             --    function F (O : T) return T;
 
             else
+               Expand_Secondary_Stack_Thunk
+                 (Target, SS_Thunk_Id, SS_Thunk_Code);
+
+               if Present (SS_Thunk_Id) then
+                  Set_Thunk_Entity (Thunk_Id, SS_Thunk_Id);
+                  Call_Node :=
+                    Make_Function_Call (Loc,
+                      Name                   =>
+                        New_Occurrence_Of (SS_Thunk_Id, Loc),
+                      Parameter_Associations => Actuals);
+                  Append_To (Thunk_Code, SS_Thunk_Code);
+               end if;
+
                Result_Def :=
                  New_Occurrence_Of (Class_Wide_Type (Etype (Prim)), Loc);
 
@@ -2136,7 +2167,7 @@ package body Exp_Disp is
                    Expression   => Relocate_Node (Call_Node));
             end if;
 
-            Thunk_Code :=
+            Append_To (Thunk_Code,
               Make_Subprogram_Body (Loc,
                 Specification              =>
                   Make_Function_Specification (Loc,
@@ -2147,11 +2178,135 @@ package body Exp_Disp is
                 Handled_Statement_Sequence =>
                   Make_Handled_Sequence_Of_Statements (Loc,
                     Statements => New_List (
-                      Make_Simple_Return_Statement (Loc, Call_Node))));
+                      Make_Simple_Return_Statement (Loc, Call_Node)))));
          end;
       end if;
    end Expand_Interface_Thunk;
 
+   ------------------------------------
+   --  Expand_Secondary_Stack_Thunk  --
+   ------------------------------------
+
+   procedure Expand_Secondary_Stack_Thunk
+     (Prim       : Entity_Id;
+      Thunk_Id   : out Entity_Id;
+      Thunk_Code : out Node_Id)
+   is
+      Actuals      : constant List_Id    := New_List;
+      Formals      : constant List_Id    := New_List;
+      Loc          : constant Source_Ptr := Sloc (Prim);
+      Typ          : constant Entity_Id  := Etype (Prim);
+
+      Call_Node   : Node_Id;
+      Expr        : Node_Id;
+      Formal      : Entity_Id;
+      Prim_Formal : Entity_Id;
+      Result_Def  : Node_Id;
+
+   begin
+      Thunk_Id   := Empty;
+      Thunk_Code := Empty;
+
+      --  No thunk needed if the primitive has been eliminated
+
+      if Is_Eliminated (Prim) then
+         return;
+
+      --  No thunk needed for procedures or functions not dispatching on result
+
+      elsif Ekind (Prim) = E_Procedure
+        or else not Has_Controlling_Result (Prim)
+      then
+         return;
+
+      --  No thunk needed if the result type is an access type
+
+      elsif Is_Access_Type (Typ) then
+         return;
+
+      --  No thunk needed if the tagged type is returned in place
+
+      elsif Is_Build_In_Place_Result_Type (Typ) then
+         return;
+
+      --  No thunk needed if the tagged type is returned on the secondary stack
+
+      elsif Needs_Secondary_Stack (Typ) then
+         return;
+      end if;
+
+      pragma Assert (Is_Tagged_Type (Typ));
+
+      --  Duplicate the formals of the target primitive and build the actuals
+
+      Prim_Formal := First_Formal (Prim);
+      while Present (Prim_Formal) loop
+         Expr := New_Copy_Tree (Expression (Parent (Prim_Formal)));
+
+         Formal :=
+           Make_Defining_Identifier (Sloc (Prim_Formal),
+             Chars => Chars (Prim_Formal));
+
+         Append_To (Formals,
+           Make_Parameter_Specification (Loc,
+             Defining_Identifier => Formal,
+             Aliased_Present => Aliased_Present (Parent (Prim_Formal)),
+             In_Present => In_Present (Parent (Prim_Formal)),
+             Out_Present => Out_Present (Parent (Prim_Formal)),
+             Parameter_Type => New_Occurrence_Of (Etype (Prim_Formal), Loc),
+             Expression => Expr));
+
+         --  Ensure proper matching of access types. Required to avoid
+         --  reporting spurious errors.
+
+         if Is_Access_Type (Etype (Prim_Formal)) then
+            Append_To (Actuals,
+              Unchecked_Convert_To (Base_Type (Etype (Prim_Formal)),
+                New_Occurrence_Of (Formal, Loc)));
+
+         --  No special management required for this actual
+
+         else
+            Append_To (Actuals, New_Occurrence_Of (Formal, Loc));
+         end if;
+
+         Next_Formal (Prim_Formal);
+      end loop;
+
+      Thunk_Id := Make_Temporary (Loc, 'T');
+
+      --  Note: any change to this symbol name needs to be coordinated
+      --  with GNATcoverage, as that tool relies on it to identify
+      --  thunks and exclude them from source coverage analysis.
+
+      Mutate_Ekind (Thunk_Id, E_Function);
+      Set_Is_Thunk (Thunk_Id);
+      Set_Has_Controlling_Result (Thunk_Id, True);
+      Set_Convention (Thunk_Id, Convention (Prim));
+      Set_Needs_Debug_Info (Thunk_Id, Needs_Debug_Info (Prim));
+      Set_Thunk_Entity (Thunk_Id, Prim);
+
+      Result_Def := New_Copy (Result_Definition (Parent (Prim)));
+
+      Call_Node :=
+        Make_Function_Call (Loc,
+          Name                   => New_Occurrence_Of (Prim, Loc),
+          Parameter_Associations => Actuals);
+
+      Thunk_Code :=
+        Make_Subprogram_Body (Loc,
+          Specification              =>
+            Make_Function_Specification (Loc,
+              Defining_Unit_Name       => Thunk_Id,
+              Parameter_Specifications => Formals,
+              Result_Definition        => Result_Def),
+          Declarations               => Empty_List,
+          Handled_Statement_Sequence =>
+            Make_Handled_Sequence_Of_Statements (Loc,
+              Statements => New_List (
+                Make_Simple_Return_Statement (Loc, Call_Node))));
+   end Expand_Secondary_Stack_Thunk;
+
    --------------------------
    -- Has_CPP_Constructors --
    --------------------------
@@ -3868,11 +4023,14 @@ package body Exp_Disp is
          --  save their entity to fill the aggregate.
 
          declare
-            Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ);
-            Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id;
-            Decl       : Node_Id;
-            Thunk_Id   : Entity_Id;
-            Thunk_Code : Node_Id;
+            Nb_P_Prims    : constant Nat := Number_Of_Predefined_Prims (Typ);
+            Prim_Table    : array (Nat range 1 .. Nb_P_Prims) of Entity_Id;
+            Decl          : Node_Id;
+            E             : Entity_Id;
+            SS_Thunk_Id   : Entity_Id;
+            SS_Thunk_Code : Node_Id;
+            Thunk_Id      : Entity_Id;
+            Thunk_Code    : List_Id;
 
          begin
             Prim_Ops_Aggr_List := New_List;
@@ -3887,19 +4045,27 @@ package body Exp_Disp is
                     and then not Is_Abstract_Subprogram (Prim)
                     and then not Is_Eliminated (Prim)
                     and then not Generate_SCIL
-                    and then not Present (Prim_Table
-                                           (UI_To_Int (DT_Position (Prim))))
+                    and then not
+                      Present (Prim_Table (UI_To_Int (DT_Position (Prim))))
                   then
                      if not Build_Thunks then
-                        Prim_Table (UI_To_Int (DT_Position (Prim))) :=
-                          Alias (Prim);
+                        E := Ultimate_Alias (Prim);
+                        Expand_Secondary_Stack_Thunk
+                          (E, SS_Thunk_Id, SS_Thunk_Code);
+
+                        if Present (SS_Thunk_Id) then
+                           E := SS_Thunk_Id;
+                           Append_To (Result, SS_Thunk_Code);
+                        end if;
+
+                        Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
 
                      else
                         Expand_Interface_Thunk
                           (Prim, Thunk_Id, Thunk_Code, Iface);
 
                         if Present (Thunk_Id) then
-                           Append_To (Result, Thunk_Code);
+                           Append_List_To (Result, Thunk_Code);
                            Prim_Table (UI_To_Int (DT_Position (Prim))) :=
                              Thunk_Id;
                         end if;
@@ -4042,17 +4208,20 @@ package body Exp_Disp is
             OSD_Aggr_List := New_List;
 
             declare
-               Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
-               Prim       : Entity_Id;
-               Prim_Alias : Entity_Id;
-               Prim_Elmt  : Elmt_Id;
-               E          : Entity_Id;
-               Count      : Nat := 0;
-               Pos        : Nat;
+               Prim_Table    : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+               Prim          : Entity_Id;
+               Prim_Alias    : Entity_Id;
+               Prim_Elmt     : Elmt_Id;
+               E             : Entity_Id;
+               Count         : Nat;
+               Pos           : Nat;
+               SS_Thunk_Id   : Entity_Id;
+               SS_Thunk_Code : Node_Id;
 
             begin
                Prim_Table := (others => Empty);
                Prim_Alias := Empty;
+               Count      := 0;
 
                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
                while Present (Prim_Elmt) loop
@@ -4066,11 +4235,15 @@ package body Exp_Disp is
                      E   := Ultimate_Alias (Prim);
                      Pos := UI_To_Int (DT_Position (Prim_Alias));
 
-                     if Present (Prim_Table (Pos)) then
-                        pragma Assert (Prim_Table (Pos) = E);
-                        null;
+                     if No (Prim_Table (Pos)) then
+                        Expand_Secondary_Stack_Thunk
+                          (E, SS_Thunk_Id, SS_Thunk_Code);
+
+                        if Present (SS_Thunk_Id) then
+                           E := SS_Thunk_Id;
+                           Append_To (Result, SS_Thunk_Code);
+                        end if;
 
-                     else
                         Prim_Table (Pos) := E;
 
                         Append_To (OSD_Aggr_List,
@@ -4158,12 +4331,14 @@ package body Exp_Disp is
 
          else
             declare
-               CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
-               E            : Entity_Id;
-               Prim_Pos     : Nat;
-               Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
-               Thunk_Code   : Node_Id;
-               Thunk_Id     : Entity_Id;
+               CPP_Nb_Prims  : constant Nat := CPP_Num_Prims (Typ);
+               E             : Entity_Id;
+               Prim_Pos      : Nat;
+               Prim_Table    : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+               SS_Thunk_Id   : Entity_Id;
+               SS_Thunk_Code : Node_Id;
+               Thunk_Id      : Entity_Id;
+               Thunk_Code    : List_Id;
 
             begin
                Prim_Table := (others => Empty);
@@ -4198,9 +4373,18 @@ package body Exp_Disp is
                                               Use_Full_View => True)
                   then
                      if not Build_Thunks then
+                        E := Alias (Prim);
+                        Expand_Secondary_Stack_Thunk
+                          (E, SS_Thunk_Id, SS_Thunk_Code);
+
+                        if Present (SS_Thunk_Id) then
+                           E := SS_Thunk_Id;
+                           Append_To (Result, SS_Thunk_Code);
+                        end if;
+
                         Prim_Pos :=
                           UI_To_Int (DT_Position (Interface_Alias (Prim)));
-                        Prim_Table (Prim_Pos) := Alias (Prim);
+                        Prim_Table (Prim_Pos) := E;
 
                      else
                         Expand_Interface_Thunk
@@ -4211,7 +4395,7 @@ package body Exp_Disp is
                              UI_To_Int (DT_Position (Interface_Alias (Prim)));
 
                            Prim_Table (Prim_Pos) := Thunk_Id;
-                           Append_To (Result, Thunk_Code);
+                           Append_List_To (Result, Thunk_Code);
                         end if;
                      end if;
                   end if;
@@ -5661,10 +5845,12 @@ package body Exp_Disp is
 
       else
          declare
-            Nb_P_Prims : constant Nat := Number_Of_Predefined_Prims (Typ);
-            Prim_Table : array (Nat range 1 .. Nb_P_Prims) of Entity_Id;
-            Decl       : Node_Id;
-            E          : Entity_Id;
+            Nb_P_Prims    : constant Nat := Number_Of_Predefined_Prims (Typ);
+            Prim_Table    : array (Nat range 1 .. Nb_P_Prims) of Entity_Id;
+            Decl          : Node_Id;
+            E             : Entity_Id;
+            SS_Thunk_Id   : Entity_Id;
+            SS_Thunk_Code : Node_Id;
 
          begin
             Prim_Ops_Aggr_List := New_List;
@@ -5684,6 +5870,15 @@ package body Exp_Disp is
                   then
                      E := Ultimate_Alias (Prim);
                      pragma Assert (not Is_Abstract_Subprogram (E));
+
+                     Expand_Secondary_Stack_Thunk
+                       (E, SS_Thunk_Id, SS_Thunk_Code);
+
+                     if Present (SS_Thunk_Id) then
+                        E := SS_Thunk_Id;
+                        Append_To (Result, SS_Thunk_Code);
+                     end if;
+
                      Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
                   end if;
 
@@ -5794,12 +5989,14 @@ package body Exp_Disp is
 
          else
             declare
-               CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);
-               E            : Entity_Id;
-               Prim         : Entity_Id;
-               Prim_Elmt    : Elmt_Id;
-               Prim_Pos     : Nat;
-               Prim_Table   : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+               CPP_Nb_Prims  : constant Nat := CPP_Num_Prims (Typ);
+               E             : Entity_Id;
+               Prim          : Entity_Id;
+               Prim_Elmt     : Elmt_Id;
+               Prim_Pos      : Nat;
+               Prim_Table    : array (Nat range 1 .. Nb_Prim) of Entity_Id;
+               SS_Thunk_Id   : Entity_Id;
+               SS_Thunk_Code : Node_Id;
 
             begin
                Prim_Table := (others => Empty);
@@ -5856,6 +6053,14 @@ package body Exp_Disp is
                      pragma Assert
                        (UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
 
+                     Expand_Secondary_Stack_Thunk
+                       (E, SS_Thunk_Id, SS_Thunk_Code);
+
+                     if Present (SS_Thunk_Id) then
+                        E := SS_Thunk_Id;
+                        Append_To (Result, SS_Thunk_Code);
+                     end if;
+
                      Prim_Table (UI_To_Int (DT_Position (Prim))) := E;
                   end if;
 
@@ -7153,12 +7358,15 @@ package body Exp_Disp is
      (Loc     : Source_Ptr;
       Prim    : Entity_Id) return List_Id
    is
-      L          : constant List_Id   := New_List;
+      L          : constant List_Id := New_List;
       Tagged_Typ : constant Entity_Id := Find_Dispatching_Type (Prim);
 
+      E             : Entity_Id;
       Iface_DT_Ptr  : Elmt_Id;
+      SS_Thunk_Id   : Entity_Id;
+      SS_Thunk_Code : Node_Id;
       Thunk_Id      : Entity_Id;
-      Thunk_Code    : Node_Id;
+      Thunk_Code    : List_Id;
 
    begin
       if No (Access_Disp_Table (Tagged_Typ))
@@ -7187,7 +7395,15 @@ package body Exp_Disp is
            (Prim, Thunk_Id, Thunk_Code, Related_Type (Node (Iface_DT_Ptr)));
 
          if Present (Thunk_Id) then
-            Append_To (L, Thunk_Code);
+            Append_List_To (L, Thunk_Code);
+
+            E := Prim;
+            Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code);
+
+            if Present (SS_Thunk_Id) then
+               E := SS_Thunk_Id;
+               Append_To (L, SS_Thunk_Code);
+            end if;
 
             Append_To (L,
               Build_Set_Predefined_Prim_Op_Address (Loc,
@@ -7210,7 +7426,7 @@ package body Exp_Disp is
                 Address_Node =>
                   Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                     Make_Attribute_Reference (Loc,
-                      Prefix         => New_Occurrence_Of (Prim, Loc),
+                      Prefix         => New_Occurrence_Of (E, Loc),
                       Attribute_Name => Name_Unrestricted_Access))));
          end if;
 
@@ -7246,15 +7462,18 @@ package body Exp_Disp is
       L : constant List_Id := New_List;
 
       DT_Ptr        : Entity_Id;
+      E             : Entity_Id;
       Iface_Prim    : Entity_Id;
       Iface_Typ     : Entity_Id;
       Iface_DT_Ptr  : Entity_Id;
       Iface_DT_Elmt : Elmt_Id;
       Pos           : Uint;
+      SS_Thunk_Id   : Entity_Id;
+      SS_Thunk_Code : Node_Id;
       Tag           : Entity_Id;
       Tag_Typ       : Entity_Id;
       Thunk_Id      : Entity_Id;
-      Thunk_Code    : Node_Id;
+      Thunk_Code    : List_Id;
 
    begin
       pragma Assert (not Restriction_Active (No_Dispatching_Calls));
@@ -7275,6 +7494,14 @@ package body Exp_Disp is
          Pos     := DT_Position (Prim);
          Tag     := First_Tag_Component (Tag_Typ);
 
+         E := Prim;
+         Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code);
+
+         if Present (SS_Thunk_Id) then
+            E := SS_Thunk_Id;
+            Append_To (L, SS_Thunk_Code);
+         end if;
+
          if Is_Predefined_Dispatching_Operation (Prim)
            or else Is_Predefined_Dispatching_Alias (Prim)
          then
@@ -7288,7 +7515,7 @@ package body Exp_Disp is
                 Address_Node =>
                   Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                     Make_Attribute_Reference (Loc,
-                      Prefix         => New_Occurrence_Of (Prim, Loc),
+                      Prefix         => New_Occurrence_Of (E, Loc),
                       Attribute_Name => Name_Unrestricted_Access))));
 
             --  Register copy of the pointer to the 'size primitive in the TSD
@@ -7321,7 +7548,7 @@ package body Exp_Disp is
                    Address_Node =>
                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
-                         Prefix         => New_Occurrence_Of (Prim, Loc),
+                         Prefix         => New_Occurrence_Of (E, Loc),
                          Attribute_Name => Name_Unrestricted_Access))));
             end if;
          end if;
@@ -7358,8 +7585,8 @@ package body Exp_Disp is
 
          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)
+         if Present (Thunk_Id)
+           and then not Is_Ancestor (Iface_Typ, Tag_Typ, Use_Full_View => True)
          then
             --  Generate the code necessary to fill the appropriate entry of
             --  the secondary dispatch table of Prim's controlling type with
@@ -7373,7 +7600,15 @@ package body Exp_Disp is
             Pos        := DT_Position (Iface_Prim);
             Tag        := First_Tag_Component (Iface_Typ);
 
-            Prepend_To (L, Thunk_Code);
+            Append_List_To (L, Thunk_Code);
+
+            E := Ultimate_Alias (Prim);
+            Expand_Secondary_Stack_Thunk (E, SS_Thunk_Id, SS_Thunk_Code);
+
+            if Present (SS_Thunk_Id) then
+               E := SS_Thunk_Id;
+               Append_To (L, SS_Thunk_Code);
+            end if;
 
             if Is_Predefined_Dispatching_Operation (Prim)
               or else Is_Predefined_Dispatching_Alias (Prim)
@@ -7402,8 +7637,7 @@ package body Exp_Disp is
                    Address_Node =>
                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
-                         Prefix          =>
-                           New_Occurrence_Of (Alias (Prim), Loc),
+                         Prefix          => New_Occurrence_Of (E, Loc),
                          Attribute_Name  => Name_Unrestricted_Access))));
 
             else
@@ -7434,8 +7668,7 @@ package body Exp_Disp is
                    Address_Node =>
                      Unchecked_Convert_To (RTE (RE_Prim_Ptr),
                        Make_Attribute_Reference (Loc,
-                         Prefix         =>
-                           New_Occurrence_Of (Ultimate_Alias (Prim), Loc),
+                         Prefix         => New_Occurrence_Of (E, Loc),
                          Attribute_Name => Name_Unrestricted_Access))));
 
             end if;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 8a8f07c449f..0f193182729 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -9294,6 +9294,17 @@ package body Exp_Util is
       return False;
    end Is_Secondary_Stack_BIP_Func_Call;
 
+   ------------------------------
+   -- Is_Secondary_Stack_Thunk --
+   ------------------------------
+
+   function Is_Secondary_Stack_Thunk (Id : Entity_Id) return Boolean is
+   begin
+      return Ekind (Id) = E_Function
+        and then Is_Thunk (Id)
+        and then Has_Controlling_Result (Id);
+   end Is_Secondary_Stack_Thunk;
+
    -------------------------------------
    -- Is_Tag_To_Class_Wide_Conversion --
    -------------------------------------
@@ -14059,6 +14070,23 @@ package body Exp_Util is
       end if;
    end Small_Integer_Type_For;
 
+   ------------------
+   -- Thunk_Target --
+   ------------------
+
+   function Thunk_Target (Thunk : Entity_Id) return Entity_Id is
+      Target : Entity_Id := Thunk;
+
+   begin
+      pragma Assert (Is_Thunk (Thunk));
+
+      while Is_Thunk (Target) loop
+         Target := Thunk_Entity (Target);
+      end loop;
+
+      return Target;
+   end Thunk_Target;
+
    -------------------
    -- Type_Map_Hash --
    -------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 464f66f7420..e812ca06a7f 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -837,6 +837,11 @@ package Exp_Util is
    --  Determine whether Expr denotes a build-in-place function which returns
    --  its result on the secondary stack.
 
+   function Is_Secondary_Stack_Thunk (Id : Entity_Id) return Boolean;
+   --  Determine whether Id denotes a secondary stack thunk
+
+   --  WARNING: There is a matching C declaration of this subprogram in fe.h
+
    function Is_Tag_To_Class_Wide_Conversion
      (Obj_Id : Entity_Id) return Boolean;
    --  Determine whether object Obj_Id is the result of a tag-to-class-wide
@@ -1190,6 +1195,12 @@ package Exp_Util is
    --  Return the smallest standard integer type containing at least S bits and
    --  of the signedness given by Uns.
 
+   function Thunk_Target (Thunk : Entity_Id) return Entity_Id;
+   --  Return the entity ultimately called by the thunk, that is to say return
+   --  the Thunk_Entity of the last member on the thunk chain.
+
+   --  WARNING: There is a matching C declaration of this subprogram in fe.h
+
    function Type_May_Have_Bit_Aligned_Components
      (Typ : Entity_Id) return Boolean;
    --  Determines if Typ is a composite type that has within it (looking down
@@ -1216,4 +1227,6 @@ private
    pragma Inline (Force_Evaluation);
    pragma Inline (Get_Mapped_Entity);
    pragma Inline (Is_Library_Level_Tagged_Type);
+   pragma Inline (Is_Secondary_Stack_Thunk);
+   pragma Inline (Thunk_Target);
 end Exp_Util;
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index a4ab35ea1f6..983f6c3a441 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -182,13 +182,17 @@ extern Boolean Is_Init_Proc		(Entity_Id);
 
 /* exp_util: */
 
+#define Find_Interface_Tag		exp_util__find_interface_tag
 #define Is_Fully_Repped_Tagged_Type	exp_util__is_fully_repped_tagged_type
 #define Is_Related_To_Func_Return	exp_util__is_related_to_func_return
-#define Find_Interface_Tag		exp_util__find_interface_tag
+#define Is_Secondary_Stack_Thunk	exp_util__is_secondary_stack_thunk
+#define Thunk_Target			exp_util__thunk_target
 
+extern Entity_Id Find_Interface_Tag		(Entity_Id, Entity_Id);
 extern Boolean Is_Fully_Repped_Tagged_Type	(Entity_Id);
 extern Boolean Is_Related_To_Func_Return	(Entity_Id);
-extern Entity_Id Find_Interface_Tag		(Entity_Id, Entity_Id);
+extern Boolean Is_Secondary_Stack_Thunk		(Entity_Id);
+extern Entity_Id Thunk_Target 			(Entity_Id);
 
 /* lib: */
 
diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index ec5202473f2..6d9639d1907 100644
--- a/gcc/ada/gcc-interface/ada-tree.h
+++ b/gcc/ada/gcc-interface/ada-tree.h
@@ -97,11 +97,6 @@ do {							 \
    an Ada array other than the first.  */
 #define TYPE_MULTI_ARRAY_P(NODE) TYPE_LANG_FLAG_1 (ARRAY_TYPE_CHECK (NODE))
 
-/* For FUNCTION_TYPE and METHOD_TYPE, nonzero if function returns an
-   unconstrained array or record type.  */
-#define TYPE_RETURN_UNCONSTRAINED_P(NODE) \
-  TYPE_LANG_FLAG_1 (FUNC_OR_METHOD_CHECK (NODE))
-
 /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this denotes
    a justified modular type (will only be true for RECORD_TYPE).  */
 #define TYPE_JUSTIFIED_MODULAR_P(NODE) \
diff --git a/gcc/ada/gcc-interface/decl.cc b/gcc/ada/gcc-interface/decl.cc
index 318c3bedf4e..bbbb343180d 100644
--- a/gcc/ada/gcc-interface/decl.cc
+++ b/gcc/ada/gcc-interface/decl.cc
@@ -5807,7 +5807,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
   bool pure_flag = Is_Pure (gnat_subprog);
   bool return_by_direct_ref_p = false;
   bool return_by_invisi_ref_p = false;
-  bool return_unconstrained_p = false;
   bool incomplete_profile_p = false;
   int num;
 
@@ -5822,7 +5821,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 	   && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type)))
     {
       gnu_return_type = TREE_TYPE (gnu_type);
-      return_unconstrained_p = TYPE_RETURN_UNCONSTRAINED_P (gnu_type);
       return_by_direct_ref_p = TYPE_RETURN_BY_DIRECT_REF_P (gnu_type);
       return_by_invisi_ref_p = TREE_ADDRESSABLE (gnu_type);
     }
@@ -5838,38 +5836,16 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
       else
 	gnu_return_type = gnat_to_gnu_profile_type (gnat_return_type);
 
-      /* If this function returns by reference, make the actual return type
-	 the reference type and make a note of that.  */
-      if (Returns_By_Ref (gnat_subprog))
+      /* If this function returns by reference or on the secondary stack, make
+	 the actual return type the reference type and make a note of that.  */
+      if (Returns_By_Ref (gnat_subprog)
+	  || Needs_Secondary_Stack (gnat_return_type)
+	  || Is_Secondary_Stack_Thunk (gnat_subprog))
 	{
 	  gnu_return_type = build_reference_type (gnu_return_type);
 	  return_by_direct_ref_p = true;
 	}
 
-      /* If the return type is an unconstrained array type, the return value
-	 will be allocated on the secondary stack so the actual return type
-	 is the fat pointer type.  */
-      else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
-	{
-	  gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
-	  return_unconstrained_p = true;
-	}
-
-      /* This is the same unconstrained array case, but for a dummy type.  */
-      else if (TYPE_REFERENCE_TO (gnu_return_type)
-	       && TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_return_type)))
-	{
-	  gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
-	  return_unconstrained_p = true;
-	}
-
-      /* This is for the other types returned on the secondary stack.  */
-      else if (Needs_Secondary_Stack (gnat_return_type))
-	{
-	  gnu_return_type = build_reference_type (gnu_return_type);
-	  return_unconstrained_p = true;
-	}
-
       /* If the Mechanism is By_Reference, ensure this function uses the
 	 target's by-invisible-reference mechanism, which may not be the
 	 same as above (e.g. it might be passing an extra parameter).  */
@@ -5949,8 +5925,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 	}
 
       if (kind == E_Function)
-	Set_Mechanism (gnat_subprog, return_unconstrained_p
-				     || return_by_direct_ref_p
+	Set_Mechanism (gnat_subprog, return_by_direct_ref_p
 				     || return_by_invisi_ref_p
 				     ? By_Reference : By_Copy);
     }
@@ -5962,7 +5937,7 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
      Similarly, if the function returns an unconstrained type, then the
      function will allocate the return value on the secondary stack and
      thus calls to it cannot be CSE'ed, lest the stack be reclaimed.  */
-  if (VOID_TYPE_P (gnu_return_type) || return_unconstrained_p)
+  if (VOID_TYPE_P (gnu_return_type) || return_by_direct_ref_p)
     pure_flag = false;
 
   /* Loop over the parameters and get their associated GCC tree.  While doing
@@ -6250,7 +6225,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 	gnu_type = make_node (method_p ? METHOD_TYPE : FUNCTION_TYPE);
       TREE_TYPE (gnu_type) = gnu_return_type;
       TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
-      TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
       TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
       TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
     }
@@ -6267,7 +6241,6 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 		= TYPE_MAIN_VARIANT (gnu_basetype);
 	    }
 	  TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
-	  TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
 	  TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
 	  TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
 	  TYPE_CANONICAL (gnu_type) = gnu_type;
@@ -6289,13 +6262,11 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
 	  /* GNU_TYPE may be shared since GCC hashes types.  Unshare it if it
 	     has a different TYPE_CI_CO_LIST or flags.  */
 	  if (!fntype_same_flags_p (gnu_type, gnu_cico_list,
-				    return_unconstrained_p,
 				    return_by_direct_ref_p,
 				    return_by_invisi_ref_p))
 	    {
 	      gnu_type = copy_type (gnu_type);
 	      TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
-	      TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
 	      TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
 	      TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
 	    }
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index bd559d17678..6d70c30305a 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -547,7 +547,7 @@ extern int gnat_types_compatible_p (tree t1, tree t2);
 extern bool gnat_useless_type_conversion (tree expr);
 
 /* Return true if T, a {FUNCTION,METHOD}_TYPE, has the specified flags.  */
-extern bool fntype_same_flags_p (const_tree, tree, bool, bool, bool);
+extern bool fntype_same_flags_p (const_tree, tree, bool, bool);
 
 /* Create an expression whose value is that of EXPR,
    converted to type TYPE.  The TREE_TYPE of the value
diff --git a/gcc/ada/gcc-interface/misc.cc b/gcc/ada/gcc-interface/misc.cc
index 2caa83ff8cf..7824ebf21f9 100644
--- a/gcc/ada/gcc-interface/misc.cc
+++ b/gcc/ada/gcc-interface/misc.cc
@@ -684,7 +684,6 @@ gnat_type_hash_eq (const_tree t1, const_tree t2)
 {
   gcc_assert (FUNC_OR_METHOD_TYPE_P (t1) && TREE_CODE (t1) == TREE_CODE (t2));
   return fntype_same_flags_p (t1, TYPE_CI_CO_LIST (t2),
-			      TYPE_RETURN_UNCONSTRAINED_P (t2),
 			      TYPE_RETURN_BY_DIRECT_REF_P (t2),
 			      TREE_ADDRESSABLE (t2));
 }
diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc
index e80200ee46a..8097a89b5ed 100644
--- a/gcc/ada/gcc-interface/trans.cc
+++ b/gcc/ada/gcc-interface/trans.cc
@@ -3725,7 +3725,7 @@ finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret
   data.result = DECL_RESULT (fndecl);
   data.gnat_ret = gnat_ret;
   data.visited = new hash_set<tree>;
-  if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
+  if (TYPE_RETURN_BY_DIRECT_REF_P (TREE_TYPE (fndecl)))
     func = finalize_nrv_unc_r;
   else
     func = finalize_nrv_r;
@@ -3902,6 +3902,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
 
   /* Try to create a bona-fide thunk and hand it over to the middle-end.  */
   if (Is_Thunk (gnat_subprog)
+      && !Is_Secondary_Stack_Thunk (gnat_subprog)
       && maybe_make_gnu_thunk (gnat_subprog, gnu_subprog))
     return;
 
@@ -5252,10 +5253,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
 	  gnu_result_type = TREE_TYPE (gnu_call);
 	}
 
-      /* If the function returns an unconstrained array or by direct reference,
-	 we have to dereference the pointer.  */
-      if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
-	  || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
+      /* If the function returns by direct reference, we have to dereference
+	 the pointer.  */
+      if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
 	gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
 
       if (gnu_target)
@@ -7439,52 +7439,58 @@ gnat_to_gnu (Node_Id gnat_node)
 	      gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
 
 	    /* If the function returns by direct reference, return a pointer
-	       to the return value.  */
-	    if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
-		|| By_Ref (gnat_node))
-	      gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
-
-	    /* Otherwise, if it returns an unconstrained array, we have to
-	       allocate a new version of the result and return it.  */
-	    else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
+	       to the return value, possibly after allocating it.  */
+	    if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
 	      {
-		gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
-
-		/* And find out whether this is a candidate for Named Return
-		   Value.  If so, record it.  */
-		if (optimize
-		    && !optimize_debug
-		    && !TYPE_CI_CO_LIST (gnu_subprog_type))
+		if (Present (Storage_Pool (gnat_node)))
 		  {
-		    tree ret_val = gnu_ret_val;
-
-		    /* Strip useless conversions around the return value.  */
-		    if (gnat_useless_type_conversion (ret_val))
-		      ret_val = TREE_OPERAND (ret_val, 0);
-
-		    /* Strip unpadding around the return value.  */
-		    if (TREE_CODE (ret_val) == COMPONENT_REF
-			&& TYPE_IS_PADDING_P
-			   (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
-		      ret_val = TREE_OPERAND (ret_val, 0);
-
-		    /* Now apply the test to the return value.  */
-		    if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
+		    gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
+
+		    /* And find out whether it is a candidate for Named Return
+		       Value.  If so, record it.  Note that we disable this NRV
+		       optimization when we're preserving the control flow as
+		       it entails hoisting the allocation done below.  */
+		    if (optimize
+			&& !optimize_debug
+			&& !TYPE_CI_CO_LIST (gnu_subprog_type))
 		      {
-			if (!f_named_ret_val)
-			  f_named_ret_val = BITMAP_GGC_ALLOC ();
-			bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
-			if (!f_gnat_ret)
-			  f_gnat_ret = gnat_node;
+			tree ret_val = gnu_ret_val;
+
+			/* Strip conversions around the return value.  */
+			if (gnat_useless_type_conversion (ret_val))
+			  ret_val = TREE_OPERAND (ret_val, 0);
+
+			/* Strip unpadding around the return value.  */
+			if (TREE_CODE (ret_val) == COMPONENT_REF
+			    && TYPE_IS_PADDING_P
+			      (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
+			  ret_val = TREE_OPERAND (ret_val, 0);
+
+			/* Now apply the test to the return value.  */
+			if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
+			  {
+			    if (!f_named_ret_val)
+			      f_named_ret_val = BITMAP_GGC_ALLOC ();
+			    bitmap_set_bit (f_named_ret_val,
+					    DECL_UID (ret_val));
+			    if (!f_gnat_ret)
+			      f_gnat_ret = gnat_node;
+			  }
 		      }
+
+		    gnu_ret_val
+		      = build_allocator (TREE_TYPE (gnu_ret_val),
+					 gnu_ret_val,
+					 TREE_TYPE (gnu_ret_obj),
+					 Procedure_To_Call (gnat_node),
+					 Storage_Pool (gnat_node),
+					 gnat_node,
+					 false);
 		  }
 
-		gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
-					       gnu_ret_val,
-					       TREE_TYPE (gnu_ret_obj),
-					       Procedure_To_Call (gnat_node),
-					       Storage_Pool (gnat_node),
-					       gnat_node, false);
+		else
+		  gnu_ret_val
+		    = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
 	      }
 
 	    /* Otherwise, if it returns by invisible reference, dereference
@@ -10670,7 +10676,8 @@ make_covariant_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
 static bool
 maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
 {
-  const Entity_Id gnat_target = Thunk_Entity (gnat_thunk);
+  /* We use the Thunk_Target to compute the properties of the thunk.  */
+  const Entity_Id gnat_target = Thunk_Target (gnat_thunk);
 
   /* Check that the first formal of the target is the only controlling one.  */
   Entity_Id gnat_formal = First_Formal (gnat_target);
@@ -10738,7 +10745,9 @@ maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
       indirect_offset = (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
     }
 
-  tree gnu_target = gnat_to_gnu_entity (gnat_target, NULL_TREE, false);
+  /* But we generate a call to the Thunk_Entity in the thunk.  */
+  tree gnu_target
+    = gnat_to_gnu_entity (Thunk_Entity (gnat_thunk), NULL_TREE, false);
 
   /* If the target is local, then thunk and target must have the same context
      because cgraph_node::expand_thunk can only forward the static chain.  */
diff --git a/gcc/ada/gcc-interface/utils.cc b/gcc/ada/gcc-interface/utils.cc
index c583acaf967..3aa810ba21a 100644
--- a/gcc/ada/gcc-interface/utils.cc
+++ b/gcc/ada/gcc-interface/utils.cc
@@ -3841,11 +3841,10 @@ gnat_useless_type_conversion (tree expr)
 /* Return true if T, a {FUNCTION,METHOD}_TYPE, has the specified flags.  */
 
 bool
-fntype_same_flags_p (const_tree t, tree cico_list, bool return_unconstrained_p,
-		     bool return_by_direct_ref_p, bool return_by_invisi_ref_p)
+fntype_same_flags_p (const_tree t, tree cico_list, bool return_by_direct_ref_p,
+		     bool return_by_invisi_ref_p)
 {
   return TYPE_CI_CO_LIST (t) == cico_list
-	 && TYPE_RETURN_UNCONSTRAINED_P (t) == return_unconstrained_p
 	 && TYPE_RETURN_BY_DIRECT_REF_P (t) == return_by_direct_ref_p
 	 && TREE_ADDRESSABLE (t) == return_by_invisi_ref_p;
 }
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index e188a6dae33..c6bcb71d40a 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -88,7 +88,6 @@ package Gen_IL.Fields is
       Body_Required,
       Body_To_Inline,
       Box_Present,
-      By_Ref,
       Char_Literal_Value,
       Chars,
       Check_Address_Alignment,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index dd730f4207b..97c16bce043 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -1059,7 +1059,6 @@ begin -- Gen_IL.Gen.Gen_Nodes
 
    Cc (N_Simple_Return_Statement, N_Statement_Other_Than_Procedure_Call,
        (Sy (Expression, Node_Id, Default_Empty),
-        Sm (By_Ref, Flag),
         Sm (Comes_From_Extended_Return_Statement, Flag),
         Sm (Procedure_To_Call, Node_Id),
         Sm (Return_Statement_Entity, Node_Id),
@@ -1068,7 +1067,6 @@ begin -- Gen_IL.Gen.Gen_Nodes
    Cc (N_Extended_Return_Statement, N_Statement_Other_Than_Procedure_Call,
        (Sy (Return_Object_Declarations, List_Id),
         Sy (Handled_Statement_Sequence, Node_Id, Default_Empty),
-        Sm (By_Ref, Flag),
         Sm (Procedure_To_Call, Node_Id),
         Sm (Return_Statement_Entity, Node_Id),
         Sm (Storage_Pool, Node_Id)));
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index cfe396ec1dd..9950d9ecffe 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -5989,7 +5989,7 @@ package body Sem_Ch6 is
          --  the subprogram is abstract also. This does not apply to renaming
          --  declarations, where abstractness is inherited, and to subprogram
          --  bodies generated for stream operations, which become renamings as
-         --  bodies.
+         --  bodies. We also skip the check for thunks.
 
          --  In case of primitives associated with abstract interface types
          --  the check is applied later (see Analyze_Subprogram_Declaration).
@@ -5998,6 +5998,7 @@ package body Sem_Ch6 is
               N_Abstract_Subprogram_Declaration        |
               N_Formal_Abstract_Subprogram_Declaration |
               N_Subprogram_Renaming_Declaration
+           and then not Is_Thunk (Designator)
          then
             if Is_Abstract_Type (Etype (Designator)) then
                Error_Msg_N
@@ -9011,7 +9012,7 @@ package body Sem_Ch6 is
       --  Local variables
 
       Formal_Type : Entity_Id;
-      P_Formal    : Entity_Id := Empty;
+      P_Formal    : Entity_Id;
 
    --  Start of processing for Create_Extra_Formals
 
@@ -9023,10 +9024,10 @@ package body Sem_Ch6 is
          return;
       end if;
 
-      --  No need to generate extra formals in interface thunks whose target
-      --  primitive has no extra formals.
+      --  No need to generate extra formals in thunks whose target has no extra
+      --  formals, but we can have two of them chained (interface and stack).
 
-      if Is_Thunk (E) and then No (Extra_Formals (Thunk_Entity (E))) then
+      if Is_Thunk (E) and then No (Extra_Formals (Thunk_Target (E))) then
          return;
       end if;
 
@@ -9036,6 +9037,8 @@ package body Sem_Ch6 is
 
       if Is_Overloadable (E) and then Present (Alias (E)) then
          P_Formal := First_Formal (Alias (E));
+      else
+         P_Formal := Empty;
       end if;
 
       Formal := First_Formal (E);
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index d5893914f27..7bead6b3522 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -296,6 +296,12 @@ package body Sem_Disp is
       Ctrl_Type : Entity_Id;
 
    begin
+      --  We skip the check for thunks
+
+      if Is_Thunk (Subp) then
+         return;
+      end if;
+
       Formal := First_Formal (Subp);
       while Present (Formal) loop
          Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 265c11afe1c..e1cfa0470ae 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -31,6 +31,7 @@ with Elists;         use Elists;
 with Errout;         use Errout;
 with Erroutc;        use Erroutc;
 with Exp_Ch3;        use Exp_Ch3;
+with Exp_Ch6;        use Exp_Ch6;
 with Exp_Ch11;       use Exp_Ch11;
 with Exp_Util;       use Exp_Util;
 with Fname;          use Fname;
@@ -6881,19 +6882,25 @@ package body Sem_Util is
    ----------------------------
 
    procedure Compute_Returns_By_Ref (Func : Entity_Id) is
-      Typ  : constant Entity_Id := Etype (Func);
+      Kind : constant Entity_Kind := Ekind (Func);
+      Typ  : constant Entity_Id   := Etype (Func);
 
    begin
-      if Is_Limited_View (Typ) then
+      --  Nothing to do for procedures
+
+      if Kind in E_Procedure | E_Generic_Procedure
+        or else (Kind = E_Subprogram_Type and then Typ = Standard_Void_Type)
+      then
+         null;
+
+      --  The build-in-place protocols return a reference to the result
+
+      elsif Is_Build_In_Place_Function (Func) then
          Set_Returns_By_Ref (Func);
 
-      --  For class-wide types and types which both need finalization and are
-      --  returned on the secondary stack, the secondary stack allocation is
-      --  done by the front end, see Expand_Simple_Function_Return.
+      --  In Ada 95, limited types are returned by reference
 
-      elsif Needs_Secondary_Stack (Typ)
-        and then CW_Or_Needs_Finalization (Underlying_Type (Typ))
-      then
+      elsif Is_Limited_View (Typ) then
          Set_Returns_By_Ref (Func);
       end if;
    end Compute_Returns_By_Ref;
@@ -23481,13 +23488,14 @@ package body Sem_Util is
       then
          return Needs_Secondary_Stack (Cloned_Subtype (Typ));
 
-      --  Functions returning specific tagged types may dispatch on result, so
-      --  their returned value is allocated on the secondary stack, even in the
-      --  definite case. We must treat nondispatching functions the same way,
-      --  because access-to-function types can point at both, so the calling
-      --  conventions must be compatible.
+      --  Class-wide types obviously have an unknown size. For specific tagged
+      --  types, if a call returning one of them is dispatching on result, and
+      --  this type is not returned on the secondary stack, then the call goes
+      --  through a thunk that only moves the result from the primary onto the
+      --  secondary stack, because the computation of the size of the result is
+      --  possible but complex from the outside.
 
-      elsif Is_Tagged_Type (Typ) then
+      elsif Is_Class_Wide_Type (Typ) then
          return True;
 
       --  If the return slot of the back end cannot be accessed, then there
@@ -23498,9 +23506,9 @@ package body Sem_Util is
       elsif not Back_End_Return_Slot and then Needs_Finalization (Typ) then
          return True;
 
-      --  Untagged definite subtypes are known size. This includes all
-      --  elementary [sub]types. Tasks are known size even if they have
-      --  discriminants. So we return False here, with one exception:
+      --  Definite subtypes have a known size. This includes all elementary
+      --  types. Tasks have a known size even if they have discriminants, so
+      --  we return False here, with one exception:
       --  For a type like:
       --    type T (Last : Natural := 0) is
       --       X : String (1 .. Last);
@@ -23513,7 +23521,7 @@ package body Sem_Util is
       elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
          return Large_Max_Size_Mutable (Typ);
 
-      --  Indefinite (discriminated) untagged record or protected type
+      --  Indefinite (discriminated) record or protected type
 
       elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
          return not Caller_Known_Size_Record (Typ);
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 87042bd97f6..e18a427f9a2 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -927,12 +927,6 @@ package Sinfo is
    --    a pragma Import or Interface applies, in which case no body is
    --    permitted (in Ada 83 or Ada 95).
 
-   --  By_Ref
-   --    Present in N_Simple_Return_Statement and N_Extended_Return_Statement,
-   --    this flag is set when the returned expression is already allocated on
-   --    the secondary stack and thus the result is passed by reference rather
-   --    than copied another time.
-
    --  Cleanup_Actions
    --    Present in block statements created for transient blocks, contains
    --    additional cleanup actions carried over from the transient scope.
@@ -5576,7 +5570,6 @@ package Sinfo is
       --  Expression (set to Empty if no expression present)
       --  Storage_Pool
       --  Procedure_To_Call
-      --  By_Ref
       --  Comes_From_Extended_Return_Statement
 
       --  Note: Return_Statement_Entity points to an E_Return_Statement
@@ -5591,7 +5584,6 @@ package Sinfo is
       --  Handled_Statement_Sequence (set to Empty if not present)
       --  Storage_Pool
       --  Procedure_To_Call
-      --  By_Ref
 
       --  Note: Return_Statement_Entity points to an E_Return_Statement.