Rework registration of RTIs for packages, to fix bug 21052.

9 files changed, 119 insertions, 73 deletions

diff --git a/translate/gcc/dist-common.sh b/translate/gcc/dist-common.sh
index 479d7ca02..51d28937b 100644
--- a/translate/gcc/dist-common.sh
+++ b/translate/gcc/dist-common.sh
@@ -204,6 +204,7 @@ grt-options.ads
 grt-processes.adb
 grt-processes.ads
 grt-rtis.ads
+grt-rtis.adb
 grt-rtis_addr.adb
 grt-rtis_addr.ads
 grt-rtis_utils.adb
diff --git a/translate/ghdldrv/ghdlrun.adb b/translate/ghdldrv/ghdlrun.adb
index 25bd385a9..0a9fe7a11 100644
--- a/translate/ghdldrv/ghdlrun.adb
+++ b/translate/ghdldrv/ghdlrun.adb
@@ -455,10 +455,10 @@ package body Ghdlrun is
       Def (Trans_Decls.Ghdl_Create_Delayed_Signal,
            Grt.Signals.Ghdl_Create_Delayed_Signal'Address);
 
-      Def (Trans_Decls.Ghdl_Rti_Top_Instance,
-           Grt.Rtis.Ghdl_Rti_Top_Instance'Address);
-      Def (Trans_Decls.Ghdl_Rti_Top_Ptr,
-           Grt.Rtis.Ghdl_Rti_Top_Ptr'Address);
+      Def (Trans_Decls.Ghdl_Rti_Add_Package,
+           Grt.Rtis.Ghdl_Rti_Add_Package'Address);
+      Def (Trans_Decls.Ghdl_Rti_Add_Top,
+           Grt.Rtis.Ghdl_Rti_Add_Top'Address);
 
       Def (Trans_Decls.Ghdl_Protected_Enter,
            Grt.Processes.Ghdl_Protected_Enter'Address);
diff --git a/translate/grt/grt-avhpi.adb b/translate/grt/grt-avhpi.adb
index a5c36e598..a6565cf5d 100644
--- a/translate/grt/grt-avhpi.adb
+++ b/translate/grt/grt-avhpi.adb
@@ -31,7 +31,7 @@ package body Grt.Avhpi is
    begin
       Res := (Kind => VhpiIteratorK,
               Ctxt => (Base => Null_Address,
-                       Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top_Ptr)),
+                       Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)),
               Rel => VhpiPackInsts,
               It_Cur => 0,
               It2 => 0,
diff --git a/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb
index d6f891a9c..cc3d5ffaa 100644
--- a/translate/grt/grt-disp_rti.adb
+++ b/translate/grt/grt-disp_rti.adb
@@ -999,14 +999,14 @@ package body Grt.Disp_Rti is
       end if;
 
       Put ("DISP_RTI.Disp_All: ");
-      Disp_Kind (Ghdl_Rti_Top_Ptr.Common.Kind);
+      Disp_Kind (Ghdl_Rti_Top.Common.Kind);
       New_Line;
       Ctxt := (Base => To_Address (Ghdl_Rti_Top_Instance),
-               Block => Ghdl_Rti_Top_Ptr.Parent);
-      Disp_Rti_Arr (Ghdl_Rti_Top_Ptr.Nbr_Child,
-                    Ghdl_Rti_Top_Ptr.Children,
+               Block => Ghdl_Rti_Top.Parent);
+      Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child,
+                    Ghdl_Rti_Top.Children,
                     Ctxt, 0);
-      Disp_Rti (Ghdl_Rti_Top_Ptr.Parent, Ctxt, 0);
+      Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0);
 
       --Disp_Hierarchy;
    end Disp_All;
diff --git a/translate/grt/grt-disp_tree.adb b/translate/grt/grt-disp_tree.adb
index 3f337ab35..c72d67b91 100644
--- a/translate/grt/grt-disp_tree.adb
+++ b/translate/grt/grt-disp_tree.adb
@@ -397,8 +397,8 @@ package body Grt.Disp_Tree is
       New_Line;
       Disp_Tree_Block (Parent, Ctxt, "");
 
-      for I in 1 .. Ghdl_Rti_Top_Ptr.Nbr_Child loop
-         Child := Ghdl_Rti_Top_Ptr.Children (I - 1);
+      for I in 1 .. Ghdl_Rti_Top.Nbr_Child loop
+         Child := Ghdl_Rti_Top.Children (I - 1);
          Ctxt := (Base => Null_Address,
                   Block => Child);
          Disp_Tree_Child (Child, Ctxt);
diff --git a/translate/grt/grt-rtis.ads b/translate/grt/grt-rtis.ads
index 564b39741..6caba1539 100644
--- a/translate/grt/grt-rtis.ads
+++ b/translate/grt/grt-rtis.ads
@@ -325,7 +325,14 @@ package Grt.Rtis is
      (Source => Address, Target => Ghdl_Component_Link_Acc);
 
    --  TOP rti.
-   Ghdl_Rti_Top_Ptr : Ghdl_Rtin_Block_Acc;
+   Ghdl_Rti_Top : Ghdl_Rtin_Block :=
+     (Common => (Ghdl_Rtik_Top, 0, 0, 0),
+      Name => null,
+      Loc => (Rel => True, Off => 0),
+      Parent => null,
+      Size => 0,
+      Nbr_Child => 0,
+      Children => null);
 
    --  Address of the top instance.
    Ghdl_Rti_Top_Instance : Ghdl_Rti_Access;
@@ -341,7 +348,13 @@ package Grt.Rtis is
    function To_Ghdl_Rti_Access is new Ada.Unchecked_Conversion
      (Source => Address, Target => Ghdl_Rti_Access);
 
-private
-   pragma Export (C, Ghdl_Rti_Top_Ptr, "__ghdl_rti_top_ptr");
-   pragma Export (C, Ghdl_Rti_Top_Instance, "__ghdl_rti_top_instance");
+   procedure Ghdl_Rti_Add_Top (Max_Pkg : Ghdl_Index_Type;
+                               Pkgs : Ghdl_Rti_Arr_Acc;
+                               Top : Ghdl_Rti_Access;
+                               Instance : Address);
+   pragma Export (C, Ghdl_Rti_Add_Top, "__ghdl_rti_add_top");
+
+   --  Register a package
+   procedure Ghdl_Rti_Add_Package (Pkg : Ghdl_Rti_Access);
+   pragma Export (C, Ghdl_Rti_Add_Package, "__ghdl_rti_add_package");
 end Grt.Rtis;
diff --git a/translate/grt/grt-rtis_addr.adb b/translate/grt/grt-rtis_addr.adb
index 4488654d5..0c64d0cec 100644
--- a/translate/grt/grt-rtis_addr.adb
+++ b/translate/grt/grt-rtis_addr.adb
@@ -265,7 +265,7 @@ package body Grt.Rtis_Addr is
       Ctxt : Rti_Context;
    begin
       Ctxt := (Base => To_Address (Ghdl_Rti_Top_Instance),
-               Block => Ghdl_Rti_Top_Ptr.Parent);
+               Block => Ghdl_Rti_Top.Parent);
       return Ctxt;
    end Get_Top_Context;
 
diff --git a/translate/trans_decls.ads b/translate/trans_decls.ads
index 8a93fcf66..eadba8bde 100644
--- a/translate/trans_decls.ads
+++ b/translate/trans_decls.ads
@@ -170,11 +170,6 @@ package Trans_Decls is
    Ghdl_Stack2_Mark : O_Dnode;
    Ghdl_Stack2_Release : O_Dnode;
 
-   --  RTI root.
-   Ghdl_Rti_Top : O_Dnode;
-   Ghdl_Rti_Top_Ptr : O_Dnode;
-   Ghdl_Rti_Top_Instance : O_Dnode;
-
    Std_Standard_Boolean_Rti : O_Dnode;
    Std_Standard_Bit_Rti : O_Dnode;
 
@@ -228,5 +223,9 @@ package Trans_Decls is
    --  For PSL.
    Ghdl_Std_Ulogic_To_Boolean_Array : O_Dnode;
 
+   --  Register a package
+   Ghdl_Rti_Add_Package : O_Dnode;
+   Ghdl_Rti_Add_Top : O_Dnode;
+
    Ghdl_Elaborate : O_Dnode;
 end Trans_Decls;
diff --git a/translate/translation.adb b/translate/translation.adb
index 572e2058e..0f2835fa2 100644
--- a/translate/translation.adb
+++ b/translate/translation.adb
@@ -738,8 +738,9 @@ package body Translation is
       procedure Generate_Library (Lib : Iir_Library_Declaration;
                                   Public : Boolean);
 
-      --  Generate RTI for the top of the hierarchy.
-      procedure Generate_Top (Arch : Iir);
+      --  Generate RTI for the top of the hierarchy.  Return the maximum number
+      --  of packages.
+      procedure Generate_Top (Nbr_Pkgs : out Natural);
 
       --  Add two associations to ASSOC to add an rti_context for NODE.
       procedure Associate_Rti_Context
@@ -5286,6 +5287,7 @@ package body Translation is
       is
          Info : Ortho_Info_Acc;
          Final : Boolean;
+         Constr : O_Assoc_List;
          pragma Unreferenced (Final);
       begin
          Info := Get_Info (Spec);
@@ -5294,6 +5296,15 @@ package body Translation is
 
          Elab_Dependence (Get_Design_Unit (Spec));
 
+         --  Register the package.  This is done dynamically, as we know only
+         --  during elaboration that the design depends on a package (a package
+         --  maybe referenced by an entity which is never map due to generate
+         --  statements).
+         Start_Association (Constr, Ghdl_Rti_Add_Package);
+         New_Association
+           (Constr, New_Lit (Rtis.New_Rti_Address (Info.Package_Rti_Const)));
+         New_Procedure_Call (Constr);
+
          Open_Temp;
          Chap4.Elab_Declaration_Chain (Spec, Final);
          Close_Temp;
@@ -27611,20 +27622,18 @@ package body Translation is
          end if;
       end Generate_Unit;
 
-      procedure Generate_Top (Arch : Iir)
+      procedure Generate_Top (Nbr_Pkgs : out Natural)
       is
          use Configuration;
 
          Unit : Iir_Design_Unit;
-         Lib_Unit : Iir;
          Lib : Iir_Library_Declaration;
-         Arr : O_Dnode;
-         Res : O_Cnode;
-         Aggr : O_Record_Aggr_List;
          Prev : Rti_Block;
       begin
          Push_Rti_Node (Prev);
-         Add_Rti_Node (Get_Info (Standard_Package).Package_Rti_Const);
+
+         --  Generate RTI for libraries, count number of packages.
+         Nbr_Pkgs := 1; --  At least std.standard.
          for I in Design_Units.First .. Design_Units.Last loop
             Unit := Design_Units.Table (I);
 
@@ -27632,31 +27641,13 @@ package body Translation is
             Lib := Get_Library (Get_Design_File (Unit));
             Generate_Library (Lib, True);
 
-            Lib_Unit := Get_Library_Unit (Unit);
-            case Get_Kind (Lib_Unit) is
-               when Iir_Kind_Package_Declaration =>
-                  Add_Rti_Node (Get_Info (Lib_Unit).Package_Rti_Const);
-               when others =>
-                  null;
-            end case;
+            if Get_Kind (Get_Library_Unit (Unit))
+              = Iir_Kind_Package_Declaration
+            then
+               Nbr_Pkgs := Nbr_Pkgs + 1;
+            end if;
          end loop;
-         Arr := Generate_Rti_Array (Get_Identifier ("__ghdl_top_RTIARRAY"));
-         New_Const_Decl (Ghdl_Rti_Top, Get_Identifier ("__ghdl_rti_top"),
-                         O_Storage_Public, Ghdl_Rtin_Block);
-         Start_Const_Value (Ghdl_Rti_Top);
-         Start_Record_Aggr (Aggr, Ghdl_Rtin_Block);
-         New_Record_Aggr_El (Aggr, Generate_Common (Ghdl_Rtik_Top));
-         New_Record_Aggr_El (Aggr, New_Null_Access (Char_Ptr_Type));
-         New_Record_Aggr_El (Aggr, Get_Null_Loc);
-         New_Record_Aggr_El
-           (Aggr, New_Rti_Address (Get_Info (Arch).Block_Rti_Const));
-         New_Record_Aggr_El (Aggr, Ghdl_Index_0);
-         New_Record_Aggr_El
-           (Aggr, New_Unsigned_Literal (Ghdl_Index_Type,
-                                        Unsigned_64 (Cur_Block.Nbr)));
-         New_Record_Aggr_El (Aggr, New_Global_Address (Arr, Ghdl_Rti_Arr_Acc));
-         Finish_Record_Aggr (Aggr, Res);
-         Finish_Const_Value (Ghdl_Rti_Top, Res);
+
          Pop_Rti_Node (Prev);
       end Generate_Top;
 
@@ -29190,6 +29181,27 @@ package body Translation is
          --                                     name : __ghdl_str_len_ptr);
          Create_Get_Name ("__ghdl_get_instance_name", Ghdl_Get_Instance_Name);
       end;
