+2017-09-29 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb (Expand_Call_Helper): Handle case of build-in-place
+ functions returning nonlimited types. Allow for qualified expressions
+ and type conversions.
+ (Expand_N_Extended_Return_Statement): Correct the computation of
+ Func_Bod to allow for child units.
+ (Expand_Simple_Function_Return): Remove assumption that b-i-p implies
+ limited (initialization of In_Place_Expansion), and implies >= Ada
+ 2005.
+ (Is_Build_In_Place_Result_Type): New function to accompany
+ Is_Build_In_Place_Function and Is_Build_In_Place_Function_Call, because
+ sometimes we just have the type on our hands, not the function. For
+ now, does the same thing as the old version, so build-in-place is
+ disabled for nonlimited types, except that you can use -gnatd.9 to
+ enable it.
+ * exp_ch6.ads (Is_Build_In_Place_Result_Type): New function to
+ accompany Is_Build_In_Place_Function and
+ Is_Build_In_Place_Function_Call, because sometimes we just have the
+ type on our hands, not the function.
+ (Make_Build_In_Place_Call_In_...): Handle nonlimited build-in-place
+ cases.
+ (Make_Build_In_Place_Call_In_Object_Declaration): Remove the
+ questionable code at the end that was setting the Etype.
+ * exp_aggr.adb (Is_Build_In_Place_Aggregate_Return): New function to
+ determine whether "return (...agg...);" is returning from a
+ build-in-place function.
+ (Initialize_Ctrl_Array_Component, Initialize_Ctrl_Record_Component):
+ Remove assumption that b-i-p implies limited (initialization of
+ In_Place_Expansion).
+ (Build_Record_Aggr_Code): AI-287: fix comment; it can't be wrapped in
+ an unchecked conversion. Add assertions.
+ (Convert_Aggr_In_Object_Decl): Establish_Transient_Scope -- no need for
+ secondary stack here, just because the type needs finalization. That
+ code is obsolete.
+ (Convert_To_Assignments): Only set Unc_Decl if Nkind (N) = N_Aggregate.
+ For "return (...agg...);" don't assume b-i-p implies limited.
+ Needs_Finalization does not imply secondary stack.
+ (Expand_Array_Aggregate): Named notation. Reverse the sense of
+ Component_OK_For_Backend -- more readability with fewer double
+ negatives.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Remove assumptions that
+ b-i-p implies >= Ada 2005.
+ * exp_ch3.adb (Expand_N_Object_Declaration): Remove assumptions that
+ b-i-p implies >= Ada 2005. Remove Adjust if we're building the return
+ object of an extended return statement in place.
+ * exp_ch4.adb (Expand_Allocator_Expression, Expand_N_Indexed_Component,
+ Expand_N_Selected_Component, Expand_N_Slice): Remove assumptions that
+ b-i-p implies >= Ada 2005.
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Remove assumption that
+ b-i-p implies >= Ada 2005.
+ * exp_ch7.adb: Comment fix.
+ * exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Remove
+ assumptions that b-i-p implies >= Ada 2005.
+ * exp_disp.adb (Expand_Interface_Actuals): Remove assumptions that
+ b-i-p implies >= Ada 2005.
+ * exp_util.adb (Build_Allocate_Deallocate_Proc): Look at Storage_Pool
+ (Expr), in case Pool_Id is not set.
+ (Initialized_By_Aliased_BIP_Func_Call): Handle case where the call is
+ qualified or converted.
+ (Is_Secondary_Stack_BIP_Func_Call): Don't check if Nkind (Selector_Name
+ (Param)) = N_Identifier; that's all it could be.
+ * sinfo.ads: Comment fixes.
+ * snames.ads-tmpl: Comment fixes.
+ * debug.adb: Add flag gnatd.9, to enable the build-in-place machinery.
+
2017-09-29 Justin Squirek <squirek@adacore.com>
* sem_ch8.adb (Mark_Use_Clauses): Add recursive call to properly handle
-- d.6 Do not avoid declaring unreferenced types in C code
-- d.7
-- d.8
- -- d.9
+ -- d.9 Enable build-in-place for nonlimited types
-- Debug flags for binder (GNATBIND)
-- referenced by the generated C code. This debug flag restores the
-- output of all the types.
+ -- d.9 Enable build-in-place for function calls returning some nonlimited
+ -- types.
+
------------------------------------------
-- Documentation for Binder Debug Flags --
------------------------------------------
-- Local subprograms for Record Aggregate Expansion --
------------------------------------------------------
+ function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean;
+ -- True if N is an aggregate (possibly qualified or converted) that is
+ -- being returned from a build-in-place function.
+
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
-- types.
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
- -- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
- -- aggregate (which can only be a record type, this procedure is only used
- -- for record types). Transform the given aggregate into a sequence of
- -- assignments performed component by component.
+ -- Transform a record aggregate into a sequence of assignments performed
+ -- component by component. N is an N_Aggregate or N_Extension_Aggregate.
+ -- Typ is the type of the record aggregate.
procedure Expand_Record_Aggregate
(N : Node_Id;
-- Checks 5 (if the component type is tagged, then we may need to do
-- tag adjustments. Perhaps this should be refined to check for any
-- component associations that actually need tag adjustment, similar
- -- to the test in Component_Not_OK_For_Backend for record aggregates
- -- with tagged components, but not clear whether it's worthwhile ???;
- -- in the case of virtual machines (no Tagged_Type_Expansion), object
- -- tags are handled implicitly).
+ -- to the test in Component_OK_For_Backend for record aggregates with
+ -- tagged components, but not clear whether it's worthwhile ???; in the
+ -- case of virtual machines (no Tagged_Type_Expansion), object tags are
+ -- handled implicitly).
if Is_Tagged_Type (Component_Type (Typ))
and then Tagged_Type_Expansion
In_Place_Expansion :=
Nkind (Expr) = N_Function_Call
- and then not Is_Limited_Type (Comp_Typ);
+ and then not Is_Build_In_Place_Result_Type (Comp_Typ);
-- The initialization expression is a controlled function call.
-- Perform in-place removal of side effects to avoid creating a
In_Place_Expansion :=
Nkind (Init_Expr) = N_Function_Call
- and then not Is_Limited_Type (Comp_Typ);
+ and then not Is_Build_In_Place_Result_Type (Comp_Typ);
-- The initialization expression is a controlled function call.
-- Perform in-place removal of side effects to avoid creating a
-- [Deep_]Adjust (Rec_Comp);
- if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then
+ if Finalization_OK
+ and then not Is_Limited_Type (Comp_Typ)
+ and then not Is_Build_In_Place_Function_Call (Init_Expr)
+ then
Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Rec_Comp),
-- Ada 2005 (AI-287): If the ancestor part is an aggregate of
-- limited type, a recursive call expands the ancestor. Note that
-- in the limited case, the ancestor part must be either a
- -- function call (possibly qualified, or wrapped in an unchecked
- -- conversion) or aggregate (definitely qualified).
-
- -- The ancestor part can also be a function call (that may be
- -- transformed into an explicit dereference) or a qualification
- -- of one such.
+ -- function call (possibly qualified) or aggregate (definitely
+ -- qualified).
elsif Is_Limited_Type (Etype (Ancestor))
and then Nkind_In (Unqualify (Ancestor), N_Aggregate,
if Needs_Finalization (Etype (Ancestor))
and then not Is_Limited_Type (Etype (Ancestor))
+ and then not Is_Build_In_Place_Function_Call (Ancestor)
then
Adj_Call :=
Make_Adjust_Call
Check_Ancestor_Discriminants (Init_Typ);
end if;
end if;
+
+ pragma Assert (Nkind (N) = N_Extension_Aggregate);
+ pragma Assert
+ (not (Ancestor_Is_Expression and Ancestor_Is_Subtype_Mark));
end;
-- Generate assignments of hidden discriminants. If the base type is
and then Ekind (Current_Scope) /= E_Return_Statement
and then not Is_Limited_Type (Typ)
then
- Establish_Transient_Scope
- (Aggr,
- Sec_Stack =>
- Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
+ Establish_Transient_Scope (Aggr, Sec_Stack => False);
end if;
declare
-- Convert_To_Assignments --
----------------------------
+ function Is_Build_In_Place_Aggregate_Return (N : Node_Id) return Boolean is
+ P : Node_Id := Parent (N);
+ begin
+ while Nkind (P) = N_Qualified_Expression loop
+ P := Parent (P);
+ end loop;
+
+ if Nkind (P) = N_Simple_Return_Statement then
+ null;
+ elsif Nkind (Parent (P)) = N_Extended_Return_Statement then
+ P := Parent (P);
+ else
+ return False;
+ end if;
+
+ return Is_Build_In_Place_Function
+ (Return_Applies_To (Return_Statement_Entity (P)));
+ end Is_Build_In_Place_Aggregate_Return;
+
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
T : Entity_Id;
Parent_Node : Node_Id;
begin
+ pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate));
pragma Assert (not Is_Static_Dispatch_Table_Aggregate (N));
pragma Assert (Is_Record_Type (Typ));
Parent_Kind := Nkind (Parent_Node);
if Parent_Kind = N_Qualified_Expression then
-
- -- Check if we are in a unconstrained declaration because in this
+ -- Check if we are in an unconstrained declaration because in this
-- case the current delayed expansion mechanism doesn't work when
- -- the declared object size depend on the initializing expr.
+ -- the declared object size depends on the initializing expr.
Parent_Node := Parent (Parent_Node);
Parent_Kind := Nkind (Parent_Node);
if Parent_Kind = N_Object_Declaration then
Unc_Decl :=
not Is_Entity_Name (Object_Definition (Parent_Node))
- or else Has_Discriminants
- (Entity (Object_Definition (Parent_Node)))
+ or else (Nkind (N) = N_Aggregate
+ and then Has_Discriminants
+ (Entity (Object_Definition (Parent_Node))))
or else Is_Class_Wide_Type
(Entity (Object_Definition (Parent_Node)));
end if;
-- finalization of the return object (which is built in place
-- within the caller's scope).
- or else
- (Is_Limited_View (Typ)
- and then
- (Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
- or else Nkind (Parent_Node) = N_Simple_Return_Statement))
+ or else Is_Build_In_Place_Aggregate_Return (N)
then
Set_Expansion_Delayed (N);
return;
-- Should the condition be more restrictive ???
if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
- Establish_Transient_Scope (N, Sec_Stack => Needs_Finalization (Typ));
+ Establish_Transient_Scope (N, Sec_Stack => False);
end if;
-- If the aggregate is nonlimited, create a temporary. If it is limited
-- for default initialization, e.g. with Initialize_Scalars.
if Requires_Transient_Scope (Typ) then
- Establish_Transient_Scope
- (N, Sec_Stack => Has_Controlled_Component (Typ));
+ Establish_Transient_Scope (N, Sec_Stack => False);
end if;
if Has_Default_Init_Comps (N) then
if Ekind (Current_Scope) = E_Loop
and then Nkind (Parent (Parent (N))) = N_Allocator
then
- Establish_Transient_Scope (N, False);
+ Establish_Transient_Scope (N, Sec_Stack => False);
end if;
Insert_Action (N, Tmp_Decl);
-- If the ancestor part is an expression, add a component association for
-- the parent field. If the type of the ancestor part is not the direct
- -- parent of the expected type, build recursively the needed ancestors.
- -- If the ancestor part is a subtype_mark, replace aggregate with a decla-
- -- ration for a temporary of the expected type, followed by individual
- -- assignments to the given components.
+ -- parent of the expected type, build recursively the needed ancestors.
+ -- If the ancestor part is a subtype_mark, replace aggregate with a
+ -- declaration for a temporary of the expected type, followed by
+ -- individual assignments to the given components.
procedure Expand_N_Extension_Aggregate (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
A : constant Node_Id := Ancestor_Part (N);
Typ : constant Entity_Id := Etype (N);
Static_Components : Boolean := True;
-- Flag to indicate whether all components are compile-time known,
-- and the aggregate can be constructed statically and handled by
- -- the back-end.
+ -- the back-end. Set to False by Component_OK_For_Backend.
procedure Build_Back_End_Aggregate;
-- Build a proper aggregate to be handled by the back-end
-- This returns true for N_Aggregate with Compile_Time_Known_Aggregate
-- set and constants whose expression is such an aggregate, recursively.
- function Component_Not_OK_For_Backend return Boolean;
+ function Component_OK_For_Backend return Boolean;
-- Check for presence of a component which makes it impossible for the
-- backend to process the aggregate, thus requiring the use of a series
-- of assignment statements. Cases checked for are a nested aggregate
-- in order to minimize elaboration code. This is one case where the
-- semantics of Ada complicate the analysis and lead to anomalies in
-- the gcc back-end if the aggregate is not expanded into assignments.
+ --
+ -- NOTE: This sets the global Static_Components to False in most, but
+ -- not all, cases when it returns False.
function Has_Per_Object_Constraint (L : List_Id) return Boolean;
-- Return True if any element of L has Has_Per_Object_Constraint set.
-- The ancestor part may be a nested aggregate that has
-- delayed expansion: recheck now.
- if Component_Not_OK_For_Backend then
+ if not Component_OK_For_Backend then
Convert_To_Assignments (N, Typ);
end if;
end;
end Compile_Time_Known_Composite_Value;
- ----------------------------------
- -- Component_Not_OK_For_Backend --
- ----------------------------------
+ ------------------------------
+ -- Component_OK_For_Backend --
+ ------------------------------
- function Component_Not_OK_For_Backend return Boolean is
+ function Component_OK_For_Backend return Boolean is
C : Node_Id;
Expr_Q : Node_Id;
begin
if No (Comps) then
- return False;
+ return True;
end if;
C := First (Comps);
-- and component is not ready for backend.
if Box_Present (C) then
- return True;
+ return False;
end if;
if Nkind (Expression (C)) = N_Qualified_Expression then
Expr_Q := Expression (C);
end if;
- -- Return true if the aggregate has any associations for tagged
+ -- Return False if the aggregate has any associations for tagged
-- components that may require tag adjustment.
-- These are cases where the source expression may have a tag that
and then Tagged_Type_Expansion
then
Static_Components := False;
- return True;
+ return False;
elsif Is_Delayed_Aggregate (Expr_Q) then
Static_Components := False;
- return True;
+ return False;
elsif Possible_Bit_Aligned_Component (Expr_Q) then
Static_Components := False;
- return True;
+ return False;
elsif Modify_Tree_For_C
and then Nkind (C) = N_Component_Association
and then Has_Per_Object_Constraint (Choices (C))
then
Static_Components := False;
- return True;
+ return False;
elsif Modify_Tree_For_C
and then Nkind (Expr_Q) = N_Identifier
and then Is_Array_Type (Etype (Expr_Q))
then
Static_Components := False;
- return True;
+ return False;
elsif Modify_Tree_For_C
and then Nkind (Expr_Q) = N_Type_Conversion
and then Is_Array_Type (Etype (Expr_Q))
then
Static_Components := False;
- return True;
+ return False;
end if;
if Is_Elementary_Type (Etype (Expr_Q)) then
if Is_Private_Type (Etype (Expr_Q))
and then Has_Discriminants (Etype (Expr_Q))
then
- return True;
+ return False;
end if;
end if;
Next (C);
end loop;
- return False;
- end Component_Not_OK_For_Backend;
+ return True;
+ end Component_OK_For_Backend;
-------------------------------
-- Has_Per_Object_Constraint --
-- Ada 2005 (AI-318-2): We need to convert to assignments if components
-- are build-in-place function calls. The assignments will each turn
-- into a build-in-place function call. If components are all static,
- -- we can pass the aggregate to the backend regardless of limitedness.
+ -- we can pass the aggregate to the back end regardless of limitedness.
-- Extension aggregates, aggregates in extended return statements, and
-- aggregates for C++ imported types must be expanded.
Convert_To_Assignments (N, Typ);
elsif not Size_Known_At_Compile_Time (Typ)
- or else Component_Not_OK_For_Backend
+ or else not Component_OK_For_Backend
or else not Static_Components
then
Convert_To_Assignments (N, Typ);
-- Check components
- elsif Component_Not_OK_For_Backend then
+ elsif not Component_OK_For_Backend then
Convert_To_Assignments (N, Typ);
-- If an ancestor is private, some components are not inherited and we
-- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
-- place function, then a temporary return object needs to be created
- -- and access to it must be passed to the function. Currently we limit
- -- such functions to those with inherently limited result subtypes, but
- -- eventually we plan to expand the functions that are treated as
- -- build-in-place to include other composite result types.
+ -- and access to it must be passed to the function.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Pref)
- then
+ if Is_Build_In_Place_Function_Call (Pref) then
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
-- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
-- containing build-in-place function calls whose returned object covers
-- interface types.
- elsif Ada_Version >= Ada_2005
- and then Present (Unqual_BIP_Iface_Function_Call (Pref))
- then
+ elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
end if;
-- plan to expand the allowed forms of functions that are treated as
-- build-in-place.
- elsif Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Expr_Q)
- then
+ elsif Is_Build_In_Place_Function_Call (Expr_Q) then
Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q);
-- The previous call expands the expression initializing the
-- in-place object to reference the secondary dispatch table of a
-- covered interface type.
- elsif Ada_Version >= Ada_2005
- and then Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
- then
+ elsif Present (Unqual_BIP_Iface_Function_Call (Expr_Q)) then
Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
-- The previous call expands the expression initializing the
-- the target is adjusted after the copy and attached to the
-- finalization list. However, no adjustment is done in the case
-- where the object was initialized by a call to a function whose
- -- result is built in place, since no copy occurred. (Eventually
- -- we plan to support in-place function results for some cases
- -- of nonlimited types. ???) Similarly, no adjustment is required
- -- if we are going to rewrite the object declaration into a
- -- renaming declaration.
+ -- result is built in place, since no copy occurred. Similarly, no
+ -- adjustment is required if we are going to rewrite the object
+ -- declaration into a renaming declaration.
+
+ if Is_Build_In_Place_Result_Type (Typ)
+ and then Nkind (Parent (N)) = N_Extended_Return_Statement
+ and then not Is_Definite_Subtype
+ (Etype (Return_Applies_To
+ (Return_Statement_Entity (Parent (N)))))
+ then
+ null;
- if Needs_Finalization (Typ)
+ elsif Needs_Finalization (Typ)
and then not Is_Limited_View (Typ)
and then not Rewrite_As_Renaming
then
end if;
end if;
- -- Cases where the back end cannot handle the initialization directly
- -- In such cases, we expand an assignment that will be appropriately
- -- handled by Expand_N_Assignment_Statement.
+ -- Cases where the back end cannot handle the initialization
+ -- directly. In such cases, we expand an assignment that will
+ -- be appropriately handled by Expand_N_Assignment_Statement.
-- The exclusion of the unconstrained case is wrong, but for now it
-- is too much trouble ???
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the allocated object
- -- must be passed to the function. Currently we limit such functions
- -- to those with constrained limited result subtypes, but eventually
- -- we plan to expand the allowed forms of functions that are treated
- -- as build-in-place.
+ -- must be passed to the function.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Exp)
- then
+ if Is_Build_In_Place_Function_Call (Exp) then
Make_Build_In_Place_Call_In_Allocator (N, Exp);
Apply_Accessibility_Check (N, Built_In_Place => True);
return;
-- in-place object to reference the secondary dispatch table of a
-- covered interface type.
- elsif Ada_Version >= Ada_2005
- and then Present (Unqual_BIP_Iface_Function_Call (Exp))
- then
+ elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then
Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
Apply_Accessibility_Check (N, Built_In_Place => True);
return;
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the allocated object
- -- must be passed to the function. Currently we limit such functions
- -- to those with constrained limited result subtypes, but eventually
- -- we plan to expand the allowed forms of functions that are treated
- -- as build-in-place.
+ -- must be passed to the function.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Exp)
- then
+ if Is_Build_In_Place_Function_Call (Exp) then
Make_Build_In_Place_Call_In_Allocator (N, Exp);
end if;
end if;
-- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
-- function, then additional actuals must be passed.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (P)
- then
+ if Is_Build_In_Place_Function_Call (P) then
Make_Build_In_Place_Call_In_Anonymous_Context (P);
-- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
-- containing build-in-place function calls whose returned object covers
-- interface types.
- elsif Ada_Version >= Ada_2005
- and then Present (Unqual_BIP_Iface_Function_Call (P))
- then
+ elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
end if;
-- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
-- function, then additional actuals must be passed.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (P)
- then
+ if Is_Build_In_Place_Function_Call (P) then
Make_Build_In_Place_Call_In_Anonymous_Context (P);
-- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
-- containing build-in-place function calls whose returned object covers
-- interface types.
- elsif Ada_Version >= Ada_2005
- and then Present (Unqual_BIP_Iface_Function_Call (P))
- then
+ elsif Present (Unqual_BIP_Iface_Function_Call (P)) then
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
end if;
-- Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
-- function, then additional actuals must be passed.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Pref)
- then
+ if Is_Build_In_Place_Function_Call (Pref) then
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
-- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
-- containing build-in-place function calls whose returned object covers
-- interface types.
- elsif Ada_Version >= Ada_2005
- and then Present (Unqual_BIP_Iface_Function_Call (Pref))
- then
+ elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
end if;
end;
end if;
- -- Build-in-place function call case. Note that we're not yet doing
- -- build-in-place for user-written assignment statements (the assignment
- -- here came from an aggregate.)
+ -- Build-in-place function call case. This is for assignment statements
+ -- that come from aggregate component associations or from init procs.
+ -- User-written assignment statements with b-i-p calls are handled
+ -- elsewhere.
- elsif Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Rhs)
- then
+ elsif Is_Build_In_Place_Function_Call (Rhs) then
+ pragma Assert (not Comes_From_Source (N));
Make_Build_In_Place_Call_In_Assignment (N, Rhs);
elsif Is_Tagged_Type (Typ)
procedure Expand_Call (N : Node_Id) is
Post_Call : List_Id;
begin
+ pragma Assert
+ (Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement,
+ N_Entry_Call_Statement));
Expand_Call_Helper (N, Post_Call);
Insert_Post_Call_Actions (N, Post_Call);
end Expand_Call;
-- result from the secondary stack.
if Needs_Finalization (Etype (Subp)) then
- if not Is_Limited_View (Etype (Subp))
- and then
- (No (First_Formal (Subp))
- or else
- not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
- then
- Expand_Ctrl_Function_Call (Call_Node);
-
-- Build-in-place function calls which appear in anonymous contexts
-- need a transient scope to ensure the proper finalization of the
-- intermediate result after its use.
- elsif Is_Build_In_Place_Function_Call (Call_Node)
+ if Is_Build_In_Place_Function_Call (Call_Node)
and then
- Nkind_In (Parent (Call_Node), N_Attribute_Reference,
- N_Function_Call,
- N_Indexed_Component,
- N_Object_Renaming_Declaration,
- N_Procedure_Call_Statement,
- N_Selected_Component,
- N_Slice)
+ Nkind_In (Parent (Unqual_Conv (Call_Node)),
+ N_Attribute_Reference,
+ N_Function_Call,
+ N_Indexed_Component,
+ N_Object_Renaming_Declaration,
+ N_Procedure_Call_Statement,
+ N_Selected_Component,
+ N_Slice)
then
Establish_Transient_Scope (Call_Node, Sec_Stack => True);
+
+ elsif not Is_Build_In_Place_Function_Call (Call_Node)
+ and then
+ (No (First_Formal (Subp))
+ or else
+ not Is_Concurrent_Record_Type (Etype (First_Formal (Subp))))
+ then
+ Expand_Ctrl_Function_Call (Call_Node);
end if;
end if;
end Expand_Call_Helper;
Func_Bod := Parent (Parent (Corresponding_Body (Func_Bod)));
end if;
+ if Nkind (Func_Bod) = N_Function_Specification then
+ Func_Bod := Parent (Func_Bod); -- one more level for child units
+ end if;
+
+ pragma Assert (Nkind (Func_Bod) = N_Subprogram_Body);
+
-- Create a flag to track the function state
Flag_Id := Make_Temporary (Loc, 'F');
-- Build a simple_return_statement that returns the return object when
-- there is a statement sequence, or no expression, or the result will
-- be built in place. Note however that we currently do this for all
- -- composite cases, even though nonlimited composite results are not yet
- -- built in place (though we plan to do so eventually).
+ -- composite cases, even though not all are built in place.
if Present (HSS)
or else Is_Composite_Type (Ret_Typ)
end if;
-- For the case of a simple return that does not come from an extended
- -- return, in the case of Ada 2005 where we are returning a limited
- -- type, we rewrite "return <expression>;" to be:
+ -- return, in the case of build-in-place, we rewrite "return
+ -- <expression>;" to be:
-- return _anon_ : <return_subtype> := <expression>
-- class-wide interface type, which is not a limited type, even though
-- the type of the expression may be.
+ pragma Assert
+ (Comes_From_Extended_Return_Statement (N)
+ or else not Is_Build_In_Place_Function_Call (Exp)
+ or else Is_Build_In_Place_Function (Scope_Id));
+
if not Comes_From_Extended_Return_Statement (N)
- and then Is_Limited_View (Etype (Expression (N)))
- and then Ada_Version >= Ada_2005
+ and then Is_Build_In_Place_Function (Scope_Id)
and then not Debug_Flag_Dot_L
-- The functionality of interface thunks is simple and it is always
-- type that requires special processing (indicated by the fact that
-- it requires a cleanup scope for the secondary stack case).
- if Is_Limited_View (Exptyp)
+ if Is_Build_In_Place_Function (Scope_Id)
or else Is_Limited_Interface (Exptyp)
then
null;
return False;
end Has_Unconstrained_Access_Discriminants;
+ -----------------------------------
+ -- Is_Build_In_Place_Result_Type --
+ -----------------------------------
+
+ function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
+ begin
+ -- In Ada 2005 all functions with an inherently limited return type
+ -- must be handled using a build-in-place profile, including the case
+ -- of a function with a limited interface result, where the function
+ -- may return objects of nonlimited descendants.
+
+ if Is_Limited_View (Typ) then
+ return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
+ else
+ return Debug_Flag_Dot_9;
+ end if;
+ end Is_Build_In_Place_Result_Type;
+
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
-- intended to be compatible with the other language, but the build-
-- in place machinery can ensure that the object is not copied.
- if Has_Foreign_Convention (E) then
- return False;
-
- -- In Ada 2005 all functions with an inherently limited return type
- -- must be handled using a build-in-place profile, including the case
- -- of a function with a limited interface result, where the function
- -- may return objects of nonlimited descendants.
-
- else
- return Is_Limited_View (Etype (E))
- and then Ada_Version >= Ada_2005
- and then not Debug_Flag_Dot_L;
- end if;
+ return Is_Build_In_Place_Result_Type (Etype (E))
+ and then not Has_Foreign_Convention (E)
+ and then not Debug_Flag_Dot_L;
else
return False;
-- may end up with a call that is neither resolved to an entity, nor
-- an indirect call.
- if not Expander_Active then
+ if not Expander_Active or else Nkind (Exp_Node) /= N_Function_Call then
return False;
end if;
- if Nkind (Exp_Node) /= N_Function_Call then
- return False;
-
- else
- if Is_Entity_Name (Name (Exp_Node)) then
- Function_Id := Entity (Name (Exp_Node));
+ if Is_Entity_Name (Name (Exp_Node)) then
+ Function_Id := Entity (Name (Exp_Node));
- -- In the case of an explicitly dereferenced call, use the subprogram
- -- type generated for the dereference.
+ -- In the case of an explicitly dereferenced call, use the subprogram
+ -- type generated for the dereference.
- elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
- Function_Id := Etype (Name (Exp_Node));
+ elsif Nkind (Name (Exp_Node)) = N_Explicit_Dereference then
+ Function_Id := Etype (Name (Exp_Node));
- -- This may be a call to a protected function.
+ -- This may be a call to a protected function.
- elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
- Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
+ elsif Nkind (Name (Exp_Node)) = N_Selected_Component then
+ Function_Id := Etype (Entity (Selector_Name (Name (Exp_Node))));
- else
- raise Program_Error;
- end if;
-
- return Is_Build_In_Place_Function (Function_Id);
+ else
+ raise Program_Error;
end if;
+
+ declare
+ Result : constant Boolean := Is_Build_In_Place_Function (Function_Id);
+ begin
+ return Result;
+ end;
end Is_Build_In_Place_Function_Call;
-----------------------
Func_Call := Expression (Func_Call);
end if;
- -- If the call has already been processed to add build-in-place actuals
- -- then return. This should not normally occur in an allocator context,
- -- but we add the protection as a defensive measure.
-
- if Is_Expanded_Build_In_Place_Call (Func_Call) then
- return;
- end if;
-
-- Mark the call as processed as a build-in-place call
+ pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
Loc := Sloc (Function_Call);
Return_Obj_Access := Make_Temporary (Loc, 'R');
Set_Etype (Return_Obj_Access, Acc_Type);
+ Set_Can_Never_Be_Null (Acc_Type, False);
+ -- It gets initialized to null, so we can't have that.
-- When the result subtype is constrained, the return object is
-- allocated on the caller side, and access to it is passed to the
-- the characteristics of the full view.
if Is_Constrained (Underlying_Type (Result_Subt)) then
-
-- Replace the initialized allocator of form "new T'(Func (...))"
-- with an uninitialized allocator of form "new T", where T is the
-- result subtype of the called function. The call to the function
Lhs : constant Node_Id := Name (Assign);
Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
Func_Id : Entity_Id;
- Loc : Source_Ptr;
+ Loc : constant Source_Ptr := Sloc (Function_Call);
Obj_Decl : Node_Id;
Obj_Id : Entity_Id;
Ptr_Typ : Entity_Id;
Result_Subt : Entity_Id;
begin
- -- If the call has already been processed to add build-in-place actuals
- -- then return. This should not normally occur in an assignment context,
- -- but we add the protection as a defensive measure.
-
- if Is_Expanded_Build_In_Place_Call (Func_Call) then
- return;
- end if;
-
-- Mark the call as processed as a build-in-place call
+ pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
- Loc := Sloc (Function_Call);
-
if Is_Entity_Name (Name (Func_Call)) then
Func_Id := Entity (Name (Func_Call));
New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
+ -- Add a conversion if it's the wrong type
+
+ if Etype (New_Expr) /= Ptr_Typ then
+ New_Expr := Make_Unchecked_Type_Conversion (Loc,
+ New_Occurrence_Of (Ptr_Typ, Loc), New_Expr);
+ end if;
+
Obj_Id := Make_Temporary (Loc, 'R', New_Expr);
Set_Etype (Obj_Id, Ptr_Typ);
Set_Is_Known_Non_Null (Obj_Id);
Func_Call : constant Node_Id := Unqual_Conv (Function_Call);
Function_Id : Entity_Id;
Pool_Actual : Node_Id;
+ Designated_Type : Entity_Id;
Ptr_Typ : Entity_Id;
Ptr_Typ_Decl : Node_Id;
Pass_Caller_Acc : Boolean := False;
Result_Subt : Entity_Id;
begin
- -- If the call has already been processed to add build-in-place actuals
- -- then return. This should not normally occur in an object declaration,
- -- but we add the protection as a defensive measure.
-
- if Is_Expanded_Build_In_Place_Call (Func_Call) then
- return;
- end if;
-
-- Mark the call as processed as a build-in-place call
+ pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call));
Set_Is_Expanded_Build_In_Place_Call (Func_Call);
if Is_Entity_Name (Name (Func_Call)) then
-- access type must be declared before we establish a transient
-- scope, so that it receives the proper accessibility level.
+ if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl)))
+ and then not Is_Interface (Etype (Defining_Identifier (Obj_Decl)))
+ and then not Is_Class_Wide_Type (Etype (Function_Call))
+ then
+ Designated_Type := Etype (Defining_Identifier (Obj_Decl));
+ else
+ Designated_Type := Etype (Function_Call);
+ end if;
+
Ptr_Typ := Make_Temporary (Loc, 'A');
Ptr_Typ_Decl :=
Make_Full_Type_Declaration (Loc,
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication =>
- New_Occurrence_Of (Etype (Function_Call), Loc)));
+ New_Occurrence_Of (Designated_Type, Loc)));
-- The access type and its accompanying object must be inserted after
-- the object declaration in the constrained case, so that the
-- Force immediate freezing of Ptr_Typ because Res_Decl will be
-- elaborated in an inner (transient) scope and thus won't cause
- -- freezing by itself.
+ -- freezing by itself. It's not an itype, but it needs to be frozen
+ -- inside the current subprogram (see Freeze_Outside in freeze.adb).
- declare
- Ptr_Typ_Freeze_Ref : constant Node_Id :=
- New_Occurrence_Of (Ptr_Typ, Loc);
- begin
- Set_Parent (Ptr_Typ_Freeze_Ref, Ptr_Typ_Decl);
- Freeze_Expression (Ptr_Typ_Freeze_Ref);
- end;
+ Freeze_Itype (Ptr_Typ, Ptr_Typ_Decl);
-- If the object is a return object of an enclosing build-in-place
-- function, then the implicit build-in-place parameters of the
Set_Etype (Def_Id, Ptr_Typ);
Set_Is_Known_Non_Null (Def_Id);
- Res_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
- Expression =>
- Make_Reference (Loc, Relocate_Node (Func_Call)));
+ if Nkind (Function_Call) = N_Type_Conversion then
+ Res_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression =>
+ Make_Unchecked_Type_Conversion (Loc,
+ New_Occurrence_Of (Ptr_Typ, Loc),
+ Make_Reference (Loc, Relocate_Node (Func_Call))));
+ else
+ Res_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression =>
+ Make_Reference (Loc, Relocate_Node (Func_Call)));
+ end if;
Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
Rewrite (Obj_Decl,
Make_Object_Renaming_Declaration (Obj_Loc,
Defining_Identifier => Make_Temporary (Obj_Loc, 'D'),
- Subtype_Mark => New_Occurrence_Of (Result_Subt, Obj_Loc),
+ Subtype_Mark =>
+ New_Occurrence_Of (Designated_Type, Obj_Loc),
Name => Call_Deref));
Set_Renamed_Object (Defining_Identifier (Obj_Decl), Call_Deref);
(Obj_Decl, Original_Node (Obj_Decl));
end if;
end;
-
- -- If the object entity has a class-wide Etype, then we need to change
- -- it to the result subtype of the function call, because otherwise the
- -- object will be class-wide without an explicit initialization and
- -- won't be allocated properly by the back end. It seems unclean to make
- -- such a revision to the type at this point, and we should try to
- -- improve this treatment when build-in-place functions with class-wide
- -- results are implemented. ???
-
- if Is_Class_Wide_Type (Etype (Defining_Identifier (Obj_Decl))) then
- Set_Etype (Defining_Identifier (Obj_Decl), Result_Subt);
- end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
-------------------------------------------------
-- Start of processing for Unqual_BIP_Iface_Function_Call
begin
+ if Nkind (Expr) = N_Identifier and then No (Entity (Expr)) then
+ -- Can happen for X'Elab_Spec in the binder-generated file.
+ return Empty;
+ end if;
+
return Unqual_BIP_Function_Call (Expr);
end Unqual_BIP_Iface_Function_Call;
-- The returned node is the root of the procedure body which will replace
-- the original function body, which is not needed for the C program.
+ function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-318-02): Returns True if functions returning the type use
+ -- build-in-place protocols. For inherently limited types, this must be
+ -- True in >= Ada 2005, and must be False in Ada 95. For other types, it
+ -- can be True or False, and the decision should be based on efficiency,
+ -- and should be the same for all language versions, so that mixed-dialect
+ -- programs will work.
+ --
+ -- For inherently limited types in Ada 2005, True means that calls will
+ -- actually be build-in-place in all cases. For other types, build-in-place
+ -- will be used when possible, but we need to make a copy at the call site
+ -- in some cases, notably assignment statements.
+
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic
- -- function, or access-to-function type whose result must be built in
- -- place; otherwise returns False. For Ada 2005, this is currently
- -- restricted to the set of functions whose result subtype is an inherently
- -- limited type. In Ada 95, this must be False for inherently limited
- -- result types (but currently returns False for all Ada 95 functions).
- -- Eventually we plan to support build-in-place for nonlimited types.
- -- Build-in-place is usually more efficient for large things, and less
- -- efficient for small things. However, we never use build-in-place if the
- -- convention is other than Ada, because that would disturb mixed-language
- -- programs. Note that for the non-inherently-limited cases, we must make
- -- the same decision for Ada 95 and 2005, so that mixed-dialect programs
- -- will work.
+ -- function, or access-to-function type for which
+ -- Is_Build_In_Place_Result_Type is True. However, we never use
+ -- build-in-place if the convention is other than Ada, because that would
+ -- disturb mixed-language programs.
function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function
- -- that requires handling as a build-in-place call or is a qualified
- -- expression applied to such a call; otherwise returns False.
+ -- that requires handling as a build-in-place call (possibly qualified or
+ -- converted).
function Is_Null_Procedure (Subp : Entity_Id) return Boolean;
-- Predicate to recognize stubbed procedures and null procedures, which
(Obj_Decl : Node_Id;
Function_Call : Node_Id);
-- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
- -- occurs as the expression initializing an object declaration by passsing
+ -- occurs as the expression initializing an object declaration by passing
-- access to the declared object as an additional parameter of the function
-- call. Function_Call must denote an expression containing a BIP function
-- call and an enclosing call to Ada.Tags.Displace to displace the pointer
-- This procedure is called each time a transient block has to be inserted
-- that is to say for each call to a function with unconstrained or tagged
- -- result. It creates a new scope on the stack scope in order to enclose
+ -- result. It creates a new scope on the scope stack in order to enclose
-- all transient variables generated.
procedure Establish_Transient_Scope (N : Node_Id; Sec_Stack : Boolean) is
-- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
-- place function, then a temporary return object needs to be created
- -- and access to it must be passed to the function. Currently we limit
- -- such functions to those with inherently limited result subtypes, but
- -- eventually we plan to expand the functions that are treated as
- -- build-in-place to include other composite result types.
+ -- and access to it must be passed to the function.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Nam)
- then
+ if Is_Build_In_Place_Function_Call (Nam) then
Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
-- Ada 2005 (AI-318-02): Specialization of previous case for renaming
-- containing build-in-place function calls whose returned object covers
-- interface types.
- elsif Ada_Version >= Ada_2005
- and then Present (Unqual_BIP_Iface_Function_Call (Nam))
- then
+ elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
end if;
-- interface conversion, so if this is a BIP call then we need
-- to handle it now.
- if Ada_Version >= Ada_2005
- and then Is_Build_In_Place_Function_Call (Actual)
- then
+ if Is_Build_In_Place_Function_Call (Actual) then
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
end if;
-- Do not process allocations on / deallocations from the secondary
-- stack.
- elsif Is_RTE (Pool_Id, RE_SS_Pool) then
+ elsif Is_RTE (Pool_Id, RE_SS_Pool)
+ or else
+ (Nkind (Expr) = N_Allocator
+ and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool))
+ then
return;
-- Optimize the case where we are using the default Global_Pool_Object,
Call := Prefix (Call);
end if;
+ Call := Unqual_Conv (Call);
+
if Is_Build_In_Place_Function_Call (Call) then
declare
Access_Nam : Name_Id := No_Name;
Param := First (Parameter_Associations (Call));
while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association
- and then Nkind (Selector_Name (Param)) = N_Identifier
- then
+ if Nkind (Param) = N_Parameter_Association then
Formal := Selector_Name (Param);
Actual := Explicit_Actual_Parameter (Param);
-- up. For nested aggregates the expansion is delayed until the enclosing
-- aggregate itself is expanded, e.g. in the context of a declaration. To
-- delay it we set this flag. This is done to avoid creating a temporary
- -- for each level of a nested aggregates, and also to prevent the
+ -- for each level of a nested aggregate, and also to prevent the
-- premature generation of constraint checks. This is also a requirement
- -- if we want to generate the proper attachment to the internal
+ -- if we want to generate the proper attachment to the internal????
-- finalization lists (for record with controlled components). Top down
-- expansion of aggregates is also used for in-place array aggregate
-- assignment or initialization. When the full context is known, the
-- case the front end must generate an extra temporary and initialize
-- this temporary as required (the temporary itself is not atomic).
- -- Note: there is not node kind for object definition. Instead, the
+ -- Note: there is no node kind for object definition. Instead, the
-- corresponding field holds a subtype indication, an array type
-- definition, or (Ada 2005, AI-406) an access definition.
-- Operator Symbol entries. The actual names have an upper case O at the
-- start in place of the Op_ prefix (e.g. the actual name that corresponds
- -- to Name_Op_Abs is "Oabs".
+ -- to Name_Op_Abs is "Oabs").
First_Operator_Name : constant Name_Id := N + $;
Name_Op_Abs : constant Name_Id := N + $; -- "abs"
projects / gcc.git / commitdiff