diff options
Diffstat (limited to 'gcc/ada/exp_ch6.adb')
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 214 |
1 files changed, 89 insertions, 125 deletions
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d48b8f2..23150c7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2729,9 +2729,7 @@ package body Exp_Ch6 is -- Ada 2005 (AI-318-02): If the actual parameter 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 - -- (and ensure that we have an activation chain defined for tasks - -- and a Master variable). + -- to be created and access to it must be passed to the function. -- But do not do it here for intrinsic subprograms since this will -- be done properly after the subprogram is expanded. @@ -2740,11 +2738,6 @@ package body Exp_Ch6 is null; elsif Is_Build_In_Place_Function_Call (Actual) then - if Might_Have_Tasks (Etype (Actual)) then - Build_Activation_Chain_Entity (N); - Build_Master_Entity (Etype (Actual)); - end if; - Make_Build_In_Place_Call_In_Anonymous_Context (Actual); -- Ada 2005 (AI-318-02): Specialization of the previous case for @@ -2752,8 +2745,6 @@ package body Exp_Ch6 is -- object covers interface types. elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then - Build_Activation_Chain_Entity (N); - Build_Master_Entity (Etype (Actual)); Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual); end if; @@ -5713,38 +5704,13 @@ package body Exp_Ch6 is if Nkind (Call_Node) = N_Function_Call and then Needs_Finalization (Etype (Call_Node)) + and then 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 - if 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, Needs_Secondary_Stack (Etype (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) - and then Nkind (Parent (Unqual_Conv (Call_Node))) in - N_Attribute_Reference - | N_Function_Call - | N_Indexed_Component - | N_Object_Renaming_Declaration - | N_Procedure_Call_Statement - | N_Selected_Component - | N_Slice - and then - (Ekind (Current_Scope) /= E_Loop - or else Nkind (Parent (Call_Node)) /= N_Function_Call - or else not - Is_Build_In_Place_Function_Call (Parent (Call_Node))) - then - Establish_Transient_Scope - (Call_Node, Needs_Secondary_Stack (Etype (Call_Node))); - end if; + Expand_Ctrl_Function_Call + (Call_Node, Needs_Secondary_Stack (Etype (Call_Node))); -- Functions returning noncontrolled objects that may be subject to -- user-defined indexing also need special attention. The problem @@ -5933,8 +5899,6 @@ package body Exp_Ch6 is Loc : constant Source_Ptr := Sloc (N); Func_Id : constant Entity_Id := Return_Applies_To (Return_Statement_Entity (N)); - Is_BIP_Func : constant Boolean := - Is_Build_In_Place_Function (Func_Id); Ret_Obj_Id : constant Entity_Id := First_Entity (Return_Statement_Entity (N)); Ret_Obj_Decl : constant Node_Id := Parent (Ret_Obj_Id); @@ -6049,12 +6013,13 @@ package body Exp_Ch6 is -- master. But Move_Activation_Chain updates their master to be that -- of the caller, so they will not be terminated unless the return -- statement completes unsuccessfully due to exception, abort, goto, - -- or exit. As a formality, we test whether the function requires the - -- result to be built in place, though that's necessarily true for - -- the case of result types with task parts. - - if Is_BIP_Func and then Has_Task (Ret_Typ) then + -- or exit. Note that we test that the function is both BIP and has + -- implicit task formal parameters, because not all functions whose + -- result type contains tasks have them (see Needs_BIP_Task_Actuals). + if Is_Build_In_Place_Function (Func_Id) + and then Needs_BIP_Task_Actuals (Func_Id) + then -- The return expression is an aggregate for a complex type which -- contains tasks. This particular case is left unexpanded since -- the regular expansion would insert all temporaries and @@ -6067,7 +6032,7 @@ package body Exp_Ch6 is -- Do not move the activation chain if the return object does not -- contain tasks. - if Has_Task (Etype (Ret_Obj_Id)) then + if Might_Have_Tasks (Etype (Ret_Obj_Id)) then Append_To (Stmts, Move_Activation_Chain (Func_Id)); end if; end if; @@ -6250,9 +6215,9 @@ package body Exp_Ch6 is procedure Prepend_Constructor_Procedure_Prologue (Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id); -- If N is the body of a constructor procedure (that is, a procedure - -- named in a Constructor aspect specification for the type of the - -- procedure's first parameter), then prepend and analyze the - -- associated initialization code for that parameter. + -- named T'Constructor where T is the type of the procedure's first + -- parameter), then prepend and analyze the associated initialization + -- code for that parameter. -- This has nothing to do with CPP constructors. ---------------- @@ -6339,16 +6304,10 @@ package body Exp_Ch6 is function First_Param_Type return Entity_Id is (Implementation_Base_Type (Etype (First_Formal (Spec_Id)))); - Is_Constructor_Procedure : constant Boolean := - Nkind (Specification (N)) = N_Procedure_Specification - and then Present (First_Formal (Spec_Id)) - and then Present (Constructor_Name (First_Param_Type)) - and then Chars (Spec_Id) = Chars (Constructor_Name - (First_Param_Type)) - and then Ekind (First_Formal (Spec_Id)) = E_In_Out_Parameter - and then Scope (Spec_Id) = Scope (First_Param_Type); begin - if not Is_Constructor_Procedure then + if not (Nkind (Specification (N)) = N_Procedure_Specification + and then Is_Constructor (Spec_Id)) + then return; -- the usual case end if; @@ -6539,7 +6498,8 @@ package body Exp_Ch6 is Attribute_Name => Name_Super), Selector_Name => Make_Identifier (Loc, - Chars (Constructor_Name (Parent_Type)))); + Direct_Attribute_Definition_Name + (Parent_Type, Name_Constructor))); begin Set_Is_Prefixed_Call (Proc_Name); @@ -7729,6 +7689,7 @@ package body Exp_Ch6 is if Is_Interface (R_Type) then Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); + Flag_Interface_Pointer_Displacement (Exp); end if; Analyze_And_Resolve (Exp, R_Type); @@ -7807,6 +7768,7 @@ package body Exp_Ch6 is if Is_Interface (R_Type) then Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp))); + Flag_Interface_Pointer_Displacement (Exp); end if; Analyze_And_Resolve (Exp, R_Type); @@ -8001,6 +7963,7 @@ package body Exp_Ch6 is and then Utyp /= Underlying_Type (Exp_Typ) then Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); + Flag_Interface_Pointer_Displacement (Exp); Analyze_And_Resolve (Exp); end if; @@ -9037,9 +9000,9 @@ package body Exp_Ch6 is (Allocator : Node_Id; Function_Call : Node_Id) is - Acc_Type : constant Entity_Id := Etype (Allocator); + Acc_Type : constant Entity_Id := Etype (Allocator); Loc : constant Source_Ptr := Sloc (Function_Call); - Func_Call : Node_Id := Function_Call; + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Ref_Func_Call : Node_Id; Function_Id : Entity_Id; Result_Subt : Entity_Id; @@ -9052,16 +9015,6 @@ package body Exp_Ch6 is Chain : Entity_Id; -- activation chain, in case of tasks begin - -- Step past qualification or unchecked conversion (the latter can occur - -- in cases of calls to 'Input). - - if Nkind (Func_Call) in N_Qualified_Expression - | N_Type_Conversion - | N_Unchecked_Type_Conversion - then - Func_Call := Expression (Func_Call); - end if; - -- Mark the call as processed as a build-in-place call pragma Assert (not Is_Expanded_Build_In_Place_Call (Func_Call)); @@ -9096,27 +9049,6 @@ package body Exp_Ch6 is -- tagged, the called function itself must perform the allocation of -- the return object, so we pass parameters indicating that. - -- But that's also the case when the result subtype needs finalization - -- actions because the caller side allocation may result in undesirable - -- finalization. Consider the following example: - -- - -- function Make_Lim_Ctrl return Lim_Ctrl is - -- begin - -- return Result : Lim_Ctrl := raise Program_Error do - -- null; - -- end return; - -- end Make_Lim_Ctrl; - -- - -- Obj : Lim_Ctrl_Ptr := new Lim_Ctrl'(Make_Lim_Ctrl); - -- - -- Even though the size of limited controlled type Lim_Ctrl is known, - -- allocating Obj at the caller side will chain Obj on Lim_Ctrl_Ptr's - -- finalization collection. The subsequent call to Make_Lim_Ctrl will - -- fail during the initialization actions for Result, which means that - -- Result (and Obj by extension) should not be finalized. However Obj - -- will be finalized when access type Lim_Ctrl_Ptr goes out of scope - -- since it is already attached on the its finalization collection. - if Needs_BIP_Alloc_Form (Function_Id) then Temp_Init := Empty; @@ -9222,6 +9154,7 @@ package body Exp_Ch6 is Rewrite (Ref_Func_Call, OK_Convert_To (Acc_Type, Ref_Func_Call)); + Flag_Interface_Pointer_Displacement (Ref_Func_Call); -- If the types are incompatible, we need an unchecked conversion. Note -- that the full types will be compatible, but the types not visibly @@ -9281,11 +9214,7 @@ package body Exp_Ch6 is end if; end; - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. + -- Add implicit actuals for the BIP formal parameters, if any Add_Unconstrained_Actuals_To_Build_In_Place_Call (Func_Call, @@ -9310,6 +9239,14 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Return_Obj_Actual); + -- If the allocation is done in the caller, create a custom Allocate + -- procedure if need be. + + if not Needs_BIP_Alloc_Form (Function_Id) then + Build_Allocate_Deallocate_Proc + (Declaration_Node (Return_Obj_Access), Mark => Allocator); + end if; + -- Finally, replace the allocator node with a reference to the temp Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); @@ -9331,6 +9268,9 @@ package body Exp_Ch6 is Loc : constant Source_Ptr := Sloc (Function_Call); Func_Call : constant Node_Id := Unqual_Conv (Function_Call); Function_Id : Entity_Id; + Has_Tasks : Boolean; + Known_Size : Boolean; + Needs_Fin : Boolean; Result_Subt : Entity_Id; begin @@ -9357,27 +9297,28 @@ package body Exp_Ch6 is Warn_BIP (Func_Call); Result_Subt := Etype (Function_Id); + Has_Tasks := Might_Have_Tasks (Result_Subt); + Known_Size := Caller_Known_Size (Func_Call, Result_Subt); + Needs_Fin := Needs_Finalization (Result_Subt); -- If the build-in-place function returns a controlled object, then the - -- object needs to be finalized immediately after the context. Since - -- this case produces a transient scope, the servicing finalizer needs - -- to name the returned object. + -- object needs to be finalized immediately after the context is exited, + -- which requires the creation of a transient scope and a named object. -- If the build-in-place function returns a definite subtype, then an -- object also needs to be created and an access value designating it -- passed as an actual. - -- Create a temporary which is initialized with the function call: - -- - -- Temp_Id : Func_Type := BIP_Func_Call; - -- - -- The initialization expression of the temporary will be rewritten by - -- the expander using the appropriate mechanism in Make_Build_In_Place_ - -- Call_In_Object_Declaration. + -- Insert a temporary before the call initialized with function call to + -- reuse the BIP machinery which takes care of adding the extra build-in + -- place actuals. + + if Needs_Fin or else Known_Size or else Has_Tasks then + if Needs_Fin then + Establish_Transient_Scope + (Func_Call, Manage_Sec_Stack => not Known_Size); + end if; - if Needs_Finalization (Result_Subt) - or else Caller_Known_Size (Func_Call, Result_Subt) - then declare Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); Temp_Decl : constant Node_Id := @@ -9389,9 +9330,20 @@ package body Exp_Ch6 is begin Set_Assignment_OK (Temp_Decl); + Expander_Mode_Save_And_Set (False); Insert_Action (Function_Call, Temp_Decl); + Expander_Mode_Restore; + + if Has_Tasks then + Build_Activation_Chain_Entity (Temp_Decl); + Build_Master_Entity (Temp_Id); + end if; + + Make_Build_In_Place_Call_In_Object_Declaration + (Obj_Decl => Temp_Decl, + Function_Call => Expression (Temp_Decl)); + Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); - Analyze (Function_Call); end; -- When the result subtype is unconstrained, the function must allocate @@ -9418,6 +9370,8 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Empty); + Establish_Transient_Scope (Func_Call, Manage_Sec_Stack => True); + -- Mark the call as processed as a build-in-place call Set_Is_Expanded_Build_In_Place_Call (Func_Call); @@ -9771,7 +9725,7 @@ package body Exp_Ch6 is -- ensure that the heap allocation can properly chain the object -- and later finalize it when the library unit goes out of scope. - if Needs_BIP_Collection (Func_Call) then + if Needs_BIP_Collection (Function_Id) then Build_Finalization_Collection (Typ => Ptr_Typ, For_Lib_Level => True, @@ -9990,7 +9944,6 @@ package body Exp_Ch6 is Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call); Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call)); Set_Etype (Anon_Type, Anon_Type); - Build_Class_Wide_Master (Anon_Type); Tmp_Decl := Make_Object_Declaration (Loc, @@ -10014,6 +9967,9 @@ package body Exp_Ch6 is Insert_Action (Allocator, Tmp_Decl); Expander_Mode_Restore; + Build_Master_Entity (Anon_Type); + Build_Master_Renaming (Anon_Type); + Make_Build_In_Place_Call_In_Allocator (Allocator => Expression (Tmp_Decl), Function_Call => Expression (Expression (Tmp_Decl))); @@ -10024,6 +9980,7 @@ package body Exp_Ch6 is Rewrite (Allocator, Convert_To (Etype (Allocator), New_Occurrence_Of (Tmp_Id, Loc))); + Flag_Interface_Pointer_Displacement (Allocator); end Make_Build_In_Place_Iface_Call_In_Allocator; --------------------------------------------------------- @@ -10067,9 +10024,14 @@ package body Exp_Ch6 is Insert_Action (Function_Call, Tmp_Decl); Expander_Mode_Restore; + Build_Activation_Chain_Entity (Tmp_Decl); + Build_Master_Entity (Tmp_Id); + Make_Build_In_Place_Iface_Call_In_Object_Declaration (Obj_Decl => Tmp_Decl, Function_Call => Expression (Tmp_Decl)); + + Rewrite (Function_Call, New_Occurrence_Of (Tmp_Id, Loc)); end Make_Build_In_Place_Iface_Call_In_Anonymous_Context; ---------------------------------------------------------- @@ -10177,7 +10139,7 @@ package body Exp_Ch6 is pragma Assert (Nkind (Allocator) = N_Allocator and then Nkind (Function_Call) = N_Function_Call); pragma Assert (Convention (Function_Id) = Convention_CPP - and then Is_Constructor (Function_Id)); + and then Is_CPP_Constructor (Function_Id)); pragma Assert (Is_Constrained (Underlying_Type (Result_Subt))); -- Replace the initialized allocator of form "new T'(Func (...))" with @@ -10241,6 +10203,7 @@ package body Exp_Ch6 is if Is_Interface (Designated_Type (Acc_Type)) then Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator))); + Flag_Interface_Pointer_Displacement (Allocator); end if; Analyze_And_Resolve (Allocator, Acc_Type); @@ -10334,6 +10297,12 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin + -- No need for BIP_Collection if allocation is always done in the caller + + if not Needs_BIP_Alloc_Form (Func_Id) then + return False; + end if; + -- A formal for the finalization collection is needed for build-in-place -- functions whose result type needs finalization or is a tagged type. -- Tagged primitive build-in-place functions need such a formal because @@ -10358,12 +10327,6 @@ package body Exp_Ch6 is Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); begin - -- See Make_Build_In_Place_Call_In_Allocator for the rationale - - if Needs_BIP_Collection (Func_Id) then - return True; - end if; - -- A formal giving the allocation method is needed for build-in-place -- functions whose result type is returned on the secondary stack or -- is a tagged type. Tagged primitive build-in-place functions need @@ -10592,8 +10555,9 @@ package body Exp_Ch6 is begin pragma Assert (Check_BIP_Actuals (Call_Node, Subp)); - -- Build-in-place function calls return their result by - -- reference. + + -- Build-in-place function calls return their result by + -- reference. pragma Assert (not Is_Build_In_Place_Function (Subp) or else Returns_By_Ref (Subp)); |