synth: represent access types as pointers in memory

13 files changed, 125 insertions, 60 deletions

diff --git a/src/synth/elab-memtype.adb b/src/synth/elab-memtype.adb
index 91e38a900..ed09f5c57 100644
--- a/src/synth/elab-memtype.adb
+++ b/src/synth/elab-memtype.adb
@@ -28,6 +28,13 @@ package body Elab.Memtype is
       return To_Memory_Ptr (To_Address (Base) + Storage_Offset (Off));
    end "+";
 
+   function "-" (Base : Memory_Ptr; Off : Size_Type) return Memory_Ptr
+   is
+      use System.Storage_Elements;
+   begin
+      return To_Memory_Ptr (To_Address (Base) - Storage_Offset (Off));
+   end "-";
+
    type Ghdl_U8_Ptr is access all Ghdl_U8;
    function To_U8_Ptr is
       new Ada.Unchecked_Conversion (Address, Ghdl_U8_Ptr);
diff --git a/src/synth/elab-memtype.ads b/src/synth/elab-memtype.ads
index 2b4cb14e7..adda31158 100644
--- a/src/synth/elab-memtype.ads
+++ b/src/synth/elab-memtype.ads
@@ -42,6 +42,7 @@ package Elab.Memtype is
    --  Low-level functions.
 
    function "+" (Base : Memory_Ptr; Off : Size_Type) return Memory_Ptr;
+   function "-" (Base : Memory_Ptr; Off : Size_Type) return Memory_Ptr;
 
    procedure Write_U8 (Mem : Memory_Ptr; Val : Ghdl_U8);
    function Read_U8 (Mem : Memory_Ptr) return Ghdl_U8;
diff --git a/src/synth/elab-vhdl_debug.adb b/src/synth/elab-vhdl_debug.adb
index 1f0eb40d9..90751e8f6 100644
--- a/src/synth/elab-vhdl_debug.adb
+++ b/src/synth/elab-vhdl_debug.adb
@@ -243,13 +243,13 @@ package body Elab.Vhdl_Debug is
             Disp_Value_Record (M, Vtype);
          when Type_Access =>
             declare
-               Idx : constant Heap_Index := Read_Access (M);
+               Ptr : constant Heap_Ptr := Read_Access (M);
             begin
-               if Idx = Null_Heap_Index then
+               if Ptr = Null_Heap_Ptr then
                   Put ("null");
                else
                   Put ("@");
-                  Put_Uns32 (Uns32 (Idx));
+                  Put_Uns32 (Uns32 (Elab.Vhdl_Heap.Get_Index (Ptr)));
                end if;
             end;
          when Type_Protected =>
@@ -1430,6 +1430,7 @@ package body Elab.Vhdl_Debug is
       F : Natural;
       Idx : Uns32;
       Valid : Boolean;
