[Ada] Improve speed of discriminated return types
authorBob Duff <duff@adacore.com>
Tue, 20 Aug 2019 09:50:19 +0000 (09:50 +0000)
committerPierre-Marie de Rodat <pmderodat@gcc.gnu.org>
Tue, 20 Aug 2019 09:50:19 +0000 (09:50 +0000)
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

gcc/ada/ChangeLog
gcc/ada/exp_ch6.adb
gcc/ada/sem_ch4.adb

index 608eacb41afc8fa05e3de7efab7b56caa58f9a68..56cb308509737631b5416b4700171290de7eb613 100644 (file)
@@ -1,3 +1,20 @@
+2019-08-20  Bob Duff  <duff@adacore.com>
+
+       * 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  <dismukes@adacore.com>
 
        * ali.adb, ali.ads, aspects.adb, checks.ads, checks.adb,
index c182072ea9f26bfe4ccc414a4339b5cccb0b2fab..2733ad44b88436ac21269e8b9ccf317ba9da47ff 100644 (file)
@@ -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;
 
    --------------------------------------
index 16614edd98584e843fbece134ad8ee734768a2c3..0dccd33a5e40f9aa8ed9358d541a9b0a7c2238b4 100644 (file)
@@ -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;