+
+      --  procedure __ghdl_rti_add_package (rti : ghdl_rti_access)
+      Start_Procedure_Decl
+        (Interfaces, Get_Identifier ("__ghdl_rti_add_package"),
+         O_Storage_External);
+      New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access);
+      Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Package);
+
+      --  procedure __ghdl_rti_add_top (max_pkgs : ghdl_index_type;
+      --                                pkgs : ghdl_rti_arr_acc);
+      Start_Procedure_Decl
+        (Interfaces, Get_Identifier ("__ghdl_rti_add_top"),
+         O_Storage_External);
+      New_Interface_Decl (Interfaces, Param, Get_Identifier ("max_pkgs"),
+                          Ghdl_Index_Type);
+      New_Interface_Decl (Interfaces, Param, Get_Identifier ("pkgs"),
+                          Rtis.Ghdl_Rti_Arr_Acc);
+      New_Interface_Decl (Interfaces, Param, Wki_Rti, Rtis.Ghdl_Rti_Access);
+      New_Interface_Decl
+        (Interfaces, Param, Wki_Instance, Ghdl_Ptr_Type);
+      Finish_Subprogram_Decl (Interfaces, Ghdl_Rti_Add_Top);
    end Post_Initialize;
 
    procedure Translate_Std_Type_Declaration (Decl : Iir)
