From: Eric Botcazou <ebotca...@adacore.com> This implements elision of the copy operation for extended return statements in the case of nonlimited by-reference types (the copy operation is already elided for limited types by the front-end and nonlimited non-by-reference types by the code generator), which comprise controlled and tagged types.
The implementation partly reuses the machinery implemented for limited types (the build-in-place machinery) to allocate the return object directly on the primary or the secondary stack, depending on whether the result type of the function is constrained or not. This requires further special-casing for the allocators generated by this machinery as well as an adjustment to the implementation of a specific case of string concatenation. gcc/ada/ * einfo.ads (Actual_Subtype): Document additional usage. * exp_aggr.adb (Expand_Array_Aggregate): Replace test on Is_Build_In_Place_Return_Object with Is_Special_Return_Object. * exp_ch3.adb (Expand_N_Object_Declaration): Factor out parts of the processing done for build-in-place return objects and reuse them to implement a similar processing for specific return objects. * exp_ch4.adb (Expand_Allocator_Expression): Do not generate a tag assignment or an adjustment if the allocator was made for a special return object. (Expand_Concatenate): If the result is allocated on the secondary stack, use an unconstrained allocation. * exp_ch6.ads (Apply_CW_Accessibility_Check): New declaration. (Is_By_Reference_Return_Object): Likewise. (Is_Secondary_Stack_Return_Object): Likewise. (Is_Special_Return_Object): Likewise. * exp_ch6.adb (Expand_Ctrl_Function_Call): Do not bail out for the expression in the declaration of a special return object. (Expand_N_Extended_Return_Statement): Add missing guard and move the class-wide accessibility check to Expand_N_Object_Declaration. (Expand_Simple_Function_Return): Delete obsolete commentary. Skip the special processing for types that require finalization or are returned on the secondary stack if the return originally comes from an extended return statement. Add missing Constant_Present. (Is_By_Reference_Return_Object): New predicate. (Is_Secondary_Stack_Return_Object): Likewise. (Is_Special_Return_Object): Likewise. * exp_util.adb (Is_Related_To_Func_Return): Also return true if the parent of the expression is the renaming declaration generated for the expansion of a return object. * gen_il-fields.ads (Opt_Field_Enum): Replace Alloc_For_BIP_Return with For_Special_Return_Object. * gen_il-gen-gen_nodes.adb (N_Allocator): Likewise. * gen_il-internals.adb (Image): Remove Alloc_For_BIP_Return. * sem_ch3.adb (Check_Return_Subtype_Indication): New procedure moved from sem_ch6.adb. (Analyze_Object_Declaration): Call it on a return object. * sem_ch4.adb: Add with and use clauses for Rtsfind. (Analyze_Allocator): Test For_Special_Return_Object to skip checks for allocators made for special return objects. Do not report restriction violations for the return stack pool. * sem_ch5.adb (Analyze_Assignment.Set_Assignment_Type): Return the Actual_Subtype for return objects that live on the secondary stack. * sem_ch6.adb (Check_Return_Subtype_Indication): Move procedure to sem_ch3.adb. (Analyze_Function_Return): Do not call above procedure. * sem_res.adb (Resolve_Allocator): Replace Alloc_For_BIP_Return with For_Special_Return_Object. * sinfo.ads: Likewise. * treepr.adb (Image): Remove Alloc_For_BIP_Return. * gcc-interface/trans.cc (gnat_to_gnu): Do not convert to the result type in the unconstrained array type case if the parent is a simple return statement. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/einfo.ads | 8 +- gcc/ada/exp_aggr.adb | 2 +- gcc/ada/exp_ch3.adb | 468 +++++++++++++++++++++++-------- gcc/ada/exp_ch4.adb | 126 +++++---- gcc/ada/exp_ch6.adb | 101 ++++--- gcc/ada/exp_ch6.ads | 27 +- gcc/ada/exp_util.adb | 6 +- gcc/ada/gcc-interface/trans.cc | 12 +- gcc/ada/gen_il-fields.ads | 2 +- gcc/ada/gen_il-gen-gen_nodes.adb | 2 +- gcc/ada/gen_il-internals.adb | 2 - gcc/ada/sem_ch3.adb | 139 +++++++++ gcc/ada/sem_ch4.adb | 64 ++--- gcc/ada/sem_ch5.adb | 6 +- gcc/ada/sem_ch6.adb | 135 --------- gcc/ada/sem_res.adb | 2 +- gcc/ada/sinfo.ads | 10 +- gcc/ada/treepr.adb | 5 +- 18 files changed, 706 insertions(+), 411 deletions(-) diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 2a1a406850e..d71dcaf8969 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -358,9 +358,11 @@ package Einfo is -- -- For objects, the Actual_Subtype is set only if this is a discriminated -- type. For arrays, the bounds of the expression are obtained and the --- Etype of the object is directly the constrained subtype. This is --- rather irregular, and the semantic checks that depend on the nominal --- subtype being unconstrained use flag Is_Constr_Subt_For_U_Nominal(qv). +-- Etype of the object is directly the constrained subtype, except in the +-- case of a return object that lives on the secondary stack where Etype +-- is the nominal unconstrained subtype. This is rather irregular and the +-- semantic checks that depend on the nominal subtype being unconstrained +-- use flag Is_Constr_Subt_For_U_Nominal(qv). -- Address_Clause (synthesized) -- Applies to entries, objects and subprograms. Set if an address clause diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3f51ed6b457..4d8bb817b80 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6841,7 +6841,7 @@ package body Exp_Aggr is or else Parent_Kind = N_Component_Association or else (Parent_Kind = N_Object_Declaration and then (Needs_Finalization (Typ) - or else Is_Build_In_Place_Return_Object + or else Is_Special_Return_Object (Defining_Identifier (Parent_Node)))) or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 5050ec6eab5..6de5843b4ba 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6289,6 +6289,18 @@ package body Exp_Ch3 is -- Generate all default initialization actions for object Def_Id. Any -- new code is inserted after node After. + procedure Initialize_Return_Object + (Tag_Assign : Node_Id; + Adj_Call : Node_Id; + Expr : Node_Id; + Init_Stmt : Node_Id; + After : Node_Id); + -- Generate all initialization actions for return object Def_Id. Any + -- new code is inserted after node After. + + function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id; + -- Make an allocator for a return object initialized with Expr + function OK_To_Rename_Ref (N : Node_Id) return Boolean; -- Return True if N denotes an entity with OK_To_Rename set @@ -7047,6 +7059,108 @@ package body Exp_Ch3 is end if; end Default_Initialize_Object; + ------------------------------ + -- Initialize_Return_Object -- + ------------------------------ + + procedure Initialize_Return_Object + (Tag_Assign : Node_Id; + Adj_Call : Node_Id; + Expr : Node_Id; + Init_Stmt : Node_Id; + After : Node_Id) + is + begin + if Present (Tag_Assign) then + Insert_Action_After (After, Tag_Assign); + end if; + + if Present (Adj_Call) then + Insert_Action_After (After, Adj_Call); + end if; + + if No (Expr) then + Default_Initialize_Object (After); + + elsif Is_Delayed_Aggregate (Expr) + and then not No_Initialization (N) + then + Convert_Aggr_In_Object_Decl (N); + + elsif Present (Init_Stmt) then + Insert_Action_After (After, Init_Stmt); + Set_Expression (N, Empty); + end if; + end Initialize_Return_Object; + + ------------------------------- + -- Make_Allocator_For_Return -- + ------------------------------- + + function Make_Allocator_For_Return (Expr : Node_Id) return Node_Id is + Func_Id : constant Entity_Id := Return_Applies_To (Scope (Def_Id)); + + Alloc : Node_Id; + + begin + -- If the return object's declaration includes an expression and the + -- declaration isn't marked as No_Initialization, then we generate an + -- allocator with a qualified expression. Although this is necessary + -- only in the case where the result type is an interface (or class- + -- wide interface), we do it in all cases for the sake of consistency + -- instead of subsequently generating a separate assignment. + + if Present (Expr) + and then not Is_Delayed_Aggregate (Expr) + and then not No_Initialization (N) + then + -- Ada 2005 (AI95-344): If the result type is class-wide, insert + -- a check that the level of the return expression's underlying + -- type is not deeper than the level of the master enclosing the + -- function. + + -- AI12-043: The check is made immediately after the return object + -- is created. + + if Is_Class_Wide_Type (Etype (Func_Id)) then + Apply_CW_Accessibility_Check (Expr, Func_Id); + end if; + + -- We always use the type of the expression for the qualified + -- expression, rather than the return object's type. We cannot + -- always use the return object's type because the expression + -- might be of a specific type and the result object mignt not. + + Alloc := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Occurrence_Of (Etype (Expr), Loc), + Expression => New_Copy_Tree (Expr))); + + else + Alloc := + Make_Allocator (Loc, + Expression => New_Occurrence_Of (Typ, Loc)); + + -- If the return object requires default initialization, then it + -- will happen later following the elaboration of the renaming. + -- If we don't turn it off here, then the object will be default + -- initialized twice. + + Set_No_Initialization (Alloc); + end if; + + -- Set the flag indicating that the allocator is made for a special + -- return object. This is used to bypass various legality checks as + -- well as to make sure that the result is not adjusted twice. + + Set_For_Special_Return_Object (Alloc); + + return Alloc; + end Make_Allocator_For_Return; + ---------------------- -- OK_To_Rename_Ref -- ---------------------- @@ -7060,10 +7174,9 @@ package body Exp_Ch3 is -- Local variables - Adj_Call : Node_Id; - Expr_Q : Node_Id; - Id_Ref : Node_Id; - Tag_Assign : Node_Id; + Adj_Call : Node_Id := Empty; + Expr_Q : Node_Id := Empty; + Tag_Assign : Node_Id := Empty; Init_After : Node_Id := N; -- Node after which the initialization actions are to be inserted. This @@ -7172,8 +7285,6 @@ package body Exp_Ch3 is -- Default initialization required, and no expression present if No (Expr) then - Expr_Q := Expr; - -- If we have a type with a variant part, the initialization proc -- will contain implicit tests of the discriminant values, which -- counts as a violation of the restriction No_Implicit_Conditionals. @@ -7232,7 +7343,7 @@ package body Exp_Ch3 is end if; end if; - if not Is_Build_In_Place_Return_Object (Def_Id) then + if not Is_Special_Return_Object (Def_Id) then Default_Initialize_Object (Init_After); end if; @@ -7292,7 +7403,7 @@ package body Exp_Ch3 is Expander_Mode_Restore; end if; - if not Is_Build_In_Place_Return_Object (Def_Id) then + if not Is_Special_Return_Object (Def_Id) then Convert_Aggr_In_Object_Decl (N); end if; @@ -7363,12 +7474,12 @@ package body Exp_Ch3 is then pragma Assert (Is_Class_Wide_Type (Typ)); - -- If the object is a built-in-place return object, bypass special + -- If the object is a special return object, then bypass special -- treatment of class-wide interface initialization below. In this -- case, the expansion of the return statement will take care of -- creating the object (via allocator) and initializing it. - if Is_Build_In_Place_Return_Object (Def_Id) then + if Is_Special_Return_Object (Def_Id) then null; elsif Tagged_Type_Expansion then @@ -7668,8 +7779,7 @@ package body Exp_Ch3 is if Present (Tag_Assign) then if Present (Following_Address_Clause (N)) then Ensure_Freeze_Node (Def_Id); - - else + elsif not Is_Special_Return_Object (Def_Id) then Insert_Action_After (Init_After, Tag_Assign); end if; @@ -7679,23 +7789,26 @@ package body Exp_Ch3 is -- record type. elsif Is_CPP_Constructor_Call (Expr) then + declare + Id_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); - -- The call to the initialization procedure does NOT freeze the - -- object being initialized. + begin + -- The call to the initialization procedure does NOT freeze + -- the object being initialized. - Id_Ref := New_Occurrence_Of (Def_Id, Loc); - Set_Must_Not_Freeze (Id_Ref); - Set_Assignment_OK (Id_Ref); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); - Insert_Actions_After (Init_After, - Build_Initialization_Call (Loc, Id_Ref, Typ, - Constructor_Ref => Expr)); + Insert_Actions_After (Init_After, + Build_Initialization_Call (Loc, Id_Ref, Typ, + Constructor_Ref => Expr)); - -- We remove here the original call to the constructor - -- to avoid its management in the backend + -- We remove here the original call to the constructor + -- to avoid its management in the backend - Set_Expression (N, Empty); - return; + Set_Expression (N, Empty); + return; + end; -- Handle initialization of limited tagged types @@ -7735,18 +7848,15 @@ package body Exp_Ch3 is then Set_Is_Known_Valid (Def_Id); - elsif Is_Access_Type (Typ) then - - -- For access types set the Is_Known_Non_Null flag if the - -- initializing value is known to be non-null. We can also set - -- Can_Never_Be_Null if this is a constant. + -- For access types, set the Is_Known_Non_Null flag if the + -- initializing value is known to be non-null. We can also + -- set Can_Never_Be_Null if this is a constant. - if Known_Non_Null (Expr) then - Set_Is_Known_Non_Null (Def_Id, True); + elsif Is_Access_Type (Typ) and then Known_Non_Null (Expr) then + Set_Is_Known_Non_Null (Def_Id, True); - if Constant_Present (N) then - Set_Can_Never_Be_Null (Def_Id); - end if; + if Constant_Present (N) then + Set_Can_Never_Be_Null (Def_Id); end if; end if; @@ -7762,6 +7872,7 @@ package body Exp_Ch3 is and then not Is_Generic_Type (Typ) then Ensure_Valid (Expr); + if Safe_To_Capture_Value (N, Def_Id) then Set_Is_Known_Valid (Def_Id); end if; @@ -7839,10 +7950,9 @@ package body Exp_Ch3 is Obj_Ref => New_Occurrence_Of (Def_Id, Loc), Typ => Base_Typ); - -- Guard against a missing [Deep_]Adjust when the base type - -- was not properly frozen. - - if Present (Adj_Call) then + if Present (Adj_Call) + and then not Is_Special_Return_Object (Def_Id) + then Insert_Action_After (Init_After, Adj_Call); end if; end if; @@ -8092,78 +8202,12 @@ package body Exp_Ch3 is -- an unconstrained array on the heap. In this case the -- result object's type is a constrained array type even -- though the function's type is unconstrained. + Obj_Alloc_Formal : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Alloc_Form); Pool_Id : constant Entity_Id := Make_Temporary (Loc, 'P'); - function Make_Allocator_For_BIP_Return return Node_Id; - -- Make an allocator for the BIP return being processed - - ----------------------------------- - -- Make_Allocator_For_BIP_Return -- - ----------------------------------- - - function Make_Allocator_For_BIP_Return return Node_Id is - Alloc : Node_Id; - - begin - if Present (Expr_Q) - and then not Is_Delayed_Aggregate (Expr_Q) - and then not No_Initialization (N) - then - -- Always use the type of the expression for the - -- qualified expression, rather than the result type. - -- In general we cannot always use the result type - -- for the allocator, because the expression might be - -- of a specific type, such as in the case of an - -- aggregate or even a nonlimited object when the - -- result type is a limited class-wide interface type. - - Alloc := - Make_Allocator (Loc, - Expression => - Make_Qualified_Expression (Loc, - Subtype_Mark => - New_Occurrence_Of (Etype (Expr_Q), Loc), - Expression => New_Copy_Tree (Expr_Q))); - - else - -- If the function returns a class-wide type we cannot - -- use the return type for the allocator. Instead we - -- use the type of the expression, which must be an - -- aggregate of a definite type. - - if Is_Class_Wide_Type (Typ) then - Alloc := - Make_Allocator (Loc, - Expression => - New_Occurrence_Of (Etype (Expr_Q), Loc)); - - else - Alloc := - Make_Allocator (Loc, - Expression => - New_Occurrence_Of (Typ, Loc)); - end if; - - -- If the object requires default initialization then - -- that will happen later following the elaboration of - -- the object renaming. If we don't turn it off here - -- then the object will be default initialized twice. - - Set_No_Initialization (Alloc); - end if; - - -- Set the flag indicating that the allocator came from - -- a build-in-place return statement, so we can avoid - -- adjusting the allocated object. - - Set_Alloc_For_BIP_Return (Alloc); - - return Alloc; - end Make_Allocator_For_BIP_Return; - Acc_Typ : Entity_Id; Alloc_Obj_Decl : Node_Id; Alloc_Obj_Id : Entity_Id; @@ -8209,13 +8253,13 @@ package body Exp_Ch3 is -- First create the Heap_Allocator - Heap_Allocator := Make_Allocator_For_BIP_Return; + Heap_Allocator := Make_Allocator_For_Return (Expr_Q); -- The Pool_Allocator is just like the Heap_Allocator, -- except we set Storage_Pool and Procedure_To_Call so -- it will use the user-defined storage pool. - Pool_Allocator := Make_Allocator_For_BIP_Return; + Pool_Allocator := Make_Allocator_For_Return (Expr_Q); -- Do not generate the renaming of the build-in-place -- pool parameter on ZFP because the parameter is not @@ -8256,7 +8300,7 @@ package body Exp_Ch3 is -- allocation. else - SS_Allocator := Make_Allocator_For_BIP_Return; + SS_Allocator := Make_Allocator_For_Return (Expr_Q); -- The heap and pool allocators are marked as -- Comes_From_Source since they correspond to an @@ -8427,7 +8471,10 @@ package body Exp_Ch3 is -- From now on, the type of the return object is the -- designated type. - Set_Etype (Def_Id, Desig_Typ); + if Desig_Typ /= Typ then + Set_Etype (Def_Id, Desig_Typ); + Set_Actual_Subtype (Def_Id, Typ); + end if; -- Remember the local access object for use in the -- dereference of the renaming created below. @@ -8474,6 +8521,7 @@ package body Exp_Ch3 is Alloc_Obj_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Alloc_Obj_Id, + Constant_Present => True, Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), Expression => @@ -8492,25 +8540,207 @@ package body Exp_Ch3 is -- Initialize the object now that it has got its final subtype, -- but before rewriting it as a renaming. - if No (Expr_Q) then - Default_Initialize_Object (Init_After); + Initialize_Return_Object + (Tag_Assign, Adj_Call, Expr_Q, Init_Stmt, Init_After); - elsif Is_Delayed_Aggregate (Expr_Q) - and then not No_Initialization (N) - then - Convert_Aggr_In_Object_Decl (N); + -- Replace the return object declaration with a renaming of a + -- dereference of the access value designating the return object. - elsif Present (Init_Stmt) then - Insert_Action_After (Init_After, Init_Stmt); - Set_Expression (N, Empty); + Expr_Q := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); + Set_Etype (Expr_Q, Etype (Def_Id)); + + Rewrite_As_Renaming := True; + end; + + -- If we can rename the initialization expression, we need to make sure + -- that we use the proper type in the case of a return object that lives + -- on the secondary stack. See other cases below for a similar handling. + + elsif Rewrite_As_Renaming then + if Is_Secondary_Stack_Return_Object (Def_Id) then + declare + Func_Id : constant Entity_Id := + Return_Applies_To (Scope (Def_Id)); + + Desig_Typ : constant Entity_Id := + (if Ekind (Typ) = E_Array_Subtype + then Etype (Func_Id) else Typ); + + begin + -- From now on, the type of the return object is the + -- designated type. + + if Desig_Typ /= Typ then + Set_Etype (Def_Id, Desig_Typ); + Set_Actual_Subtype (Def_Id, Typ); + end if; + end; + end if; + + -- If this is the return object of a function returning on the secondary + -- stack, convert the declaration to a renaming of the dereference of ah + -- allocator for the secondary stack. + + -- Result : T [:= <expression>]; + + -- is converted to + + -- type Txx is access all ...; + -- Rxx : constant Txx := + -- new <expression-type>['(<expression>)][storage_pool = + -- system__secondary_stack__ss_pool][procedure_to_call = + -- system__secondary_stack__ss_allocate]; + + -- Result : T renames Rxx.all; + + elsif Is_Secondary_Stack_Return_Object (Def_Id) then + declare + Func_Id : constant Entity_Id := + Return_Applies_To (Scope (Def_Id)); + + Desig_Typ : constant Entity_Id := + (if Ekind (Typ) = E_Array_Subtype + then Etype (Func_Id) else Typ); + -- Ensure that the we use a fat pointer when allocating + -- an unconstrained array on the heap. In this case the + -- result object's type is a constrained array type even + -- though the function's type is unconstrained. + + Acc_Typ : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Alloc_Obj_Id : Entity_Id; + Ptr_Type_Decl : Node_Id; + + begin + -- Create an access type designating the function's + -- result subtype. + + Acc_Typ := Make_Temporary (Loc, 'A'); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Desig_Typ, Loc))); + + Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks); + + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Acc_Typ, Loc), + Expression => Make_Allocator_For_Return (Expr_Q)); + + Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); + + Set_Uses_Sec_Stack (Func_Id); + Set_Uses_Sec_Stack (Scope (Def_Id)); + Set_Sec_Stack_Needed_For_Return (Scope (Def_Id)); + + -- From now on, the type of the return object is the + -- designated type. + + if Desig_Typ /= Typ then + Set_Etype (Def_Id, Desig_Typ); + Set_Actual_Subtype (Def_Id, Typ); end if; + -- Initialize the object now that it has got its final subtype, + -- but before rewriting it as a renaming. + + Initialize_Return_Object + (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After); + -- Replace the return object declaration with a renaming of a -- dereference of the access value designating the return object. Expr_Q := Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Obj_Acc_Formal, Loc)); + Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)); + Set_Etype (Expr_Q, Etype (Def_Id)); + + Rewrite_As_Renaming := True; + end; + + -- If this is the return object of a function returning a by-reference + -- type, convert the declaration to a renaming of the dereference of ah + -- allocator for the return stack. + + -- Result : T [:= <expression>]; + + -- is converted to + + -- type Txx is access all ...; + -- Rxx : constant Txx := + -- new <expression-type>['(<expression>)][storage_pool = + -- system__secondary_stack__rs_pool][procedure_to_call = + -- system__secondary_stack__rs_allocate]; + + -- Result : T renames Rxx.all; + + elsif Back_End_Return_Slot + and then Is_By_Reference_Return_Object (Def_Id) + then + declare + Acc_Typ : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Alloc_Obj_Id : Entity_Id; + Ptr_Type_Decl : Node_Id; + + begin + -- Create an access type designating the function's + -- result subtype. + + Acc_Typ := Make_Temporary (Loc, 'A'); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Occurrence_Of (Typ, Loc))); + + Insert_Action (N, Ptr_Type_Decl, Suppress => All_Checks); + + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_RS_Pool)); + + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Acc_Typ, Loc), + Expression => Make_Allocator_For_Return (Expr_Q)); + + Insert_Action (N, Alloc_Obj_Decl, Suppress => All_Checks); + + -- Initialize the object now that it has got its final subtype, + -- but before rewriting it as a renaming. + + Initialize_Return_Object + (Tag_Assign, Adj_Call, Expr_Q, Empty, Init_After); + + -- Replace the return object declaration with a renaming of a + -- dereference of the access value designating the return object. + + Expr_Q := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Alloc_Obj_Id, Loc)); Set_Etype (Expr_Q, Etype (Def_Id)); Rewrite_As_Renaming := True; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7edef4c39c3..a8980a63d46 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -898,6 +898,11 @@ package body Exp_Ch4 is (Directly_Designated_Type (Etype (N)))); null; + -- Likewise if the allocator is made for a special return object + + elsif For_Special_Return_Object (N) then + null; + elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then TagT := T; TagR := @@ -946,19 +951,18 @@ package body Exp_Ch4 is -- Adjust procedure, and the object is built in place. In Ada 95, the -- object can be limited but not inherently limited if this allocator -- came from a return statement (we're allocating the result on the - -- secondary stack). In that case, the object will be moved, so we do - -- want to Adjust. However, if it's a nonlimited build-in-place - -- function call, Adjust is not wanted. - -- - -- Needs_Finalization (DesigT) can differ from Needs_Finalization (T) + -- secondary stack); in that case, the object will be moved, so we do + -- want to Adjust. But the call is always skipped if the allocator is + -- made for a special return object because it's generated elsewhere. + + -- Needs_Finalization (DesigT) may differ from Needs_Finalization (T) -- if one of the two types is class-wide, and the other is not. if Needs_Finalization (DesigT) and then Needs_Finalization (T) and then not Aggr_In_Place and then not Is_Limited_View (T) - and then not Alloc_For_BIP_Return (N) - and then not Is_Build_In_Place_Function_Call (Expression (N)) + and then not For_Special_Return_Object (N) then -- An unchecked conversion is needed in the classwide case because -- the designated type can be an ancestor of the subtype mark of @@ -2724,6 +2728,7 @@ package body Exp_Ch4 is Len : Unat; J : Nat; Clen : Node_Id; + Decl : Node_Id; Set : Boolean; -- Start of processing for Expand_Concatenate @@ -3250,10 +3255,32 @@ package body Exp_Ch4 is Set_Is_Internal (Ent); Set_Debug_Info_Needed (Ent); + -- If the bound is statically known to be out of range, we do not want + -- to abort, we want a warning and a constraint error at run time. Note + -- that we have arranged that the result will not be treated as a static + -- constant, so we won't get an illegality during the insertion. We also + -- enable all checks (in particular range checks) in case the bounds of + -- Subtyp_Ind are out of range. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => Subtyp_Ind); + Insert_Action (Cnode, Decl); + + -- If the result of the concatenation appears as the initializing + -- expression of an object declaration, we can just rename the + -- result, rather than copying it. + + Set_OK_To_Rename (Ent); + -- If we are concatenating strings and the current scope already uses - -- the secondary stack, allocate the resulting string also on the - -- secondary stack to avoid putting too much pressure on the primary - -- stack. + -- the secondary stack, allocate the result also on the secondary stack + -- to avoid putting too much pressure on the primary stack. + + -- We use an unconstrained allocation, i.e. we also allocate the bounds, + -- so that the result can be renamed in all contexts. + -- Don't do this if -gnatd.h is set, as this will break the wrapping of -- Cnode in an Expression_With_Actions, see Expand_N_Op_Concat. @@ -3263,84 +3290,77 @@ package body Exp_Ch4 is and then not Debug_Flag_Dot_H then -- Generate: - -- subtype Axx is ...; - -- type Ayy is access Axx; - -- Rxx : Ayy := new <subtype> [storage_pool = ss_pool]; - -- Sxx : <subtype> renames Rxx.all; + -- subtype Axx is String (<low-bound> .. <high-bound>) + -- type Ayy is access String; + -- Rxx : Ayy := new <Axx> [storage_pool = ss_pool]; + -- Sxx : String renames Rxx.all; declare - Alloc : Node_Id; ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A'); Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Alloc : Node_Id; + Deref : Node_Id; Temp : Entity_Id; begin - Insert_Action (Cnode, + Insert_Action (Decl, Make_Subtype_Declaration (Loc, Defining_Identifier => ConstrT, Subtype_Indication => Subtyp_Ind), Suppress => All_Checks); - Freeze_Itype (ConstrT, Cnode); - Insert_Action (Cnode, + Freeze_Itype (ConstrT, Decl); + + Insert_Action (Decl, Make_Full_Type_Declaration (Loc, Defining_Identifier => Acc_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, - Subtype_Indication => New_Occurrence_Of (ConstrT, Loc))), + Subtype_Indication => New_Occurrence_Of (Atyp, Loc))), Suppress => All_Checks); + + Mutate_Ekind (Acc_Typ, E_Access_Type); + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + Alloc := Make_Allocator (Loc, Expression => New_Occurrence_Of (ConstrT, Loc)); - -- Allocate on the secondary stack. This is currently done - -- only for type String, which normally doesn't have default - -- initialization, but we need to Set_No_Initialization in case - -- of Initialize_Scalars or Normalize_Scalars; otherwise, the - -- allocator will get transformed and will not use the secondary - -- stack. + -- This is currently done only for type String, which normally + -- doesn't have default initialization, but we need to set the + -- No_Initialization flag in case of either Initialize_Scalars + -- or Normalize_Scalars. - Set_Storage_Pool (Alloc, RTE (RE_SS_Pool)); - Set_Procedure_To_Call (Alloc, RTE (RE_SS_Allocate)); Set_No_Initialization (Alloc); Temp := Make_Temporary (Loc, 'R', Alloc); - Insert_Action (Cnode, + Insert_Action (Decl, Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), Expression => Alloc), Suppress => All_Checks); - Insert_Action (Cnode, + Deref := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Temp, Loc)); + Set_Etype (Deref, Atyp); + + Rewrite (Decl, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Ent, - Subtype_Mark => New_Occurrence_Of (ConstrT, Loc), - Name => - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Temp, Loc))), - Suppress => All_Checks); - end; - else - -- If the bound is statically known to be out of range, we do not - -- want to abort, we want a warning and a runtime constraint error. - -- Note that we have arranged that the result will not be treated as - -- a static constant, so we won't get an illegality during this - -- insertion. - -- We also enable checks (in particular range checks) in case the - -- bounds of Subtyp_Ind are out of range. - - Insert_Action (Cnode, - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Object_Definition => Subtyp_Ind)); - end if; + Subtype_Mark => New_Occurrence_Of (Atyp, Loc), + Name => Deref)); - -- If the result of the concatenation appears as the initializing - -- expression of an object declaration, we can just rename the - -- result, rather than copying it. + -- We do not analyze this renaming declaration because this would + -- change the subtype of Ent back to a constrained string. - Set_OK_To_Rename (Ent); + Set_Etype (Ent, Atyp); + Set_Renamed_Object (Ent, Deref); + Set_Analyzed (Decl); + end; + end if; -- Catch the static out of range case now diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index ae59ad7017d..7555bf5dcf5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -192,16 +192,6 @@ package body Exp_Ch6 is -- the activation Chain. Note: Master_Actual can be Empty, but only if -- there are no tasks. - procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id); - -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check - -- that the level of the return expression's underlying type is not deeper - -- than the level of the master enclosing the function. Always generate the - -- check when the type of the return expression is class-wide, when it's a - -- type conversion, or when it's a formal parameter. Otherwise suppress the - -- check in the case where the return expression has a specific type whose - -- level is known not to be statically deeper than the result type of the - -- function. - function Caller_Known_Size (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean; @@ -5140,10 +5130,15 @@ package body Exp_Ch6 is end if; -- Another optimization: if the returned value is used to initialize an - -- object, and the secondary stack is not involved in the call, then no - -- need to copy/readjust/finalize, we can just initialize it in place. - - if Nkind (Par) = N_Object_Declaration and then not Use_Sec_Stack then + -- object, then no need to copy/readjust/finalize, we can initialize it + -- in place. However, if the call returns on the secondary stack or this + -- is a special return object, then we need the expansion because we'll + -- be renaming the temporary as the (permanent) object. + + if Nkind (Par) = N_Object_Declaration + and then not Use_Sec_Stack + and then not Is_Special_Return_Object (Defining_Entity (Par)) + then return; end if; @@ -5300,7 +5295,7 @@ package body Exp_Ch6 is -- Assert that if F says "return R : T := G(...) do..." -- then F and G are both b-i-p, or neither b-i-p. - if Nkind (Exp) = N_Function_Call then + if Present (Exp) and then Nkind (Exp) = N_Function_Call then pragma Assert (Ekind (Current_Subprogram) = E_Function); pragma Assert (Is_Build_In_Place_Function (Current_Subprogram) = @@ -5308,16 +5303,6 @@ package body Exp_Ch6 is null; end if; - -- Ada 2005 (AI95-344): If the result type is class-wide, then insert - -- a check that the level of the return expression's underlying type - -- is not deeper than the level of the master enclosing the function. - - -- AI12-043: The check is made immediately after the return object - -- is created. - - if Present (Exp) and then Is_Class_Wide_Type (Ret_Typ) then - Apply_CW_Accessibility_Check (Exp, Func_Id); - end if; else Exp := Empty; end if; @@ -6529,19 +6514,6 @@ package body Exp_Ch6 is -- need to reify the return object, so we can build it "in place", and -- we need a block statement to hang finalization and tasking stuff. - -- ??? In order to avoid disruption, we avoid translating to extended - -- return except in the cases where we really need to (Ada 2005 for - -- inherently limited). We might prefer to do this translation in all - -- cases (except perhaps for the case of Ada 95 inherently limited), - -- in order to fully exercise the Expand_N_Extended_Return_Statement - -- code. This would also allow us to do the build-in-place optimization - -- for efficiency even in cases where it is semantically not required. - - -- As before, we check the type of the return expression rather than the - -- return type of the function, because the latter may be a limited - -- 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) @@ -6682,15 +6654,18 @@ package body Exp_Ch6 is -- type Ann is access R_Type; -- for Ann'Storage_pool use rs_pool; - -- Rnn : Ann := new Exp_Typ'(Exp); + -- Rnn : constant Ann := new Exp_Typ'(Exp); -- return Rnn.all; -- but optimize the case where the result is a function call that -- also needs finalization. In this case the result can directly be -- allocated on the return stack of the caller and no further - -- processing is required. + -- processing is required. Likewise if this is a return object. - if Present (Utyp) + if Comes_From_Extended_Return_Statement (N) then + null; + + elsif Present (Utyp) and then Needs_Finalization (Utyp) and then not (Exp_Is_Function_Call and then Needs_Finalization (Exp_Typ)) @@ -6733,6 +6708,7 @@ package body Exp_Ch6 is Make_Object_Declaration (Loc, Defining_Identifier => Temp, + Constant_Present => True, Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), Expression => Alloc_Node))); @@ -6753,11 +6729,16 @@ package body Exp_Ch6 is Set_Enclosing_Sec_Stack_Return (N); + -- Nothing else to do for a return object + + if Comes_From_Extended_Return_Statement (N) then + null; + -- Optimize the case where the result is a function call that also -- returns on the secondary stack. In this case the result is already -- on the secondary stack and no further processing is required. - if Exp_Is_Function_Call + elsif Exp_Is_Function_Call and then Needs_Secondary_Stack (Exp_Typ) then -- Remove side effects from the expression now so that other parts @@ -6782,7 +6763,7 @@ package body Exp_Ch6 is -- type Ann is access R_Type; -- for Ann'Storage_pool use ss_pool; - -- Rnn : Ann := new Exp_Typ'(Exp); + -- Rnn : constant Ann := new Exp_Typ'(Exp); -- return Rnn.all; -- And we do the same for class-wide types that are not potentially @@ -6806,7 +6787,6 @@ package body Exp_Ch6 is begin Mutate_Ekind (Acc_Typ, E_Access_Type); - Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); -- This is an allocator for the secondary stack, and it's fine @@ -6836,6 +6816,7 @@ package body Exp_Ch6 is Make_Object_Declaration (Loc, Defining_Identifier => Temp, + Constant_Present => True, Object_Definition => New_Occurrence_Of (Acc_Typ, Loc), Expression => Alloc_Node))); @@ -7900,6 +7881,16 @@ package body Exp_Ch6 is and then Is_Build_In_Place_Function (Return_Applies_To (Scope (E))); end Is_Build_In_Place_Return_Object; + ----------------------------------- + -- Is_By_Reference_Return_Object -- + ----------------------------------- + + function Is_By_Reference_Return_Object (E : Entity_Id) return Boolean is + begin + return Is_Return_Object (E) + and then Is_By_Reference_Type (Etype (Return_Applies_To (Scope (E)))); + end Is_By_Reference_Return_Object; + ----------------------- -- Is_Null_Procedure -- ----------------------- @@ -7959,6 +7950,28 @@ package body Exp_Ch6 is end if; end Is_Null_Procedure; + -------------------------------------- + -- Is_Secondary_Stack_Return_Object -- + -------------------------------------- + + function Is_Secondary_Stack_Return_Object (E : Entity_Id) return Boolean is + begin + return Is_Return_Object (E) + and then Needs_Secondary_Stack (Etype (Return_Applies_To (Scope (E)))); + end Is_Secondary_Stack_Return_Object; + + ------------------------------ + -- Is_Special_Return_Object -- + ------------------------------ + + function Is_Special_Return_Object (E : Entity_Id) return Boolean is + begin + return Is_Build_In_Place_Return_Object (E) + or else Is_Secondary_Stack_Return_Object (E) + or else (Back_End_Return_Slot + and then Is_By_Reference_Return_Object (E)); + end Is_Special_Return_Object; + ------------------------------------------- -- Make_Build_In_Place_Call_In_Allocator -- ------------------------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 66888c51a07..41ddf8dd8d0 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -99,6 +99,16 @@ package Exp_Ch6 is -- Adds Extra_Actual as a named parameter association for the formal -- Extra_Formal in Subprogram_Call. + procedure Apply_CW_Accessibility_Check (Exp : Node_Id; Func : Entity_Id); + -- Ada 2005 (AI95-344): If the result type is class-wide, insert a check + -- that the level of the return expression's underlying type is not deeper + -- than the level of the master enclosing the function. Always generate the + -- check when the type of the return expression is class-wide, when it's a + -- type conversion, or when it's a formal parameter. Otherwise suppress the + -- check in the case where the return expression has a specific type whose + -- level is known not to be statically deeper than the result type of the + -- function. + function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String; -- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names -- for build-in-place formal parameters of the given kind. @@ -158,13 +168,28 @@ package Exp_Ch6 is -- True in >= Ada 2005 and must be False in Ada 95. function Is_Build_In_Place_Return_Object (E : Entity_Id) return Boolean; - -- Ada 2005 (AI-318-02): Return True is E is a return object of a function + -- Ada 2005 (AI-318-02): Return True if E is a return object of a function -- that uses build-in-place protocols. + function Is_By_Reference_Return_Object (E : Entity_Id) return Boolean; + -- Return True if E is a return object of a function whose return type is + -- required to be passed by reference, as defined in (RM 6.2(4-9)). + function Is_Null_Procedure (Subp : Entity_Id) return Boolean; -- Predicate to recognize stubbed procedures and null procedures, which -- can be inlined unconditionally in all cases. + function Is_Secondary_Stack_Return_Object (E : Entity_Id) return Boolean; + -- Return True if E is a return object of a function whose return type is + -- returned on the secondary stack. + + function Is_Special_Return_Object (E : Entity_Id) return Boolean; + -- Return True if E is the return object of a function and is handled in a + -- special way by the expander. In most cases, return objects are handled + -- like any other variables or constants but, in a few special cases, they + -- are further expanded into more elaborate constructs, whose common goal + -- is to elide the copy operation associated with the return. + procedure Make_Build_In_Place_Call_In_Allocator (Allocator : Node_Id; Function_Call : Node_Id); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index bcfb39ce21d..84b0c0e2941 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -9166,7 +9166,11 @@ package body Exp_Util is return Present (Expr) and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference - and then Nkind (Parent (Expr)) = N_Simple_Return_Statement; + and then (Nkind (Parent (Expr)) = N_Simple_Return_Statement + or else + (Nkind (Parent (Expr)) = N_Object_Renaming_Declaration + and then + Is_Return_Object (Defining_Entity (Parent (Expr))))); end Is_Related_To_Func_Return; -------------------------------- diff --git a/gcc/ada/gcc-interface/trans.cc b/gcc/ada/gcc-interface/trans.cc index a012271abf3..59332f93614 100644 --- a/gcc/ada/gcc-interface/trans.cc +++ b/gcc/ada/gcc-interface/trans.cc @@ -8473,9 +8473,10 @@ gnat_to_gnu (Node_Id gnat_node) declaration, return the result unmodified because we want to use the return slot optimization in this case. - 5. If this is a reference to an unconstrained array which is used as the - prefix of an attribute reference that requires an lvalue, return the - result unmodified because we want to return the original bounds. + 5. If this is a reference to an unconstrained array which is used either + as the prefix of an attribute reference that requires an lvalue or in + a return statement, then return the result unmodified because we want + to return the original bounds. 6. Finally, if the type of the result is already correct. */ @@ -8539,8 +8540,9 @@ gnat_to_gnu (Node_Id gnat_node) else if (TREE_CODE (TREE_TYPE (gnu_result)) == UNCONSTRAINED_ARRAY_TYPE && Present (Parent (gnat_node)) - && Nkind (Parent (gnat_node)) == N_Attribute_Reference - && lvalue_required_for_attribute_p (Parent (gnat_node))) + && ((Nkind (Parent (gnat_node)) == N_Attribute_Reference + && lvalue_required_for_attribute_p (Parent (gnat_node))) + || Nkind (Parent (gnat_node)) == N_Simple_Return_Statement)) ; else if (TREE_TYPE (gnu_result) != gnu_result_type) diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index e0dba9e6a5c..bc424ab3c3b 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -69,7 +69,6 @@ package Gen_IL.Fields is Address_Warning_Posted, Aggregate_Bounds, Aliased_Present, - Alloc_For_BIP_Return, All_Others, All_Present, Alternatives, @@ -189,6 +188,7 @@ package Gen_IL.Fields is Float_Truncate, Formal_Type_Definition, Forwards_OK, + For_Special_Return_Object, From_Aspect_Specification, From_At_Mod, From_Conditional_Expression, diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb index ba4539140fe..ec0eba74d06 100644 --- a/gcc/ada/gen_il-gen-gen_nodes.adb +++ b/gcc/ada/gen_il-gen-gen_nodes.adb @@ -494,7 +494,7 @@ begin -- Gen_IL.Gen.Gen_Nodes (Sy (Expression, Node_Id, Default_Empty), Sy (Subpool_Handle_Name, Node_Id, Default_Empty), Sy (Null_Exclusion_Present, Flag, Default_False), - Sm (Alloc_For_BIP_Return, Flag), + Sm (For_Special_Return_Object, Flag), Sm (Do_Storage_Check, Flag), Sm (Is_Dynamic_Coextension, Flag), Sm (Is_Static_Coextension, Flag), diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb index cec5b94b6fc..09fe99f44bc 100644 --- a/gcc/ada/gen_il-internals.adb +++ b/gcc/ada/gen_il-internals.adb @@ -257,8 +257,6 @@ package body Gen_IL.Internals is -- Special cases for the same reason as in the above Image -- function for Opt_Type_Enum. - when Alloc_For_BIP_Return => - return "Alloc_For_BIP_Return"; when Assignment_OK => return "Assignment_OK"; when Backwards_OK => diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index abee91f27fd..5334e486800 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3781,6 +3781,11 @@ package body Sem_Ch3 is -- Obj_Decl carrying type Obj_Typ has explicit initialization. Emit -- a compile-time warning if this is not the case. + procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); + -- Check that the return subtype indication properly matches the result + -- subtype of the function in an extended return object declaration, as + -- required by RM 6.5(5.1/2-5.3/2). + function Count_Tasks (T : Entity_Id) return Uint; -- This function is called when a non-generic library level object of a -- task type is declared. Its function is to count the static number of @@ -3954,6 +3959,134 @@ package body Sem_Ch3 is Check_Component (Obj_Typ, Obj_Decl); end Check_For_Null_Excluding_Components; + ------------------------------------- + -- Check_Return_Subtype_Indication -- + ------------------------------------- + + procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is + Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl); + Obj_Typ : constant Entity_Id := Etype (Obj_Id); + Func_Id : constant Entity_Id := Return_Applies_To (Scope (Obj_Id)); + R_Typ : constant Entity_Id := Etype (Func_Id); + Indic : constant Node_Id := + Object_Definition (Original_Node (Obj_Decl)); + + procedure Error_No_Match (N : Node_Id); + -- Output error messages for case where types do not statically + -- match. N is the location for the messages. + + -------------------- + -- Error_No_Match -- + -------------------- + + procedure Error_No_Match (N : Node_Id) is + begin + Error_Msg_N + ("subtype must statically match function result subtype", N); + + if not Predicates_Match (Obj_Typ, R_Typ) then + Error_Msg_Node_2 := R_Typ; + Error_Msg_NE + ("\predicate of& does not match predicate of&", + N, Obj_Typ); + end if; + end Error_No_Match; + + -- Start of processing for Check_Return_Subtype_Indication + + begin + -- First, avoid cascaded errors + + if Error_Posted (Obj_Decl) or else Error_Posted (Indic) then + return; + end if; + + -- "return access T" case; check that the return statement also has + -- "access T", and that the subtypes statically match: + -- if this is an access to subprogram the signatures must match. + + if Is_Anonymous_Access_Type (R_Typ) then + if Is_Anonymous_Access_Type (Obj_Typ) then + if Ekind (Designated_Type (Obj_Typ)) /= E_Subprogram_Type + then + if Base_Type (Designated_Type (Obj_Typ)) /= + Base_Type (Designated_Type (R_Typ)) + or else not Subtypes_Statically_Match (Obj_Typ, R_Typ) + then + Error_No_Match (Subtype_Mark (Indic)); + end if; + + else + -- For two anonymous access to subprogram types, the types + -- themselves must be type conformant. + + if not Conforming_Types + (Obj_Typ, R_Typ, Fully_Conformant) + then + Error_No_Match (Indic); + end if; + end if; + + else + Error_Msg_N ("must use anonymous access type", Indic); + end if; + + -- If the return object is of an anonymous access type, then report + -- an error if the function's result type is not also anonymous. + + elsif Is_Anonymous_Access_Type (Obj_Typ) then + pragma Assert (not Is_Anonymous_Access_Type (R_Typ)); + Error_Msg_N + ("anonymous access not allowed for function with named access " + & "result", Indic); + + -- Subtype indication case: check that the return object's type is + -- covered by the result type, and that the subtypes statically match + -- when the result subtype is constrained. Also handle record types + -- with unknown discriminants for which we have built the underlying + -- record view. Coverage is needed to allow specific-type return + -- objects when the result type is class-wide (see AI05-32). + + elsif Covers (Base_Type (R_Typ), Base_Type (Obj_Typ)) + or else (Is_Underlying_Record_View (Base_Type (Obj_Typ)) + and then + Covers + (Base_Type (R_Typ), + Underlying_Record_View (Base_Type (Obj_Typ)))) + then + -- A null exclusion may be present on the return type, on the + -- function specification, on the object declaration or on the + -- subtype itself. + + if Is_Access_Type (R_Typ) + and then + (Can_Never_Be_Null (R_Typ) + or else Null_Exclusion_Present (Parent (Func_Id))) /= + Can_Never_Be_Null (Obj_Typ) + then + Error_No_Match (Indic); + end if; + + -- AI05-103: for elementary types, subtypes must statically match + + if Is_Constrained (R_Typ) or else Is_Access_Type (R_Typ) then + if not Subtypes_Statically_Match (Obj_Typ, R_Typ) then + Error_No_Match (Indic); + end if; + end if; + + -- All remaining cases are illegal + + -- Note: previous versions of this subprogram allowed the return + -- value to be the ancestor of the return type if the return type + -- was a null extension. This was plainly incorrect. + + else + Error_Msg_N + ("wrong type for return_subtype_indication", Indic); + end if; + end Check_Return_Subtype_Indication; + ----------------- -- Count_Tasks -- ----------------- @@ -5047,6 +5180,12 @@ package body Sem_Ch3 is end if; end if; + -- Check specific legality rules for a return object + + if Is_Return_Object (Id) then + Check_Return_Subtype_Indication (N); + end if; + -- Some simple constant-propagation: if the expression is a constant -- string initialized with a literal, share the literal. This avoids -- a run-time copy. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c8c0d80ffcd..da5aa5fe88f 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -44,6 +44,7 @@ with Opt; use Opt; with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Case; use Sem_Case; @@ -733,43 +734,16 @@ package body Sem_Ch4 is end; end if; - -- Check for missing initialization. Skip this check if we already - -- had errors on analyzing the allocator, since in that case these - -- are probably cascaded errors. + -- Check for missing initialization. Skip this check if the allocator + -- is made for a special return object or if we already had errors on + -- analyzing the allocator since, in that case, these are very likely + -- cascaded errors. if not Is_Definite_Subtype (Type_Id) + and then not For_Special_Return_Object (N) and then Serious_Errors_Detected = Sav_Errs then - -- The build-in-place machinery may produce an allocator when - -- the designated type is indefinite but the underlying type is - -- not. In this case the unknown discriminants are meaningless - -- and should not trigger error messages. Check the parent node - -- because the allocator is marked as coming from source. - - if Present (Underlying_Type (Type_Id)) - and then Is_Definite_Subtype (Underlying_Type (Type_Id)) - and then not Comes_From_Source (Parent (N)) - then - null; - - -- An unusual case arises when the parent of a derived type is - -- a limited record extension with unknown discriminants, and - -- its full view has no discriminants. - -- - -- A more general fix might be to create the proper underlying - -- type for such a derived type, but it is a record type with - -- no private attributes, so this required extending the - -- meaning of this attribute. ??? - - elsif Ekind (Etype (Type_Id)) = E_Record_Type_With_Private - and then Present (Underlying_Type (Etype (Type_Id))) - and then - not Has_Discriminants (Underlying_Type (Etype (Type_Id))) - and then not Comes_From_Source (Parent (N)) - then - null; - - elsif Is_Class_Wide_Type (Type_Id) then + if Is_Class_Wide_Type (Type_Id) then Error_Msg_N ("initialization required in class-wide allocation", N); @@ -842,6 +816,27 @@ package body Sem_Ch4 is Error_Msg_N ("cannot allocate abstract object", E); end if; + Set_Etype (N, Acc_Type); + + -- If this is an allocator for the return stack, then no restriction may + -- be violated since it's just a low-level access to the primary stack. + + if Nkind (Parent (N)) = N_Object_Declaration + and then Is_Entity_Name (Object_Definition (Parent (N))) + and then Is_Access_Type (Entity (Object_Definition (Parent (N)))) + then + declare + Pool : constant Entity_Id := + Associated_Storage_Pool + (Root_Type (Entity (Object_Definition (Parent (N))))); + + begin + if Present (Pool) and then Is_RTE (Pool, RE_RS_Pool) then + goto Leave; + end if; + end; + end if; + if Has_Task (Designated_Type (Acc_Type)) then Check_Restriction (No_Tasking, N); Check_Restriction (Max_Tasks, N); @@ -893,12 +888,11 @@ package body Sem_Ch4 is end if; end if; - Set_Etype (N, Acc_Type); - if not Is_Library_Level_Entity (Acc_Type) then Check_Restriction (No_Local_Allocators, N); end if; + <<Leave>> if Serious_Errors_Detected > Sav_Errs then Set_Error_Posted (N); Set_Etype (N, Any_Type); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index c1523ae11e2..344b3ebfdb2 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -307,7 +307,8 @@ package body Sem_Ch5 is -- get the actual subtype (needed for the unconstrained case). If the -- operand is the actual in an entry declaration, then within the -- accept statement it is replaced with a local renaming, which may - -- also have an actual subtype. + -- also have an actual subtype. Likewise for a return object that + -- lives on the secondary stack. if Is_Entity_Name (Opnd) and then (Ekind (Entity (Opnd)) in E_Out_Parameter @@ -318,7 +319,8 @@ package body Sem_Ch5 is and then Nkind (Parent (Entity (Opnd))) = N_Object_Renaming_Declaration and then Nkind (Parent (Parent (Entity (Opnd)))) = - N_Accept_Statement)) + N_Accept_Statement) + or else Is_Secondary_Stack_Return_Object (Entity (Opnd))) then Opnd_Type := Get_Actual_Subtype (Opnd); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d567f79b27e..f46ca46fc64 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -746,10 +746,6 @@ package body Sem_Ch6 is -- Ada 2022: Check that the return expression in a No_Return function -- meets the conditions specified by RM 6.5.1(5.1/5). - procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id); - -- Check that the return_subtype_indication properly matches the result - -- subtype of the function, as required by RM-6.5(5.1/2-5.3/2). - -------------------------------- -- Check_No_Return_Expression -- -------------------------------- @@ -778,135 +774,6 @@ package body Sem_Ch6 is Return_Expr); end Check_No_Return_Expression; - ------------------------------------- - -- Check_Return_Subtype_Indication -- - ------------------------------------- - - procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is - Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl); - - R_Stm_Type : constant Entity_Id := Etype (Return_Obj); - -- Subtype given in the extended return statement (must match R_Type) - - Subtype_Ind : constant Node_Id := - Object_Definition (Original_Node (Obj_Decl)); - - procedure Error_No_Match (N : Node_Id); - -- Output error messages for case where types do not statically - -- match. N is the location for the messages. - - -------------------- - -- Error_No_Match -- - -------------------- - - procedure Error_No_Match (N : Node_Id) is - begin - Error_Msg_N - ("subtype must statically match function result subtype", N); - - if not Predicates_Match (R_Stm_Type, R_Type) then - Error_Msg_Node_2 := R_Type; - Error_Msg_NE - ("\predicate of& does not match predicate of&", - N, R_Stm_Type); - end if; - end Error_No_Match; - - -- Start of processing for Check_Return_Subtype_Indication - - begin - -- First, avoid cascaded errors - - if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then - return; - end if; - - -- "return access T" case; check that the return statement also has - -- "access T", and that the subtypes statically match: - -- if this is an access to subprogram the signatures must match. - - if Is_Anonymous_Access_Type (R_Type) then - if Is_Anonymous_Access_Type (R_Stm_Type) then - if Ekind (Designated_Type (R_Stm_Type)) /= E_Subprogram_Type - then - if Base_Type (Designated_Type (R_Stm_Type)) /= - Base_Type (Designated_Type (R_Type)) - or else not Subtypes_Statically_Match (R_Stm_Type, R_Type) - then - Error_No_Match (Subtype_Mark (Subtype_Ind)); - end if; - - else - -- For two anonymous access to subprogram types, the types - -- themselves must be type conformant. - - if not Conforming_Types - (R_Stm_Type, R_Type, Fully_Conformant) - then - Error_No_Match (Subtype_Ind); - end if; - end if; - - else - Error_Msg_N ("must use anonymous access type", Subtype_Ind); - end if; - - -- If the return object is of an anonymous access type, then report - -- an error if the function's result type is not also anonymous. - - elsif Is_Anonymous_Access_Type (R_Stm_Type) then - pragma Assert (not Is_Anonymous_Access_Type (R_Type)); - Error_Msg_N - ("anonymous access not allowed for function with named access " - & "result", Subtype_Ind); - - -- Subtype indication case: check that the return object's type is - -- covered by the result type, and that the subtypes statically match - -- when the result subtype is constrained. Also handle record types - -- with unknown discriminants for which we have built the underlying - -- record view. Coverage is needed to allow specific-type return - -- objects when the result type is class-wide (see AI05-32). - - elsif Covers (Base_Type (R_Type), Base_Type (R_Stm_Type)) - or else (Is_Underlying_Record_View (Base_Type (R_Stm_Type)) - and then - Covers - (Base_Type (R_Type), - Underlying_Record_View (Base_Type (R_Stm_Type)))) - then - -- A null exclusion may be present on the return type, on the - -- function specification, on the object declaration or on the - -- subtype itself. - - if Is_Access_Type (R_Type) - and then - (Can_Never_Be_Null (R_Type) - or else Null_Exclusion_Present (Parent (Scope_Id))) /= - Can_Never_Be_Null (R_Stm_Type) - then - Error_No_Match (Subtype_Ind); - end if; - - -- AI05-103: for elementary types, subtypes must statically match - - if Is_Constrained (R_Type) or else Is_Access_Type (R_Type) then - if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then - Error_No_Match (Subtype_Ind); - end if; - end if; - - -- All remaining cases are illegal - - -- Note: previous versions of this subprogram allowed the return - -- value to be the ancestor of the return type if the return type - -- was a null extension. This was plainly incorrect. - - else - Error_Msg_N - ("wrong type for return_subtype_indication", Subtype_Ind); - end if; - end Check_Return_Subtype_Indication; - --------------------- -- Local Variables -- --------------------- @@ -1016,8 +883,6 @@ package body Sem_Ch6 is Set_Is_Return_Object (Defining_Identifier (Obj_Decl)); Analyze (Obj_Decl); - Check_Return_Subtype_Indication (Obj_Decl); - if Present (HSS) then Analyze (HSS); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4bbec65d6a0..b54ed93a7f7 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5622,7 +5622,7 @@ package body Sem_Res is -- caller does use an allocator, it will be caught at the call site. if No_Pool_Assigned (Typ) - and then not Alloc_For_BIP_Return (N) + and then not For_Special_Return_Object (N) then Error_Msg_N ("allocation from empty storage pool!", N); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 7accb018a69..104ee663c0e 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -842,10 +842,6 @@ package Sinfo is -- known at compile time, this field points to an N_Range node with those -- bounds. Otherwise Empty. - -- Alloc_For_BIP_Return - -- Present in N_Allocator nodes. True if the allocator is one of those - -- generated for a build-in-place return statement. - -- All_Others -- Present in an N_Others_Choice node. This flag is set for an others -- exception where all exceptions are to be caught, even those that are @@ -1344,6 +1340,10 @@ package Sinfo is -- cannot figure it out. If both flags Forwards_OK and Backwards_OK are -- set, it means that the front end can assure no overlap of operands. + -- For_Special_Return_Object + -- Present in N_Allocator nodes. True if the allocator is generated for + -- the initialization of a special return object. + -- From_Aspect_Specification -- Processing of aspect specifications typically results in insertion in -- the tree of corresponding pragma or attribute definition clause nodes. @@ -4777,7 +4777,7 @@ package Sinfo is -- Subpool_Handle_Name (set to Empty if not present) -- Storage_Pool -- Procedure_To_Call - -- Alloc_For_BIP_Return + -- For_Special_Return_Object -- Null_Exclusion_Present -- No_Initialization -- Is_Static_Coextension diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index a9f40887d8a..a0f45c422be 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -269,8 +269,9 @@ package body Treepr is function Image (F : Node_Or_Entity_Field) return String is begin case F is - when F_Alloc_For_BIP_Return => - return "Alloc_For_BIP_Return"; + -- We special case the following; otherwise the compiler will use + -- the usual Mixed_Case convention. + when F_Assignment_OK => return "Assignment_OK"; when F_Backwards_OK => -- 2.34.1