aboutsummaryrefslogtreecommitdiffstats
path: root/src/dyn_interning.adb
blob: 96f4edc046e25545684472ef3698e443214f493d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
--  Type interning - set of unique objects.
--  Copyright (C) 2019 Tristan Gingold
--
--  GHDL is free software; you can redistribute it and/or modify it under
--  the terms of the GNU General Public License as published by the Free
--  Software Foundation; either version 2, or (at your option) any later
--  version.
--
--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
--  for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with GHDL; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.

with Ada.Unchecked_Deallocation;

package body Dyn_Interning is
   procedure Deallocate is new Ada.Unchecked_Deallocation
     (Hash_Array, Hash_Array_Acc);

   procedure Init (Inst : out Instance) is
   begin
      Inst.Size := Initial_Size;
      Inst.Hash_Table := new Hash_Array'(0 .. Initial_Size - 1 => No_Index);
      Wrapper_Tables.Init (Inst.Els);
      pragma Assert (Wrapper_Tables.Last (Inst.Els) = No_Index);
   end Init;

   procedure Free (Inst : in out Instance) is
   begin
      Deallocate (Inst.Hash_Table);
      Inst.Size := 0;
      Wrapper_Tables.Free (Inst.Els);
   end Free;

   --  Expand the hash table (double the size).
   procedure Expand (Inst : in out Instance)
   is
      Old_Hash_Table : Hash_Array_Acc;
      Idx : Index_Type;
   begin
      Old_Hash_Table := Inst.Hash_Table;
      Inst.Size := Inst.Size * 2;
      Inst.Hash_Table := new Hash_Array'(0 .. Inst.Size - 1 => No_Index);

      --  Rehash.
      for I in Old_Hash_Table'Range loop
         Idx := Old_Hash_Table (I);
         while Idx /= No_Index loop
            --  Note: collisions are put in reverse order.
            declare
               Ent : Element_Wrapper renames Inst.Els.Table (Idx);
               Hash_Index : constant Hash_Value_Type :=
                 Ent.Hash and (Inst.Size - 1);
               Next_Idx : constant Index_Type := Ent.Next;
            begin
               Ent.Next := Inst.Hash_Table (Hash_Index);
               Inst.Hash_Table (Hash_Index) := Idx;
               Idx := Next_Idx;
            end;
         end loop;
      end loop;

      Deallocate (Old_Hash_Table);
   end Expand;

   procedure Get_Index
     (Inst : in out Instance; Params : Params_Type; Idx : out Index_Type)
   is
      Hash_Value : Hash_Value_Type;
      Hash_Index : Hash_Value_Type;
   begin
      --  Check if the package was initialized.
      pragma Assert (Inst.Hash_Table /= null);

      Hash_Value := Hash (Params);
      Hash_Index := Hash_Value and (Inst.Size - 1);

      Idx := Inst.Hash_Table (Hash_Index);
      while Idx /= No_Index loop
         declare
            E : Element_Wrapper renames Inst.Els.Table (Idx);
         begin
            if E.Hash = Hash_Value and then Equal (E.Obj, Params) then
               return;
            end if;
            Idx := E.Next;
         end;
      end loop;

      --  Maybe expand the table.
      if Hash_Value_Type (Wrapper_Tables.Last (Inst.Els)) > 2 * Inst.Size then
         Expand (Inst);

         --  Recompute hash index.
         Hash_Index := Hash_Value and (Inst.Size - 1);
      end if;

      declare
         Res : Object_Type;
      begin
         Res := Build (Params);

         --  Insert.
         Wrapper_Tables.Append (Inst.Els,
                                (Hash => Hash_Value,
                                 Next => Inst.Hash_Table (Hash_Index),
                                 Obj => Res));
         Inst.Hash_Table (Hash_Index) := Wrapper_Tables.Last (Inst.Els);
      end;

      Idx := Wrapper_Tables.Last (Inst.Els);
   end Get_Index;

   procedure Get
     (Inst : in out Instance; Params : Params_Type; Res : out Object_Type)
   is
      Idx : Index_Type;
   begin
      Get_Index (Inst, Params, Idx);
      Res := Get_By_Index (Inst, Idx);
   end Get;

   function Last_Index (Inst : Instance) return Index_Type is
   begin
      return Wrapper_Tables.Last (Inst.Els);
   end Last_Index;

   function Get_By_Index (Inst : Instance; Index : Index_Type)
                         return Object_Type is
   begin
      pragma Assert (Index <= Wrapper_Tables.Last (Inst.Els));
      return Inst.Els.Table (Index).Obj;
   end Get_By_Index;
end Dyn_Interning;