vhdl: fix uvvm failure in scoreboard testbench.

8 files changed, 71 insertions, 13 deletions

diff --git a/src/vhdl/canon.adb b/src/vhdl/canon.adb
index 99232ff4d..921798a9a 100644
--- a/src/vhdl/canon.adb
+++ b/src/vhdl/canon.adb
@@ -2735,7 +2735,7 @@ package body Canon is
       then
          Bod := Sem_Inst.Instantiate_Package_Body (Decl);
          Set_Parent (Bod, Get_Parent (Decl));
-         Set_Package_Body (Decl, Bod);
+         Set_Instance_Package_Body (Decl, Bod);
       end if;
 
       return Decl;
diff --git a/src/vhdl/iirs.adb b/src/vhdl/iirs.adb
index 1ad810da6..b41fd1e4d 100644
--- a/src/vhdl/iirs.adb
+++ b/src/vhdl/iirs.adb
@@ -1826,6 +1826,22 @@ package body Iirs is
       Set_Field5 (Pkg, Decl);
    end Set_Package_Body;
 
+   function Get_Instance_Package_Body (Pkg : Iir) return Iir is
+   begin
+      pragma Assert (Pkg /= Null_Iir);
+      pragma Assert (Has_Instance_Package_Body (Get_Kind (Pkg)),
+                     "no field Instance_Package_Body");
+      return Get_Field5 (Pkg);
+   end Get_Instance_Package_Body;
+
+   procedure Set_Instance_Package_Body (Pkg : Iir; Decl : Iir) is
+   begin
+      pragma Assert (Pkg /= Null_Iir);
+      pragma Assert (Has_Instance_Package_Body (Get_Kind (Pkg)),
+                     "no field Instance_Package_Body");
+      Set_Field5 (Pkg, Decl);
+   end Set_Instance_Package_Body;
+
    function Get_Need_Body (Decl : Iir_Package_Declaration) return Boolean is
    begin
       pragma Assert (Decl /= Null_Iir);
diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads
index 69917d637..4add8dd6e 100644
--- a/src/vhdl/iirs.ads
+++ b/src/vhdl/iirs.ads
@@ -987,7 +987,8 @@ package Iirs is
    --
    --   Get/Set_Attribute_Value_Chain (Field4)
    --
-   --   Get/Set_Package_Body (Field5)
+   --  For macro-expanded packages: the body.
+   --   Get/Set_Instance_Package_Body (Field5)
    --
    --   Get/Set_Visible_Flag (Flag4)
    --
@@ -6264,6 +6265,11 @@ package Iirs is
    function Get_Package_Body (Pkg : Iir) return Iir;
    procedure Set_Package_Body (Pkg : Iir; Decl : Iir);
 
+   --  The package body corresponding to the package declaration.
+   --  Field: Field5
+   function Get_Instance_Package_Body (Pkg : Iir) return Iir;
+   procedure Set_Instance_Package_Body (Pkg : Iir; Decl : Iir);
+
    --  Field: Flag1
    function Get_Need_Body (Decl : Iir_Package_Declaration) return Boolean;
    procedure Set_Need_Body (Decl : Iir_Package_Declaration; Flag : Boolean);
diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb
index f09b6c711..0ccea3a42 100644
--- a/src/vhdl/nodes_meta.adb
+++ b/src/vhdl/nodes_meta.adb
@@ -96,6 +96,7 @@ package body Nodes_Meta is
       Field_Entity_Name => Type_Iir,
       Field_Package => Type_Iir,
       Field_Package_Body => Type_Iir,
+      Field_Instance_Package_Body => Type_Iir,
       Field_Need_Body => Type_Boolean,
       Field_Macro_Expanded_Flag => Type_Boolean,
       Field_Need_Instance_Bodies => Type_Boolean,
@@ -509,6 +510,8 @@ package body Nodes_Meta is
             return "package";
          when Field_Package_Body =>
             return "package_body";
