-- 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
-- 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
-- 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
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
(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;
-----------------------
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
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 :=
-- 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
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;
-- 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
-- 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)
-- 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
-- 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');
-- formals.
if Is_Thunk (Func_Id) then
- Subp_Id := Thunk_Entity (Func_Id);
+ Subp_Id := Thunk_Target (Func_Id);
-- Common case
-- 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;
--------------------------
--------------------------
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;
-------------------------------------
-- 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
-- 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 --
--------------------------------------------------
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
-- 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
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;
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);
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
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;
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
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),
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,
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 :=
-- 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);
Expression => Relocate_Node (Call_Node));
end if;
- Thunk_Code :=
+ Append_To (Thunk_Code,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
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 --
--------------------------
-- 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;
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;
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
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,
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);
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
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;
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;
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;
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);
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;
(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))
(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,
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;
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));
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
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
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;
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
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)
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
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;
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 --
-------------------------------------
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 --
-------------------
-- 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
-- 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
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;
/* 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: */
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) \
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;
&& !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);
}
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). */
}
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);
}
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
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;
}
= 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;
/* 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;
}
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
{
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));
}
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;
/* 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;
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)
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
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);
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. */
/* 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;
}
Body_Required,
Body_To_Inline,
Box_Present,
- By_Ref,
Char_Literal_Value,
Chars,
Check_Address_Alignment,
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),
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)));
-- 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).
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
-- Local variables
Formal_Type : Entity_Id;
- P_Formal : Entity_Id := Empty;
+ P_Formal : Entity_Id;
-- Start of processing for Create_Extra_Formals
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;
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);
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);
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;
----------------------------
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;
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
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);
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);
-- 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.
-- 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
-- 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.
projects / thirdparty / gcc.git / commitdiff