+      Ptr : Heap_Ptr;
       Mt : Memtyp;
    begin
       F := Skip_Blanks (Line, Line'First);
@@ -1438,8 +1439,13 @@ package body Elab.Vhdl_Debug is
          Put_Line ("invalid heap index");
          return;
       end if;
-      Mt := Elab.Vhdl_Heap.Synth_Dereference (Heap_Index (Idx));
-      Debug_Memtyp (Mt);
+      Ptr := Elab.Vhdl_Heap.Get_Pointer (Elab.Vhdl_Heap.Heap_Slot (Idx));
+      if Ptr = Null_Heap_Ptr then
+         Put_Line ("invalid heap index");
+      else
+         Mt := Elab.Vhdl_Heap.Synth_Dereference (Ptr);
+         Debug_Memtyp (Mt);
+      end if;
    end Print_Heap_Proc;
 
    procedure Info_Lib_Proc (Line : String)
diff --git a/src/synth/elab-vhdl_heap.adb b/src/synth/elab-vhdl_heap.adb
index ed026a64e..8b125c589 100644
--- a/src/synth/elab-vhdl_heap.adb
+++ b/src/synth/elab-vhdl_heap.adb
@@ -18,21 +18,39 @@
 
 with Ada.Unchecked_Conversion;
 
-with Types; use Types;
 with Tables;
 
 with Elab.Memtype; use Elab.Memtype;
 
 package body Elab.Vhdl_Heap is
 
+   --  Each object on the heap is prefixed by this prefix (to easily convert
+   --  to an index).
+   type Slot_Prefix is record
+      Slot : Heap_Slot;
+      Pad : Uns32;
+   end record;
+
+   --  Size of the prefix.
+   Prefix_Size : constant Size_Type := Size_Type (Slot_Prefix'Size / 8);
+
+   type Slot_Prefix_Acc is access all Slot_Prefix;
+
+   function To_Slot_Prefix_Acc is new Ada.Unchecked_Conversion
+     (Source => Memory_Ptr, Target => Slot_Prefix_Acc);
+
+   --  Each allocated object on the heap is referenced in the heap table.
+   --  This is the entry in the table.
    type Heap_Entry is record
-      Obj : Memory_Ptr;
+      --  Pointer to the prefix.
+      Ptr : Memory_Ptr;
+      --  Type of the object.
       Typ : Memory_Ptr;
    end record;
 
    package Heap_Table is new Tables
      (Table_Component_Type => Heap_Entry,
-      Table_Index_Type => Heap_Index,
+      Table_Index_Type => Heap_Slot,
       Table_Low_Bound => 1,
       Table_Initial => 16);
 
@@ -43,16 +61,18 @@ package body Elab.Vhdl_Heap is
    --  OBJ_TYP is the object type.
    procedure Allocate (Acc_Typ : Type_Acc;
                        Obj_Typ : Type_Acc;
-                       Res : out Memory_Ptr;
-                       Idx : out Heap_Index)
+                       Res : out Memory_Ptr)
    is
       Typ_Sz : constant Size_Type := Acc_Typ.Acc_Bnd_Sz;
       E : Heap_Entry;
    begin
       pragma Assert (Acc_Typ.Kind = Type_Access);
 
-      E.Obj := Alloc_Mem (Obj_Typ.Sz);
+      --  Allocate memory for the object and the prefix.
+      E.Ptr := Alloc_Mem (Prefix_Size + Obj_Typ.Sz);
+      Res := E.Ptr + Prefix_Size;
 
+      --  Allocate the memory for the type.
       if Typ_Sz > 0 then
          declare
             T : Type_Acc;
@@ -70,42 +90,54 @@ package body Elab.Vhdl_Heap is
          end;
       end if;
 
-      Res := E.Obj;
-
       Heap_Table.Append (E);
-      Idx := Heap_Table.Last;
+      To_Slot_Prefix_Acc (E.Ptr).Slot := Heap_Table.Last;
    end Allocate;
 
    function Allocate_By_Type (Acc_Typ : Type_Acc; T : Type_Acc)
-                             return Heap_Index
+                             return Heap_Ptr
    is
       Res : Memory_Ptr;
-      Idx : Heap_Index;
    begin
-      Allocate (Acc_Typ, T, Res, Idx);
+      Allocate (Acc_Typ, T, Res);
       Write_Value_Default (Res, T);
-      return Idx;
+      return Heap_Ptr (Res);
    end Allocate_By_Type;
 
    function Allocate_By_Value (Acc_Typ : Type_Acc; V : Valtyp)
-                              return Heap_Index
+                              return Heap_Ptr
    is
       Mem : Memory_Ptr;
-      Idx : Heap_Index;
    begin
-      Allocate (Acc_Typ, V.Typ, Mem, Idx);
+      Allocate (Acc_Typ, V.Typ, Mem);
       Write_Value (Mem, V);
-      return Idx;
+      return Heap_Ptr (Mem);
    end Allocate_By_Value;
 
-   function Synth_Dereference (Idx : Heap_Index) return Memtyp
+   function Get_Index (Ptr : Heap_Ptr) return Heap_Slot
+   is
+      Pfx : constant Memory_Ptr := Memory_Ptr (Ptr) - Prefix_Size;
+   begin
+      return To_Slot_Prefix_Acc (Pfx).Slot;
+   end Get_Index;
+
+   function Get_Pointer (Idx : Heap_Slot) return Heap_Ptr
+   is
+      Pfx : constant Memory_Ptr := Heap_Table.Table (Idx).Ptr;
+   begin
+      return Heap_Ptr (Pfx + Prefix_Size);
+   end Get_Pointer;
+
+   function Synth_Dereference (Ptr : Heap_Ptr) return Memtyp
    is
       function To_Type_Acc is new Ada.Unchecked_Conversion
         (Memory_Ptr, Type_Acc);
 
-      E : Heap_Entry renames Heap_Table.Table (Idx);
+      Slot : constant Heap_Slot := Get_Index (Ptr);
+
+      E : Heap_Entry renames Heap_Table.Table (Slot);
    begin
-      return (To_Type_Acc (E.Typ), E.Obj);
+      return (To_Type_Acc (E.Typ), E.Ptr + Prefix_Size);
    end Synth_Dereference;
 
    procedure Free (Obj : in out Heap_Entry) is
@@ -114,12 +146,14 @@ package body Elab.Vhdl_Heap is
       Obj := (null, null);
    end Free;
 
-   procedure Synth_Deallocate (Idx : Heap_Index) is
+   procedure Synth_Deallocate (Ptr : Heap_Ptr)
+   is
+      Slot : constant Heap_Slot := Get_Index (Ptr);
    begin
-      if Heap_Table.Table (Idx).Obj = null then
+      if Heap_Table.Table (Slot).Ptr = null then
          return;
       end if;
-      Free (Heap_Table.Table (Idx));
+      Free (Heap_Table.Table (Slot));
    end Synth_Deallocate;
 
 end Elab.Vhdl_Heap;
diff --git a/src/synth/elab-vhdl_heap.ads b/src/synth/elab-vhdl_heap.ads
index 7c2846a31..668ec0df8 100644
--- a/src/synth/elab-vhdl_heap.ads
+++ b/src/synth/elab-vhdl_heap.ads
@@ -16,6 +16,8 @@
 --  You should have received a copy of the GNU General Public License
 --  along with this program.  If not, see <gnu.org/licenses>.
 
+with Types; use Types;
+
 with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes;
 with Elab.Vhdl_Values; use Elab.Vhdl_Values;
 
@@ -23,11 +25,16 @@ package Elab.Vhdl_Heap is
 
    --  Allocate a value.
    function Allocate_By_Type (Acc_Typ : Type_Acc; T : Type_Acc)
-                             return Heap_Index;
+                             return Heap_Ptr;
    function Allocate_By_Value (Acc_Typ : Type_Acc; V : Valtyp)
-                              return Heap_Index;
+                              return Heap_Ptr;
+
+   function Synth_Dereference (Ptr : Heap_Ptr) return Memtyp;
+
+   procedure Synth_Deallocate (Ptr : Heap_Ptr);
 
-   function Synth_Dereference (Idx : Heap_Index) return Memtyp;
+   type Heap_Slot is new Uns32;
 
-   procedure Synth_Deallocate (Idx : Heap_Index);
+   function Get_Index (Ptr : Heap_Ptr) return Heap_Slot;
+   function Get_Pointer (Idx : Heap_Slot) return Heap_Ptr;
 end Elab.Vhdl_Heap;
diff --git a/src/synth/elab-vhdl_objtypes.adb b/src/synth/elab-vhdl_objtypes.adb
index 38d7376a4..f59380091 100644
--- a/src/synth/elab-vhdl_objtypes.adb
+++ b/src/synth/elab-vhdl_objtypes.adb
@@ -689,9 +689,9 @@ package body Elab.Vhdl_Objtypes is
       end if;
       return To_Type_Acc (Alloc (Current_Pool, (Kind => Type_Access,
                                                 Wkind => Wkind_Sim,
-                                                Al => 2,
+                                                Al => Heap_Ptr_Al,
                                                 Is_Global => False,
-                                                Sz => 4,
+                                                Sz => Heap_Ptr_Sz,
                                                 W => 1,
                                                 Acc_Acc => Acc_Type,
                                                 Acc_Bnd_Sz => Bnd_Sz)));
diff --git a/src/synth/elab-vhdl_objtypes.ads b/src/synth/elab-vhdl_objtypes.ads
index c46095a3d..dcd29a6cf 100644
--- a/src/synth/elab-vhdl_objtypes.ads
+++ b/src/synth/elab-vhdl_objtypes.ads
@@ -217,6 +217,16 @@ package Elab.Vhdl_Objtypes is
 
    Null_Memtyp : constant Memtyp := (null, null);
 
+   --  Representation of an access: a pointer inside the heap.
+   type Heap_Ptr is new Memory_Ptr;
+   Null_Heap_Ptr : constant Heap_Ptr := null;
+
+   Heap_Ptr_Sz : constant Size_Type := Size_Type (Heap_Ptr'Size / 8);
+
+   Heap_Ptr_Al : constant Palign_Type :=
+     2 * Boolean'Pos (Heap_Ptr_Sz = 4)
+     + 3 * Boolean'Pos (Heap_Ptr_Sz = 8);
+
    --  Memory pools, which defines where the memory is allocated for data,
    --  types, values...
 
diff --git a/src/synth/elab-vhdl_values-debug.adb b/src/synth/elab-vhdl_values-debug.adb
index 63718b55d..de640eae8 100644
--- a/src/synth/elab-vhdl_values-debug.adb
+++ b/src/synth/elab-vhdl_values-debug.adb
@@ -20,6 +20,7 @@ with Simple_IO; use Simple_IO;
 with Utils_IO; use Utils_IO;
 
 with Vhdl.Nodes; use Vhdl.Nodes;
+with Elab.Vhdl_Heap;
 
 package body Elab.Vhdl_Values.Debug is
    procedure Put_Dir (Dir : Direction_Type) is
@@ -273,7 +274,7 @@ package body Elab.Vhdl_Values.Debug is
             Put_Int64 (Read_Discrete (M));
          when Type_Access =>
             Put ("access: ");
-            Put_Uns32 (Uns32 (Read_Access (M)));
+            Put_Uns32 (Uns32 (Elab.Vhdl_Heap.Get_Index (Read_Access (M))));
          when Type_File =>
             Put ("file");
          when Type_Float =>
diff --git a/src/synth/elab-vhdl_values.adb b/src/synth/elab-vhdl_values.adb
index d1bdf15be..0a1a4b982 100644
--- a/src/synth/elab-vhdl_values.adb
+++ b/src/synth/elab-vhdl_values.adb
@@ -357,25 +357,25 @@ package body Elab.Vhdl_Values is
       return Res;
    end Unshare;
 
-   procedure Write_Access (Mem : Memory_Ptr; Val : Heap_Index)
+   procedure Write_Access (Mem : Memory_Ptr; Val : Heap_Ptr)
    is
-      V : Heap_Index;
+      V : Heap_Ptr;
       for V'Address use Mem.all'Address;
       pragma Import (Ada, V);
    begin
       V := Val;
    end Write_Access;
 
-   function Read_Access (Mem : Memory_Ptr) return Heap_Index
+   function Read_Access (Mem : Memory_Ptr) return Heap_Ptr
    is
-      V : Heap_Index;
+      V : Heap_Ptr;
       for V'Address use Mem.all'Address;
       pragma Import (Ada, V);
    begin
       return V;
    end Read_Access;
 
-   function Read_Access (Mt : Memtyp) return Heap_Index is
+   function Read_Access (Mt : Memtyp) return Heap_Ptr is
    begin
       return Read_Access (Mt.Mem);
    end Read_Access;
@@ -430,7 +430,7 @@ package body Elab.Vhdl_Values is
       return Read_Fp64 (Vt.Val.Mem);
    end Read_Fp64;
 
-   function Read_Access (Vt : Valtyp) return Heap_Index is
+   function Read_Access (Vt : Valtyp) return Heap_Ptr is
    begin
       pragma Assert (Vt.Typ.Kind = Type_Access);
       return Read_Access (Get_Memory (Vt));
@@ -526,7 +526,7 @@ package body Elab.Vhdl_Values is
                                     Typ.Rec.E (I).Typ);
             end loop;
          when Type_Access =>
-            Write_Access (M, Null_Heap_Index);
+            Write_Access (M, Null_Heap_Ptr);
          when Type_File
            |  Type_Protected =>
             raise Internal_Error;
@@ -542,7 +542,7 @@ package body Elab.Vhdl_Values is
       return Res;
    end Create_Value_Default;
 
-   function Create_Value_Access (Val : Heap_Index; Acc_Typ : Type_Acc)
+   function Create_Value_Access (Val : Heap_Ptr; Acc_Typ : Type_Acc)
                                 return Valtyp
    is
       Res : Valtyp;
diff --git a/src/synth/elab-vhdl_values.ads b/src/synth/elab-vhdl_values.ads
index adf11ae8e..21ea4a35b 100644
--- a/src/synth/elab-vhdl_values.ads
+++ b/src/synth/elab-vhdl_values.ads
@@ -70,9 +70,6 @@ package Elab.Vhdl_Values is
 
    type Value_Acc is access Value_Type;
 
-   type Heap_Index is new Uns32;
-   Null_Heap_Index : constant Heap_Index := 0;
-
    type Protected_Index is new Uns32;
    No_Protected_Index : constant Protected_Index := 0;
 
@@ -164,7 +161,7 @@ package Elab.Vhdl_Values is
    function Create_Value_Discrete (Val : Int64; Vtype : Type_Acc)
                                   return Valtyp;
 
-   function Create_Value_Access (Val : Heap_Index; Acc_Typ : Type_Acc)
+   function Create_Value_Access (Val : Heap_Ptr; Acc_Typ : Type_Acc)
                                 return Valtyp;
 
    function Create_Value_Float (Val : Fp64; Vtype : Type_Acc) return Valtyp;
@@ -228,9 +225,9 @@ package Elab.Vhdl_Values is
    procedure Write_Discrete (Vt : Valtyp; Val : Int64);
    function Read_Discrete (Vt : Valtyp) return Int64;
 
-   procedure Write_Access (Mem : Memory_Ptr; Val : Heap_Index);
-   function Read_Access (Mt : Memtyp) return Heap_Index;
-   function Read_Access (Vt : Valtyp) return Heap_Index;
+   procedure Write_Access (Mem : Memory_Ptr; Val : Heap_Ptr);
+   function Read_Access (Mt : Memtyp) return Heap_Ptr;
+   function Read_Access (Vt : Valtyp) return Heap_Ptr;
 
    procedure Write_Protected (Mem : Memory_Ptr; Idx : Protected_Index);
    function Read_Protected (Mem : Memory_Ptr) return Protected_Index;
diff --git a/src/synth/synth-vhdl_expr.adb b/src/synth/synth-vhdl_expr.adb
index d194c4dcd..d1d705592 100644
--- a/src/synth/synth-vhdl_expr.adb
+++ b/src/synth/synth-vhdl_expr.adb
@@ -800,12 +800,12 @@ package body Synth.Vhdl_Expr is
            | Iir_Kind_Dereference =>
             declare
                Val : Valtyp;
-               Acc : Heap_Index;
+               Acc : Heap_Ptr;
                Obj : Memtyp;
             begin
                Val := Synth_Expression (Syn_Inst, Get_Prefix (Name));
                Acc := Read_Access (Val);
-               if Acc = Null_Heap_Index then
+               if Acc = Null_Heap_Ptr then
                   Error_Msg_Synth (Syn_Inst, Name, "NULL access dereferenced");
                   return No_Valtyp;
                end if;
@@ -2531,13 +2531,13 @@ package body Synth.Vhdl_Expr is
                return Create_Value_Memtyp (Mt);
             end;
          when Iir_Kind_Null_Literal =>
-            return Create_Value_Access (Null_Heap_Index, Expr_Type);
+            return Create_Value_Access (Null_Heap_Ptr, Expr_Type);
          when Iir_Kind_Allocator_By_Subtype =>
             declare
                Acc_Typ : constant Type_Acc :=
                  Get_Subtype_Object (Syn_Inst, Get_Type (Expr));
                T : Type_Acc;
-               Acc : Heap_Index;
+               Acc : Heap_Ptr;
             begin
                T := Synth_Subtype_Indication
                  (Syn_Inst, Get_Subtype_Indication (Expr));
@@ -2549,7 +2549,7 @@ package body Synth.Vhdl_Expr is
                Acc_Typ : constant Type_Acc :=
                  Get_Subtype_Object (Syn_Inst, Get_Type (Expr));
                V : Valtyp;
-               Acc : Heap_Index;
+               Acc : Heap_Ptr;
             begin
                V := Synth_Expression_With_Type
                  (Syn_Inst, Get_Expression (Expr), Expr_Type.Acc_Acc);
diff --git a/src/synth/synth-vhdl_static_proc.adb b/src/synth/synth-vhdl_static_proc.adb
index fdc33b121..80bb91513 100644
--- a/src/synth/synth-vhdl_static_proc.adb
+++ b/src/synth/synth-vhdl_static_proc.adb
@@ -24,6 +24,7 @@ with Vhdl.Errors; use Vhdl.Errors;
 
 with Elab.Memtype;
 with Elab.Vhdl_Values; use Elab.Vhdl_Values;
+with Elab.Vhdl_Objtypes;
 with Elab.Vhdl_Heap;
 with Elab.Vhdl_Files; use Elab.Vhdl_Files;
 with Elab.Debugger;
@@ -36,18 +37,19 @@ package body Synth.Vhdl_Static_Proc is
 
    procedure Synth_Deallocate (Syn_Inst : Synth_Instance_Acc; Imp : Node)
    is
+      use Elab.Vhdl_Objtypes;
       Inter : constant Node := Get_Interface_Declaration_Chain (Imp);
       Param : constant Valtyp := Get_Value (Syn_Inst, Inter);
-      Val : Heap_Index;
+      Val : Heap_Ptr;
    begin
       if not Is_Static (Param.Val) then
          --  Certainly an error (and certainly already reported).
          return;
       end if;
       Val := Read_Access (Param);
-      if Val /= Null_Heap_Index then
+      if Val /= Null_Heap_Ptr then
          Elab.Vhdl_Heap.Synth_Deallocate (Val);
-         Write_Access (Param.Val.Mem, Null_Heap_Index);
+         Write_Access (Param.Val.Mem, Null_Heap_Ptr);
       end if;
    end Synth_Deallocate;
 
diff --git a/src/synth/synth-vhdl_stmts.adb b/src/synth/synth-vhdl_stmts.adb
index 52f08ce86..78a177359 100644
--- a/src/synth/synth-vhdl_stmts.adb
+++ b/src/synth/synth-vhdl_stmts.adb
@@ -298,13 +298,13 @@ package body Synth.Vhdl_Stmts is
            | Iir_Kind_Dereference =>
             declare
                Acc : Memtyp;
-               Idx : Heap_Index;
+               Idx : Heap_Ptr;
             begin
                Synth_Assignment_Prefix
                  (Syn_Inst, Get_Prefix (Pfx), Dest_Base, Dest_Typ, Dest_Off);
                Acc := (Dest_Typ, Dest_Base.Val.Mem + Dest_Off.Mem_Off);
                Idx := Read_Access (Acc);
-               if Idx = Null_Heap_Index then
+               if Idx = Null_Heap_Ptr then
                   Error_Msg_Synth (Syn_Inst, Pfx, "NULL access dereferenced");
                   Dest_Base := No_Valtyp;
                   Dest_Typ := Dest_Typ.Acc_Acc;