+         when Field_Instance_Package_Body =>
+            return "instance_package_body";
          when Field_Need_Body =>
             return "need_body";
          when Field_Macro_Expanded_Flag =>
@@ -1711,6 +1714,8 @@ package body Nodes_Meta is
             return Attr_Ref;
          when Field_Package_Body =>
             return Attr_Forward_Ref;
+         when Field_Instance_Package_Body =>
+            return Attr_None;
          when Field_Need_Body =>
             return Attr_None;
          when Field_Macro_Expanded_Flag =>
@@ -2854,7 +2859,7 @@ package body Nodes_Meta is
       Field_Declaration_Chain,
       Field_Chain,
       Field_Attribute_Value_Chain,
-      Field_Package_Body,
+      Field_Instance_Package_Body,
       --  Iir_Kind_Package_Body
       Field_Identifier,
       Field_End_Has_Reserved_Id,
@@ -5142,6 +5147,8 @@ package body Nodes_Meta is
             return Get_Package (N);
          when Field_Package_Body =>
             return Get_Package_Body (N);
+         when Field_Instance_Package_Body =>
+            return Get_Instance_Package_Body (N);
          when Field_Block_Configuration =>
             return Get_Block_Configuration (N);
          when Field_Concurrent_Statement_Chain =>
@@ -5536,6 +5543,8 @@ package body Nodes_Meta is
             Set_Package (N, V);
          when Field_Package_Body =>
             Set_Package_Body (N, V);
+         when Field_Instance_Package_Body =>
+            Set_Instance_Package_Body (N, V);
          when Field_Block_Configuration =>
             Set_Block_Configuration (N, V);
          when Field_Concurrent_Statement_Chain =>
@@ -7208,15 +7217,14 @@ package body Nodes_Meta is
 
    function Has_Package_Body (K : Iir_Kind) return Boolean is
    begin
-      case K is
-         when Iir_Kind_Package_Declaration
-           | Iir_Kind_Package_Instantiation_Declaration =>
-            return True;
-         when others =>
-            return False;
-      end case;
+      return K = Iir_Kind_Package_Declaration;
    end Has_Package_Body;
 
+   function Has_Instance_Package_Body (K : Iir_Kind) return Boolean is
+   begin
+      return K = Iir_Kind_Package_Instantiation_Declaration;
+   end Has_Instance_Package_Body;
+
    function Has_Need_Body (K : Iir_Kind) return Boolean is
    begin
       return K = Iir_Kind_Package_Declaration;
diff --git a/src/vhdl/nodes_meta.ads b/src/vhdl/nodes_meta.ads
index c7b8c9924..4f913b7c1 100644
--- a/src/vhdl/nodes_meta.ads
+++ b/src/vhdl/nodes_meta.ads
@@ -137,6 +137,7 @@ package Nodes_Meta is
       Field_Entity_Name,
       Field_Package,
       Field_Package_Body,
+      Field_Instance_Package_Body,
       Field_Need_Body,
       Field_Macro_Expanded_Flag,
       Field_Need_Instance_Bodies,
@@ -665,6 +666,7 @@ package Nodes_Meta is
    function Has_Entity_Name (K : Iir_Kind) return Boolean;
    function Has_Package (K : Iir_Kind) return Boolean;
    function Has_Package_Body (K : Iir_Kind) return Boolean;
+   function Has_Instance_Package_Body (K : Iir_Kind) return Boolean;
    function Has_Need_Body (K : Iir_Kind) return Boolean;
    function Has_Macro_Expanded_Flag (K : Iir_Kind) return Boolean;
    function Has_Need_Instance_Bodies (K : Iir_Kind) return Boolean;
diff --git a/src/vhdl/sem_inst.adb b/src/vhdl/sem_inst.adb
index fb67f61d2..54f37a2f6 100644
--- a/src/vhdl/sem_inst.adb
+++ b/src/vhdl/sem_inst.adb
@@ -148,6 +148,9 @@ package body Sem_Inst is
    --  The virtual file for the instance.
    Instance_File : Source_File_Entry;
 
