[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  <duff@adacore.com>

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

1 files changed, 35 insertions, 13 deletions

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 16614ed..0dccd33 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;