From cf0e5ca723edbb63719ca075fce3f84eb8e43553 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Tue, 20 Aug 2019 09:50:19 +0000 Subject: [PATCH] [Ada] Improve speed of discriminated return types The compiler now generates faster code for functions that return discriminated types in many cases where the size is known at compile time. 2019-08-20 Bob Duff gcc/ada/ * exp_ch6.adb (Needs_BIP_Alloc_Form): Call Requires_Transient_Scope rather than checking constrainedness and so forth. We have previously improved Requires_Transient_Scope to return False in various cases, notably a limited record with an access discriminant. This change takes advantage of that to avoid using the secondary stack for functions returning such types. (Make_Build_In_Place_Call_In_Allocator): Be consistent by calling Needs_BIP_Alloc_Form rather than Is_Constrained and so forth. * sem_ch4.adb (Analyze_Allocator): The above change causes the compiler to generate code that is not legal Ada, in particular an uninitialized allocator for indefinite subtype. This is harmless, so we suppress the error message in this case. From-SVN: r274738 --- gcc/ada/ChangeLog | 17 +++++++ gcc/ada/exp_ch6.adb | 109 +++++++++++++++++++++----------------------- gcc/ada/sem_ch4.adb | 48 +++++++++++++------ 3 files changed, 103 insertions(+), 71 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 608eacb41af..56cb3085097 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2019-08-20 Bob Duff + + * exp_ch6.adb (Needs_BIP_Alloc_Form): Call + Requires_Transient_Scope rather than checking constrainedness + and so forth. We have previously improved + Requires_Transient_Scope to return False in various cases, + notably a limited record with an access discriminant. This + change takes advantage of that to avoid using the secondary + stack for functions returning such types. + (Make_Build_In_Place_Call_In_Allocator): Be consistent by + calling Needs_BIP_Alloc_Form rather than Is_Constrained and so + forth. + * sem_ch4.adb (Analyze_Allocator): The above change causes the + compiler to generate code that is not legal Ada, in particular + an uninitialized allocator for indefinite subtype. This is + harmless, so we suppress the error message in this case. + 2019-08-20 Gary Dismukes * ali.adb, ali.ads, aspects.adb, checks.ads, checks.adb, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c182072ea9f..2733ad44b88 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5615,7 +5615,23 @@ package body Exp_Ch6 is Set_Comes_From_Extended_Return_Statement (Return_Stmt); Rewrite (N, Result); - Analyze (N, Suppress => All_Checks); + + declare + T : constant Entity_Id := Etype (Ret_Obj_Id); + begin + Analyze (N, Suppress => All_Checks); + + -- In some cases, analysis of N can set the Etype of an N_Identifier + -- to a subtype of the Etype of the Entity of the N_Identifier, which + -- gigi doesn't like. Reset the Etypes correctly here. + + if Nkind (Expression (Return_Stmt)) = N_Identifier + and then Entity (Expression (Return_Stmt)) = Ret_Obj_Id + then + Set_Etype (Ret_Obj_Id, T); + Set_Etype (Expression (Return_Stmt), T); + end if; + end; end Expand_N_Extended_Return_Statement; ---------------------------- @@ -8108,13 +8124,41 @@ package body Exp_Ch6 is -- since it is already attached on the related finalization master. -- Here and in related routines, we must examine the full view of the - -- type, because the view at the point of call may differ from that - -- that in the function body, and the expansion mechanism depends on + -- type, because the view at the point of call may differ from the + -- one in the function body, and the expansion mechanism depends on -- the characteristics of the full view. - if Is_Constrained (Underlying_Type (Result_Subt)) - and then not Needs_Finalization (Underlying_Type (Result_Subt)) - then + if Needs_BIP_Alloc_Form (Function_Id) then + Temp_Init := Empty; + + -- Case of a user-defined storage pool. Pass an allocation parameter + -- indicating that the function should allocate its result in the + -- pool, and pass the pool. Use 'Unrestricted_Access because the + -- pool may not be aliased. + + if Present (Associated_Storage_Pool (Acc_Type)) then + Alloc_Form := User_Storage_Pool; + Pool := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Associated_Storage_Pool (Acc_Type), Loc), + Attribute_Name => Name_Unrestricted_Access); + + -- No user-defined pool; pass an allocation parameter indicating that + -- the function should allocate its result on the heap. + + else + Alloc_Form := Global_Heap; + Pool := Make_Null (No_Location); + end if; + + -- The caller does not provide the return object in this case, so we + -- have to pass null for the object access actual. + + Return_Obj_Actual := Empty; + + else -- 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 @@ -8163,35 +8207,6 @@ package body Exp_Ch6 is -- perform the allocation of the return object, so we pass parameters -- indicating that. - else - Temp_Init := Empty; - - -- Case of a user-defined storage pool. Pass an allocation parameter - -- indicating that the function should allocate its result in the - -- pool, and pass the pool. Use 'Unrestricted_Access because the - -- pool may not be aliased. - - if Present (Associated_Storage_Pool (Acc_Type)) then - Alloc_Form := User_Storage_Pool; - Pool := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Associated_Storage_Pool (Acc_Type), Loc), - Attribute_Name => Name_Unrestricted_Access); - - -- No user-defined pool; pass an allocation parameter indicating that - -- the function should allocate its result on the heap. - - else - Alloc_Form := Global_Heap; - Pool := Make_Null (No_Location); - end if; - - -- The caller does not provide the return object in this case, so we - -- have to pass null for the object access actual. - - Return_Obj_Actual := Empty; end if; -- Declare the temp object @@ -9279,30 +9294,8 @@ package body Exp_Ch6 is function Needs_BIP_Alloc_Form (Func_Id : Entity_Id) return Boolean is pragma Assert (Is_Build_In_Place_Function (Func_Id)); Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); - begin - -- A build-in-place function needs to know which allocation form to - -- use when: - -- - -- 1) The result subtype is unconstrained. In this case, depending on - -- the context of the call, the object may need to be created in the - -- secondary stack, the heap, or a user-defined storage pool. - -- - -- 2) The result subtype is tagged. In this case the function call may - -- dispatch on result and thus needs to be treated in the same way as - -- calls to functions with class-wide results, because a callee that - -- can be dispatched to may have any of various result subtypes, so - -- if any of the possible callees would require an allocation form to - -- be passed then they all do. - -- - -- 3) The result subtype needs finalization actions. In this case, based - -- on the context of the call, the object may need to be created at - -- the caller site, in the heap, or in a user-defined storage pool. - - return - not Is_Constrained (Func_Typ) - or else Is_Tagged_Type (Func_Typ) - or else Needs_Finalization (Func_Typ); + return Requires_Transient_Scope (Func_Typ); end Needs_BIP_Alloc_Form; -------------------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 16614edd985..0dccd33a5e4 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -796,25 +796,47 @@ package body Sem_Ch4 is ("\constraint with discriminant values required", N); end if; - -- Limited Ada 2005 and general nonlimited case + -- Limited Ada 2005 and general nonlimited case. + -- This is an error, except in the case of an + -- uninitialized allocator that is generated + -- for a build-in-place function return of a + -- discriminated but compile-time-known-size + -- type. else - Error_Msg_N - ("uninitialized unconstrained allocation not " - & "allowed", N); + if Original_Node (N) /= N + and then Nkind (Original_Node (N)) = N_Allocator + then + declare + Qual : constant Node_Id := + Expression (Original_Node (N)); + pragma Assert + (Nkind (Qual) = N_Qualified_Expression); + Call : constant Node_Id := Expression (Qual); + pragma Assert + (Is_Expanded_Build_In_Place_Call (Call)); + begin + null; + end; - if Is_Array_Type (Type_Id) then + else Error_Msg_N - ("\qualified expression or constraint with " - & "array bounds required", N); + ("uninitialized unconstrained allocation not " + & "allowed", N); - elsif Has_Unknown_Discriminants (Type_Id) then - Error_Msg_N ("\qualified expression required", N); + if Is_Array_Type (Type_Id) then + Error_Msg_N + ("\qualified expression or constraint with " + & "array bounds required", N); - else pragma Assert (Has_Discriminants (Type_Id)); - Error_Msg_N - ("\qualified expression or constraint with " - & "discriminant values required", N); + elsif Has_Unknown_Discriminants (Type_Id) then + Error_Msg_N ("\qualified expression required", N); + + else pragma Assert (Has_Discriminants (Type_Id)); + Error_Msg_N + ("\qualified expression or constraint with " + & "discriminant values required", N); + end if; end if; end if; end if; -- 2.30.2