@@ -29405,7 +29417,8 @@ package body Translation is
       --  Create __ghdl_ELABORATE
       procedure Gen_Main (Entity : Iir_Entity_Declaration;
                           Arch : Iir_Architecture_Declaration;
-                          Config_Subprg : O_Dnode)
+                          Config_Subprg : O_Dnode;
+                          Nbr_Pkgs : Natural)
       is
          Entity_Info : Block_Info_Acc;
          Arch_Info : Block_Info_Acc;
@@ -29414,6 +29427,8 @@ package body Translation is
          Instance : O_Dnode;
          Arch_Instance : O_Dnode;
          Mark : Id_Mark_Type;
+         Arr_Type : O_Tnode;
+         Arr : O_Dnode;
       begin
          Arch_Info := Get_Info (Arch);
          Entity_Info := Get_Info (Entity);
@@ -29421,14 +29436,13 @@ package body Translation is
          --  We need to create code.
          Set_Global_Storage (O_Storage_Private);
 
-         New_Var_Decl
-           (Ghdl_Rti_Top_Instance, Get_Identifier ("__ghdl_rti_top_instance"),
-            O_Storage_External, Ghdl_Ptr_Type);
-
-         New_Var_Decl (Ghdl_Rti_Top_Ptr,
-                       Get_Identifier ("__ghdl_rti_top_ptr"),
-                       O_Storage_External, Ghdl_Ptr_Type);
-
+         --  Create the array of packages (as a variable, dynamically
+         --  initialized).
+         Arr_Type := New_Constrained_Array_Type
+           (Rtis.Ghdl_Rti_Array,
+            New_Unsigned_Literal (Ghdl_Index_Type, Unsigned_64 (Nbr_Pkgs)));
+         New_Var_Decl (Arr, Get_Identifier ("__ghdl_top_RTIARRAY"),
+                       O_Storage_Private, Arr_Type);
 
          --  Declare (but do not define):
          --  Variable for the hierarchy top instance.
