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;
|
