[gcc r13-954] [Ada] Restore full generation of static dispatch tables with -gnatzr

[gcc r13-954] [Ada] Restore full generation of static dispatch tables with -gnatzr

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:bbb9c475bff9e3646542fa5273433abc0300cf6a

commit r13-954-gbbb9c475bff9e3646542fa5273433abc0300cf6a
Author: Eric Botcazou <ebotcazou@adacore.com>
Date:   Sat May 21 21:54:45 2022 +0200

    [Ada] Restore full generation of static dispatch tables with -gnatzr
    
    The -gnatzr switch triggers the creation of distribution stubs for use
    by the implementation of PolyORB.  Now these stubs declare tagged types
    and are generated at the very end of the analysis of compilation units,
    after the static dispatch tables have been built, so these tables are
    missing for the tagged types of the stubs.
    
    Therefore this change defers the generation of static dispatch tables
    for compilation units, which is the common case, until after the stubs
    are (potentially) generated.  For the other cases, in particular the
    generic instances that are not compilation units, nothing is changed.
    
    gcc/ada/
    
            * exp_ch7.adb (Expand_N_Package_Body): Build static dispatch
            tables only for units that are not compilation units, unless
            they are generic instances.  Do not push a scope for this.
            (Expand_N_Package_Declaration): Build static dispatch tables
            only for units that are both not compilation units and generic
            instances.
            * exp_disp.adb (Build_Static_Dispatch_Tables): Remove redundant
            early return.  Push a scope for package bodies.
            * sem_ch10.adb: Add with and use clauses for Exp_Disp.
            (Analyze_Compilation_Unit): Build static dispatch tables here.

Diff:
---
 gcc/ada/exp_ch7.adb  | 19 ++++++++++++-------
 gcc/ada/exp_disp.adb | 17 +++++++++--------
 gcc/ada/sem_ch10.adb | 17 +++++++++++++++++
 3 files changed, 38 insertions(+), 15 deletions(-)

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index b6fc62d2b80..5f1c357a125 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -5876,16 +5876,20 @@ package body Exp_Ch7 is
       --  This is done only for non-generic packages
 
       if Ekind (Spec_Id) = E_Package then
-         Push_Scope (Spec_Id);
-
-         --  Build dispatch tables of library level tagged types
+         --  Build dispatch tables of library-level tagged types for bodies
+         --  that are not compilation units (see Analyze_Compilation_Unit),
+         --  except for instances because they have no N_Compilation_Unit.
 
          if Tagged_Type_Expansion
            and then Is_Library_Level_Entity (Spec_Id)
+           and then (not Is_Compilation_Unit (Spec_Id)
+                      or else Is_Generic_Instance (Spec_Id))
          then
             Build_Static_Dispatch_Tables (N);
          end if;
 
+         Push_Scope (Spec_Id);
+
          Expand_CUDA_Package (N);
 
          Build_Task_Activation_Call (N);
@@ -6035,12 +6039,13 @@ package body Exp_Ch7 is
          Pop_Scope;
       end if;
 
-      --  Build dispatch tables of library-level tagged types
+      --  Build dispatch tables of library-level tagged types for instances
+      --  that are not compilation units (see Analyze_Compilation_Unit).
 
       if Tagged_Type_Expansion
-        and then (Is_Compilation_Unit (Id)
-                   or else (Is_Generic_Instance (Id)
-                             and then Is_Library_Level_Entity (Id)))
+        and then Is_Library_Level_Entity (Id)
+        and then Is_Generic_Instance (Id)
+        and then not Is_Compilation_Unit (Id)
       then
          Build_Static_Dispatch_Tables (N);
       end if;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index ddb0cedc048..17043d15510 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -524,12 +524,6 @@ package body Exp_Disp is
    --  Start of processing for Build_Static_Dispatch_Tables
 
    begin
-      if not Expander_Active
-        or else not Tagged_Type_Expansion
-      then
-         return;
-      end if;
-
       if Nkind (N) = N_Package_Declaration then
          declare
             Spec       : constant Node_Id := Specification (N);
@@ -553,8 +547,15 @@ package body Exp_Disp is
          end;
 
       else pragma Assert (Nkind (N) = N_Package_Body);
-         Target_List := Declarations (N);
-         Build_Dispatch_Tables (Target_List);
+         declare
+            Spec_Id : constant Entity_Id := Corresponding_Spec (N);
+
+         begin
+            Push_Scope (Spec_Id);
+            Target_List := Declarations (N);
+            Build_Dispatch_Tables (Target_List);
+            Pop_Scope;
+         end;
       end if;
    end Build_Static_Dispatch_Tables;
 
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index 5976b4dd7e3..9b9a9f147cc 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -31,6 +31,7 @@ with Einfo;          use Einfo;
 with Einfo.Entities; use Einfo.Entities;
 with Einfo.Utils;    use Einfo.Utils;
 with Errout;         use Errout;
+with Exp_Disp;       use Exp_Disp;
 with Exp_Put_Image;
 with Exp_Util;       use Exp_Util;
 with Elists;         use Elists;
@@ -1000,6 +1001,22 @@ package body Sem_Ch10 is
          end if;
       end if;
 
+      --  Build dispatch tables of library-level tagged types only now because
+      --  the generation of distribution stubs above may create some of them.
+
+      if Expander_Active and then Tagged_Type_Expansion then
+         case Nkind (Unit_Node) is
+            when N_Package_Declaration | N_Package_Body =>
+               Build_Static_Dispatch_Tables (Unit_Node);
+
+            when N_Package_Instantiation =>
+               Build_Static_Dispatch_Tables (Instance_Spec (Unit_Node));
+
+            when others =>
+               null;
+         end case;
+      end if;
+
       --  Remove unit from visibility, so that environment is clean for the
       --  next compilation, which is either the main unit or some other unit
       --  in the context.