+   --  True if currently instantiated a shared generic.
+   Is_Within_Shared_Instance : Boolean := False;
+
    --  Get the new location.
    function Relocate (Loc : Location_Type) return Location_Type is
    begin
@@ -573,7 +576,24 @@ package body Sem_Inst is
                   null;
                when Field_Package =>
                   Instantiate_Iir_Field (Res, N, F);
-                  Set_Package_Body (Get_Package (Res), Res);
+                  declare
+                     Pkg : constant Iir := Get_Package (Res);
+                  begin
+                     --  The current node can be the body of a package; in that
+                     --  case set the forward link.
+                     --  Or it can be the body of an instantiated package; in
+                     --  that case there is no forward link.
+                     if Get_Kind (Pkg) = Iir_Kind_Package_Declaration then
+                        Set_Package_Body (Get_Package (Res), Res);
+                     end if;
+                  end;
+
+               when Field_Instance_Package_Body =>
+                  --  Do not instantiate the body of a package while
+                  --  instantiating a shared package.
+                  if not Is_Within_Shared_Instance then
+                     Instantiate_Iir_Field (Res, N, F);
+                  end if;
 
                when Field_Subtype_Definition =>
                   --  TODO
@@ -969,6 +989,8 @@ package body Sem_Inst is
       Header : constant Iir := Get_Package_Header (Pkg);
       Prev_Instance_File : constant Source_File_Entry := Instance_File;
       Mark : constant Instance_Index_Type := Prev_Instance_Table.Last;
+      Prev_Within_Shared_Instance : constant Boolean :=
+        Is_Within_Shared_Instance;
    begin
       Create_Relocation (Inst, Pkg);
       Set_Instance_Source_File (Inst, Instance_File);
@@ -979,6 +1001,8 @@ package body Sem_Inst is
       --  For Parent: the instance of PKG is INST.
       Set_Origin (Pkg, Inst);
 
+      Is_Within_Shared_Instance := not Get_Macro_Expanded_Flag (Pkg);
+
       Set_Generic_Chain
         (Inst, Instantiate_Generic_Chain (Inst, Get_Generic_Chain (Header)));
       Instantiate_Generic_Map_Chain (Inst, Pkg);
@@ -989,6 +1013,8 @@ package body Sem_Inst is
 
       Instance_File := Prev_Instance_File;
       Restore_Origin (Mark);
+
+      Is_Within_Shared_Instance := Prev_Within_Shared_Instance;
    end Instantiate_Package_Declaration;
 
    function Instantiate_Package_Body (Inst : Iir) return Iir
diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb
index e1770ad90..01703b842 100644
--- a/src/vhdl/translate/trans-chap2.adb
+++ b/src/vhdl/translate/trans-chap2.adb
@@ -1552,7 +1552,7 @@ package body Trans.Chap2 is
          --  Generate code for the body.
          if Global_Storage /= O_Storage_External then
             declare
-               Bod : constant Iir := Get_Package_Body (Inst);
+               Bod : constant Iir := Get_Instance_Package_Body (Inst);
             begin
                if Is_Valid (Bod) then
                   Translate_Package_Body (Bod);
diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb
index c7c806b34..11c5f1a8c 100644
--- a/src/vhdl/translate/trans-chap4.adb
+++ b/src/vhdl/translate/trans-chap4.adb
@@ -2522,7 +2522,7 @@ package body Trans.Chap4 is
                  (Get_Uninstantiated_Package_Decl (El))
                then
                   declare
-                     Bod : constant Iir := Get_Package_Body (El);
+                     Bod : constant Iir := Get_Instance_Package_Body (El);
                      Mark  : Id_Mark_Type;
                   begin
                      Push_Identifier_Prefix (Mark, Get_Identifier (El));