[gcc r13-942] [Ada] Build static dispatch tables always at the end of declarative part

[gcc r13-942] [Ada] Build static dispatch tables always at the end of declarative part

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:5a06e886ac86fd14e02eca0cf70360f1c2d9374f

commit r13-942-g5a06e886ac86fd14e02eca0cf70360f1c2d9374f
Author: Eric Botcazou <ebotcazou@adacore.com>
Date:   Mon May 16 16:14:46 2022 +0200

    [Ada] Build static dispatch tables always at the end of declarative part
    
    The static dispatch tables of library-level tagged types are either built
    on the first object declaration or at the end of the declarative part of
    the package spec or body. There is no real need for the former case, and
    the tables are not built for other constructs that freeze (tagged) types.
    
    Therefore this change removes the former case, thus causing the tables to
    be always built at the end of the declarative part; that's orthogonal to
    freezing and the tagged types are still frozen at the appropriate place.
    
    Moreover, it wraps the code in the Actions list of a freeze node (like
    for the nonstatic case) so that it is considered elaboration code by the
    processing done in Sem_Elab and does not disturb it.
    
    No functional changes.
    
    gcc/ada/
    
            * exp_ch3.adb (Expand_Freeze_Record_Type): Adjust comment.
            (Expand_N_Object_Declaration): Do not build static dispatch tables.
            * exp_disp.adb (Make_And_Insert_Dispatch_Table): New procedure.
            (Build_Static_Dispatch_Tables): Call it to build the dispatch tables
            and wrap them in the Actions list of a freeze node.

Diff:
---
 gcc/ada/exp_ch3.adb  | 33 +--------------------------------
 gcc/ada/exp_disp.adb | 31 +++++++++++++++++++++++++++----
 2 files changed, 28 insertions(+), 36 deletions(-)

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 5403f3b4f64..2f74208c401 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -5763,7 +5763,7 @@ package body Exp_Ch3 is
 
                --  Generate dispatch table of locally defined tagged type.
                --  Dispatch tables of library level tagged types are built
-               --  later (see Analyze_Declarations).
+               --  later (see Build_Static_Dispatch_Tables).
 
                if not Building_Static_DT (Typ) then
                   Append_Freeze_Actions (Typ, Make_DT (Typ));
@@ -6907,37 +6907,6 @@ package body Exp_Ch3 is
          return;
       end if;
 
-      --  First we do special processing for objects of a tagged type where
-      --  this is the point at which the type is frozen. The creation of the
-      --  dispatch table and the initialization procedure have to be deferred
-      --  to this point, since we reference previously declared primitive
-      --  subprograms.
-
-      --  Force construction of dispatch tables of library level tagged types
-
-      if Tagged_Type_Expansion
-        and then Building_Static_Dispatch_Tables
-        and then Is_Library_Level_Entity (Def_Id)
-        and then Is_Library_Level_Tagged_Type (Base_Typ)
-        and then Ekind (Base_Typ) in E_Record_Type
-                                   | E_Protected_Type
-                                   | E_Task_Type
-        and then not Has_Dispatch_Table (Base_Typ)
-      then
-         declare
-            New_Nodes : List_Id := No_List;
-
-         begin
-            if Is_Concurrent_Type (Base_Typ) then
-               New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ));
-            else
-               New_Nodes := Make_DT (Base_Typ);
-            end if;
-
-            Insert_List_Before (N, New_Nodes);
-         end;
-      end if;
-
       --  Make shared memory routines for shared passive variable
 
       if Is_Shared_Passive (Def_Id) then
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 8666902be8d..f16cfdca948 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -358,6 +358,12 @@ package body Exp_Disp is
       procedure Build_Package_Dispatch_Tables (N : Node_Id);
       --  Build static dispatch tables associated with package declaration N
 
+      procedure Make_And_Insert_Dispatch_Table (Typ : Entity_Id);
+      --  Build the dispatch table of the tagged type Typ and insert it at the
+      --  end of Target_List after wrapping it in the Actions list of a freeze
+      --  node, so that it is skipped by Sem_Elab (Expand_Freeze_Record_Type
+      --  does the same for nonstatic dispatch tables).
+
       ---------------------------
       -- Build_Dispatch_Tables --
       ---------------------------
@@ -410,8 +416,7 @@ package body Exp_Disp is
                then
                   null;
                else
-                  Insert_List_After_And_Analyze (Last (Target_List),
-                    Make_DT (Defining_Entity (D)));
+                  Make_And_Insert_Dispatch_Table (Defining_Entity (D));
                end if;
 
             --  Handle private types of library level tagged types. We must
@@ -434,8 +439,7 @@ package body Exp_Disp is
                     and then not Is_Concurrent_Type (E2)
                   then
                      Exchange_Declarations (E1);
-                     Insert_List_After_And_Analyze (Last (Target_List),
-                       Make_DT (E1));
+                     Make_And_Insert_Dispatch_Table (E1);
                      Exchange_Declarations (E2);
                   end if;
                end;
@@ -469,6 +473,25 @@ package body Exp_Disp is
          Pop_Scope;
       end Build_Package_Dispatch_Tables;
 
+      ------------------------------------
+      -- Make_And_Insert_Dispatch_Table --
+      ------------------------------------
+
+      procedure Make_And_Insert_Dispatch_Table (Typ : Entity_Id) is
+         F_Typ : constant Entity_Id := Create_Itype (E_Class_Wide_Type, Typ);
+         --  The code generator discards freeze nodes of CW types after
+         --  evaluating their side effects, so create an artificial one.
+
+         F_Nod : constant Node_Id := Make_Freeze_Entity (Sloc (Typ));
+
+      begin
+         Set_Is_Frozen (F_Typ);
+         Set_Entity    (F_Nod, F_Typ);
+         Set_Actions   (F_Nod, Make_DT (Typ));
+
+         Insert_After_And_Analyze (Last (Target_List), F_Nod);
+      end Make_And_Insert_Dispatch_Table;
+
    --  Start of processing for Build_Static_Dispatch_Tables
 
    begin