@@ -29470,13 +29484,28 @@ package body Translation is
          --  Set top instances and RTI.
          --  Do it before the elaboration code, since it may be used to
          --  diagnose errors.
-         New_Assign_Stmt (New_Obj (Ghdl_Rti_Top_Instance),
-                          New_Convert_Ov (New_Obj_Value (Arch_Instance),
-                                          Ghdl_Ptr_Type));
+         --  Call ghdl_rti_add_top
+         Start_Association (Assoc, Ghdl_Rti_Add_Top);
+         New_Association
+           (Assoc, New_Lit (New_Unsigned_Literal (Ghdl_Index_Type,
+                                                  Unsigned_64 (Nbr_Pkgs))));
+         New_Association
+           (Assoc, New_Lit (New_Global_Address (Arr, Rtis.Ghdl_Rti_Arr_Acc)));
+         New_Association
+           (Assoc,
+            New_Lit (Rtis.New_Rti_Address (Get_Info (Arch).Block_Rti_Const)));
+         New_Association
+           (Assoc, New_Convert_Ov (New_Obj_Value (Arch_Instance),
+                                   Ghdl_Ptr_Type));
+         New_Procedure_Call (Assoc);
 
-         New_Assign_Stmt (New_Obj (Ghdl_Rti_Top_Ptr),
-                          New_Unchecked_Address (New_Obj (Ghdl_Rti_Top),
-                                                 Ghdl_Ptr_Type));
+         --  Add std.standard rti
+         Start_Association (Assoc, Ghdl_Rti_Add_Package);
+         New_Association
+           (Assoc,
+            New_Lit (Rtis.New_Rti_Address
+                       (Get_Info (Standard_Package).Package_Rti_Const)));
+         New_Procedure_Call (Assoc);
 
          Gen_Filename (Get_Design_File (Get_Design_Unit (Entity)));
 
