First cut at build-in-place for nonlimited types. This is a work in progress; the build-in-place support is currently disabled.
Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-29 Bob Duff <d...@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.
Index: exp_aggr.adb =================================================================== --- exp_aggr.adb (revision 253285) +++ exp_aggr.adb (working copy) @@ -175,6 +175,10 @@ -- 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; @@ -186,10 +190,9 @@ -- 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; @@ -762,10 +765,10 @@ -- 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 @@ -1347,7 +1350,7 @@ 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 @@ -2831,7 +2834,7 @@ 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 @@ -2967,7 +2970,10 @@ -- [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), @@ -3229,13 +3235,9 @@ -- 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). + -- function call (possibly qualified) 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. - elsif Is_Limited_Type (Etype (Ancestor)) and then Nkind_In (Unqualify (Ancestor), N_Aggregate, N_Extension_Aggregate) @@ -3330,6 +3332,7 @@ 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 @@ -3351,6 +3354,10 @@ 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 @@ -4073,10 +4080,7 @@ 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 @@ -4121,6 +4125,25 @@ -- 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; @@ -4134,6 +4157,7 @@ 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)); @@ -4141,10 +4165,9 @@ 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); @@ -4152,8 +4175,9 @@ 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; @@ -4195,11 +4219,7 @@ -- 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; @@ -4214,7 +4234,7 @@ -- 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 @@ -6111,8 +6131,7 @@ -- 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 @@ -6251,7 +6270,7 @@ 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); @@ -6646,13 +6665,13 @@ -- 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); @@ -6709,7 +6728,7 @@ 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 @@ -6722,7 +6741,7 @@ -- 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 @@ -6741,6 +6760,9 @@ -- 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. @@ -7043,7 +7065,7 @@ -- 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; @@ -7110,17 +7132,17 @@ 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); @@ -7130,7 +7152,7 @@ -- 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 @@ -7139,7 +7161,7 @@ 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 @@ -7156,36 +7178,36 @@ 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 @@ -7199,15 +7221,15 @@ 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 -- @@ -7297,7 +7319,7 @@ -- 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. @@ -7314,7 +7336,7 @@ 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); @@ -7349,7 +7371,7 @@ -- 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 Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 253288) +++ exp_ch5.adb (working copy) @@ -2390,13 +2390,13 @@ 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) Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 253283) +++ exp_ch6.adb (working copy) @@ -2252,6 +2252,9 @@ 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; @@ -4327,29 +4330,30 @@ -- 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; @@ -4756,6 +4760,12 @@ 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'); @@ -4781,8 +4791,7 @@ -- 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) @@ -6385,8 +6394,8 @@ 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> @@ -6414,9 +6423,13 @@ -- 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 @@ -6494,7 +6507,7 @@ -- 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; @@ -7186,6 +7199,24 @@ 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 -- -------------------------------- @@ -7216,20 +7247,10 @@ -- 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; + return Is_Build_In_Place_Result_Type (Etype (E)) + and then not Has_Foreign_Convention (E) + and then not Debug_Flag_Dot_L; - -- 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; - else return False; end if; @@ -7256,34 +7277,33 @@ -- 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; + if Is_Entity_Name (Name (Exp_Node)) then + Function_Id := Entity (Name (Exp_Node)); - else - 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; - else - raise Program_Error; - end if; - - return Is_Build_In_Place_Function (Function_Id); - end if; + declare + Result : constant Boolean := Is_Build_In_Place_Function (Function_Id); + begin + return Result; + end; end Is_Build_In_Place_Function_Call; ----------------------- @@ -7693,16 +7713,9 @@ 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); @@ -7727,6 +7740,8 @@ 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 @@ -7738,7 +7753,6 @@ -- 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 @@ -8051,7 +8065,7 @@ 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; @@ -8060,20 +8074,11 @@ 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)); @@ -8131,6 +8136,13 @@ 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); @@ -8165,6 +8177,7 @@ 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; @@ -8172,16 +8185,9 @@ 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 @@ -8208,6 +8214,15 @@ -- 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, @@ -8216,7 +8231,7 @@ 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 @@ -8238,15 +8253,10 @@ -- 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 @@ -8424,13 +8434,25 @@ 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); @@ -8475,7 +8497,8 @@ 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); @@ -8495,18 +8518,6 @@ (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; ------------------------------------------------- @@ -9225,6 +9236,11 @@ -- 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; Index: exp_ch6.ads =================================================================== --- exp_ch6.ads (revision 253283) +++ exp_ch6.ads (working copy) @@ -117,25 +117,30 @@ -- 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 @@ -212,7 +217,7 @@ (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 Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 253283) +++ exp_ch7.adb (working copy) @@ -4057,7 +4057,7 @@ -- 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 Index: exp_util.adb =================================================================== --- exp_util.adb (revision 253283) +++ exp_util.adb (working copy) @@ -649,7 +649,11 @@ -- 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, @@ -7857,6 +7861,8 @@ 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; @@ -8679,9 +8685,7 @@ 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); Index: exp_ch8.adb =================================================================== --- exp_ch8.adb (revision 253283) +++ exp_ch8.adb (working copy) @@ -176,23 +176,16 @@ -- 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; Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 253283) +++ snames.ads-tmpl (working copy) @@ -328,7 +328,7 @@ -- 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" Index: exp_attr.adb =================================================================== --- exp_attr.adb (revision 253283) +++ exp_attr.adb (working copy) @@ -1753,23 +1753,16 @@ -- 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; Index: sinfo.ads =================================================================== --- sinfo.ads (revision 253283) +++ sinfo.ads (working copy) @@ -1372,9 +1372,9 @@ -- 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 @@ -2917,7 +2917,7 @@ -- 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. Index: exp_disp.adb =================================================================== --- exp_disp.adb (revision 253283) +++ exp_disp.adb (working copy) @@ -1640,9 +1640,7 @@ -- 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; Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 253283) +++ exp_ch3.adb (working copy) @@ -6299,9 +6299,7 @@ -- 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 @@ -6317,9 +6315,7 @@ -- 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 @@ -6617,13 +6613,19 @@ -- 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 Needs_Finalization (Typ) + 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; + + elsif Needs_Finalization (Typ) and then not Is_Limited_View (Typ) and then not Rewrite_As_Renaming then @@ -6755,9 +6757,9 @@ 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 ??? Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 253283) +++ exp_ch4.adb (working copy) @@ -793,14 +793,9 @@ -- 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; @@ -812,9 +807,7 @@ -- 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; @@ -1223,14 +1216,9 @@ -- 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; @@ -6572,18 +6560,14 @@ -- 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; @@ -10221,18 +10205,14 @@ -- 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; @@ -10587,18 +10567,14 @@ -- 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; Index: debug.adb =================================================================== --- debug.adb (revision 253283) +++ debug.adb (working copy) @@ -163,7 +163,7 @@ -- 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) @@ -820,6 +820,9 @@ -- 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 -- ------------------------------------------