@@ -29886,6 +29915,7 @@ package body Translation is
          Arch : Iir_Architecture_Declaration;
          Conf_Info : Config_Info_Acc;
          Last_Design_Unit : Natural;
+         Nbr_Pkgs : Natural;
       begin
          Primary_Id := Get_Identifier (Primary);
          if Secondary /= "" then
@@ -29980,6 +30010,11 @@ package body Translation is
          end loop;
 
          --  Generate code to elaboration body-less package.
+         --
+         --  When a package is analyzed, we don't know wether there is body
+         --  or not.  Therefore, we assume there is always a body, and will
+         --  elaborate the body (which elaborates its spec).  If a package
+         --  has no body, create the body elaboration procedure.
          for I in Design_Units.First .. Design_Units.Last loop
             Unit := Design_Units.Table (I);
             Lib_Unit := Get_Library_Unit (Unit);
@@ -29999,13 +30034,11 @@ package body Translation is
             end case;
          end loop;
 
-         if Flag_Rti then
-            Rtis.Generate_Top (Arch);
-         end if;
+         Rtis.Generate_Top (Nbr_Pkgs);
 
          --  Create main code.
          Conf_Info := Get_Info (Config_Lib);
-         Gen_Main (Entity, Arch, Conf_Info.Config_Subprg);
+         Gen_Main (Entity, Arch, Conf_Info.Config_Subprg, Nbr_Pkgs);
 
          Gen_Setup_Info;