hashtable.icl 13.4 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
implementation module hashtable

3
import predef, syntax, compare_types, compare_constructor
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4

5
::	HashTableEntry
6
		= HTE_Ident !BoxedIdent !IdentClass !Int !HashTableEntry !HashTableEntry
7
		| HTE_Empty 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
8
9
10
11

::	HashTable =
	{	hte_symbol_heap	:: !.SymbolTable
	,	hte_entries		:: !.{! .HashTableEntry}
12
	,	hte_mark	:: !Int // 1 for .icl modules, otherwise 0
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
13
14
15
16
17
18
	}

::	IdentClass	= IC_Expression
				| IC_Type
				| IC_TypeAttr
				| IC_Class
19
				| IC_Module !QualifiedIdents
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
20
21
22
				| IC_Field !Ident
				| IC_Selector
				| IC_Instance ![Type]
23
				| IC_InstanceMember ![Type]
24
25
				| IC_Generic
				| IC_GenericCase !Type
26
				| IC_GenericDeriveClass !Type
27
				| IC_TypeExtension !{#Char}/*module name*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
28
29
				| IC_Unknown

30
31
32
::	QualifiedIdents	= QualifiedIdents !Ident !IdentClass !QualifiedIdents
					| NoQualifiedIdents;

33
34
:: BoxedIdent = {boxed_ident::!Ident}

35
newHashTable :: !*SymbolTable -> *HashTable
36
newHashTable symbol_heap = { hte_symbol_heap = symbol_heap, hte_entries = {  HTE_Empty \\ i <- [0 .. dec cHashTableSize] },hte_mark=0}
37
38
39

set_hte_mark :: !Int !*HashTable -> *HashTable
set_hte_mark hte_mark ht = {ht & hte_mark=hte_mark}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
40
41
42
43

instance =< IdentClass
where
	(=<) (IC_Instance types1) (IC_Instance types2)
44
		= compareInstances types1 types2
45
46
	(=<) (IC_InstanceMember types1) (IC_InstanceMember types2)
		= compare_types types1 types2
47
	(=<) (IC_GenericCase type1) (IC_GenericCase type2)
48
49
50
51
		# cmp = type1 =< type2
		| cmp == Equal
			= compare_unboxed_array_element_type type1 type2
			= cmp
52
	(=<) (IC_GenericDeriveClass type1) (IC_GenericDeriveClass type2)
53
54
55
56
		# cmp = type1 =< type2
		| cmp == Equal
			= compare_unboxed_array_element_type type1 type2
			= cmp
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
57
58
	(=<) (IC_Field typ_id1) (IC_Field typ_id2)
		= typ_id1 =< typ_id2
59
60
	(=<) (IC_TypeExtension module_name1) (IC_TypeExtension module_name2)
		= module_name1=<module_name2
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
61
62
63
64
65
66
67
	(=<) ic1 ic2
		| equal_constructor ic1 ic2
			= Equal
		| less_constructor ic1 ic2
			= Smaller
			= Greater

68
69
70
71
72
73
74
75
76
77
78
79
compare_types [t1 : t1s] [t2 : t2s]
	# cmp = t1 =< t2
	| cmp == Equal
		= t1s =< t2s
		= cmp
compare_types [] []
	= Equal
compare_types [] _
	= Smaller
compare_types _ []
	= Greater

80
81
82
83
84
85
86
87
88
89
compare_unboxed_array_element_type (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type1}]) (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type2}])
	= compare_unboxed_array_element_type` element_type1 element_type2
where
	compare_unboxed_array_element_type` (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type1}]) (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type2}])
		= compare_unboxed_array_element_type` element_type1 element_type2
	compare_unboxed_array_element_type` t1 t2
		= t1 =< t2
compare_unboxed_array_element_type t1 t2
	= Equal

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
90
91
92
93
94
95
96
97
98
99
100
101
instance =< (!a,!b) |  =< a &  =< b
where
	(=<) (x1,y1) (x2,y2)
		# cmp = x1 =< x2
		| cmp == Equal
			= y1 =< y2
			= cmp

cHashTableSize	:==	1023

hashValue :: !String -> Int
hashValue name
John van Groningen's avatar
John van Groningen committed
102
	# hash_val = hash_value name (size name) 0 rem cHashTableSize
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
103
104
105
106
107
108
109
110
111
112
113
114
	| hash_val < 0
		= hash_val + cHashTableSize
		= hash_val
where
	hash_value :: !String !Int !Int -> Int
	hash_value name index val
		| index == 0
			= val
		# index = dec index
		  char = name.[index]
		= hash_value name index (val << 2 + toInt char)

115
116
117
putIdentInHashTable :: !String !IdentClass !*HashTable -> (!BoxedIdent, !*HashTable)
putIdentInHashTable name ident_class {hte_symbol_heap,hte_entries,hte_mark}
	# hash_val = hashValue name
118
	  (entries,hte_entries) = hte_entries![hash_val]
119
	  (ident, hte_symbol_heap, entries) = insert name ident_class hte_mark hte_symbol_heap entries
120
	  hte_entries = {hte_entries & [hash_val]=entries}
121
122
123
124
125
126
	= (ident, { hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries,hte_mark=hte_mark })
where
	insert ::  !String !IdentClass !Int !*SymbolTable *HashTableEntry -> (!BoxedIdent, !*SymbolTable, !*HashTableEntry)
	insert name ident_class hte_mark0 hte_symbol_heap HTE_Empty
		# (hte_symbol_ptr, hte_symbol_heap) = newPtr EmptySymbolTableEntry hte_symbol_heap
		# ident = { id_name = name, id_info = hte_symbol_ptr}
127
128
		# boxed_ident={boxed_ident=ident}
		= (boxed_ident, hte_symbol_heap, HTE_Ident boxed_ident ident_class hte_mark0 HTE_Empty HTE_Empty)
129
	insert name ident_class hte_mark0 hte_symbol_heap (HTE_Ident hte_ident=:{boxed_ident={id_name}} hte_class hte_mark hte_left hte_right)
130
131
		# cmp = (name,ident_class) =< (id_name,hte_class)
		| cmp == Equal
132
			= (hte_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class (hte_mark bitand hte_mark0) hte_left hte_right)
133
134
135
136
137
138
		| cmp == Smaller
			#! (boxed_ident, hte_symbol_heap, hte_left) = insert name ident_class hte_mark0 hte_symbol_heap hte_left
			= (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
			#! (boxed_ident, hte_symbol_heap, hte_right) = insert name ident_class hte_mark0 hte_symbol_heap hte_right
			= (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)

139
140
141
putQualifiedIdentInHashTable :: !String !BoxedIdent !IdentClass !*HashTable -> (!BoxedIdent, !*HashTable)
putQualifiedIdentInHashTable module_name ident ident_class {hte_symbol_heap,hte_entries,hte_mark}
	# hash_val = hashValue module_name
142
	  (entries,hte_entries) = hte_entries![hash_val]
143
	  (ident, hte_symbol_heap, entries) = insert module_name ident ident_class (IC_Module NoQualifiedIdents) hte_mark hte_symbol_heap entries
144
	  hte_entries = {hte_entries & [hash_val]=entries}
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
	= (ident, { hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries,hte_mark=hte_mark })
where
	insert :: !String !BoxedIdent !IdentClass !IdentClass !Int !*SymbolTable *HashTableEntry -> (!BoxedIdent, !*SymbolTable, !*HashTableEntry)
	insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap HTE_Empty
		# (hte_symbol_ptr, hte_symbol_heap) = newPtr EmptySymbolTableEntry hte_symbol_heap
		# module_ident = { id_name = module_name, id_info = hte_symbol_ptr}
		# boxed_module_ident={boxed_ident=module_ident}
		# ident_class = IC_Module (QualifiedIdents ident.boxed_ident ident_class NoQualifiedIdents)
		= (boxed_module_ident, hte_symbol_heap, HTE_Ident boxed_module_ident ident_class hte_mark0 HTE_Empty HTE_Empty)
	insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap (HTE_Ident hte_ident=:{boxed_ident={id_name}} hte_class hte_mark hte_left hte_right)
		# cmp = (module_name,module_ident_class) =< (id_name,hte_class)
		| cmp == Equal
			# (IC_Module qualified_idents) = hte_class
			  qualified_idents = QualifiedIdents ident.boxed_ident ident_class qualified_idents
			= (hte_ident, hte_symbol_heap, HTE_Ident hte_ident (IC_Module qualified_idents) (hte_mark bitand hte_mark0) hte_left hte_right)
		| cmp == Smaller
			#! (boxed_ident, hte_symbol_heap, hte_left) = insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap hte_left
			= (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
			#! (boxed_ident, hte_symbol_heap, hte_right) = insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap hte_right
			= (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)

John van Groningen's avatar
John van Groningen committed
166
putPredefinedIdentInHashTable :: !Ident !IdentClass !*HashTable -> *HashTable
167
168
putPredefinedIdentInHashTable predefined_ident=:{id_name} ident_class {hte_symbol_heap,hte_entries,hte_mark}
	# hash_val = hashValue id_name
169
	  (entries,hte_entries) = hte_entries![hash_val]
170
	  (hte_symbol_heap, entries) = insert id_name ident_class hte_mark hte_symbol_heap entries
171
	  hte_entries = {hte_entries & [hash_val]=entries}
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
	= { hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries,hte_mark=hte_mark }
where
	insert ::  !String !IdentClass !Int !*SymbolTable *HashTableEntry -> (!*SymbolTable, !*HashTableEntry)
	insert name ident_class hte_mark0 hte_symbol_heap HTE_Empty
		# hte_symbol_heap = writePtr predefined_ident.id_info EmptySymbolTableEntry hte_symbol_heap
		# boxed_ident={boxed_ident=predefined_ident}
		= (hte_symbol_heap, HTE_Ident boxed_ident ident_class hte_mark0 HTE_Empty HTE_Empty)
	insert name ident_class hte_mark0 hte_symbol_heap (HTE_Ident hte_ident=:{boxed_ident={id_name,id_info}} hte_class hte_mark hte_left hte_right)
		# cmp = (name,ident_class) =< (id_name,hte_class)
		| cmp == Equal
			= (hte_symbol_heap, HTE_Ident hte_ident hte_class (hte_mark bitand hte_mark0) hte_left hte_right)
		| cmp == Smaller
			#! (hte_symbol_heap, hte_left) = insert name ident_class hte_mark0 hte_symbol_heap hte_left
			= (hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
			#! (hte_symbol_heap, hte_right) = insert name ident_class hte_mark0 hte_symbol_heap hte_right
			= (hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)

189
190
191
get_qualified_idents_from_hash_table :: !Ident !*HashTable -> (!QualifiedIdents,!*HashTable)
get_qualified_idents_from_hash_table module_ident=:{id_name} hash_table=:{hte_entries}
	# hash_val = hashValue id_name
192
	  (entries,hte_entries) = hte_entries![hash_val]
193
	  (qualified_idents, entries) = find_qualified_idents id_name (IC_Module NoQualifiedIdents) entries
194
	  hte_entries = {hte_entries & [hash_val] = entries}
195
196
197
198
199
200
201
202
203
204
205
206
207
208
	= (qualified_idents, {hash_table & hte_entries = hte_entries})
where
	find_qualified_idents :: !String !IdentClass *HashTableEntry -> (!QualifiedIdents, !*HashTableEntry)
	find_qualified_idents module_name module_ident_class hte=:(HTE_Ident hte_ident=:{boxed_ident={id_name}} hte_class hte_mark hte_left hte_right)
		# cmp = (module_name,module_ident_class) =< (id_name,hte_class)
		| cmp == Equal
			# (IC_Module qualified_idents) = hte_class
			= (qualified_idents, hte)
		| cmp == Smaller
			#! (qualified_idents, hte_left) = find_qualified_idents module_name module_ident_class hte_left
			= (qualified_idents, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
			#! (qualified_idents, hte_right) = find_qualified_idents module_name module_ident_class hte_right
			= (qualified_idents, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)

209
210
211
212
213
214
215
remove_icl_symbols_from_hash_table :: !*HashTable -> *HashTable
remove_icl_symbols_from_hash_table hash_table=:{hte_entries}
	# hte_entries=remove_icl_symbols_from_array 0 hte_entries
	= {hash_table & hte_entries=hte_entries}
	where
		remove_icl_symbols_from_array i hte_entries
			 | i<size hte_entries
216
			 	# (entries,hte_entries) = hte_entries![i]
217
				# (_,entries) = remove_icl_entries_from_tree entries
218
				# hte_entries = {hte_entries & [i] = entries}
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
				= remove_icl_symbols_from_array (i+1) hte_entries
				= hte_entries

		// a tuple with a dummy value is used to change the calling convention to improve reuse of nodes
		remove_icl_entries_from_tree :: !*HashTableEntry -> (!Int,!.HashTableEntry);
		remove_icl_entries_from_tree HTE_Empty
			= (0,HTE_Empty)
		remove_icl_entries_from_tree (HTE_Ident hte_ident hte_class 0 hte_left hte_right)
			# (_,hte_left) = remove_icl_entries_from_tree hte_left
			# (_,hte_right) = remove_icl_entries_from_tree hte_right
			= (0,HTE_Ident hte_ident hte_class 0 hte_left hte_right)
		remove_icl_entries_from_tree (HTE_Ident hte_ident hte_class _ hte_left hte_right)
			# (depth_left,hte_left) = remove_icl_entries_from_tree_and_compute_depth hte_left
			# (depth_right,hte_right) = remove_icl_entries_from_tree_and_compute_depth hte_right
			= merge_trees hte_left hte_right depth_left depth_right

		remove_icl_entries_from_tree_and_compute_depth :: !*HashTableEntry -> (!Int,!.HashTableEntry);
		remove_icl_entries_from_tree_and_compute_depth HTE_Empty
			= (0,HTE_Empty)
		remove_icl_entries_from_tree_and_compute_depth (HTE_Ident hte_ident hte_class 0 hte_left hte_right)
			# (depth_left,hte_left) = remove_icl_entries_from_tree_and_compute_depth hte_left
			# (depth_right,hte_right) = remove_icl_entries_from_tree_and_compute_depth hte_right
			= (if (depth_left>=depth_right) depth_left depth_right,HTE_Ident hte_ident hte_class 0 hte_left hte_right)
		remove_icl_entries_from_tree_and_compute_depth (HTE_Ident hte_ident hte_class _ hte_left hte_right)
			# (depth_left,hte_left) = remove_icl_entries_from_tree_and_compute_depth hte_left
			# (depth_right,hte_right) = remove_icl_entries_from_tree_and_compute_depth hte_right
			= merge_trees hte_left hte_right depth_left depth_right
		
		// the returned depth is an estimate
		merge_trees :: !*HashTableEntry !*HashTableEntry !Int !Int -> (!Int,!.HashTableEntry)
		merge_trees HTE_Empty hte_right depth_left depth_right
			= (depth_right,hte_right)
		merge_trees hte_left HTE_Empty depth_left depth_right
			= (depth_left,hte_left)
		merge_trees hte_left hte_right depth_left depth_right
			| depth_left>=depth_right
				= merge_trees_left hte_left hte_right depth_left depth_right
				= merge_trees_right hte_left hte_right depth_left depth_right
		where
				merge_trees_left :: !*HashTableEntry !*HashTableEntry !Int !Int -> (!Int,!.HashTableEntry)
				merge_trees_left (HTE_Ident hte_ident hte_class hte_mark hte_left_left hte_left_right) hte_right depth_left depth_right
					# (depth_right,hte_right)=merge_trees hte_left_right hte_right (depth_left-1) depth_right
					# depth_right=depth_right+1
					= (if (depth_left>=depth_right) depth_left depth_right,HTE_Ident hte_ident hte_class hte_mark hte_left_left hte_right)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
263

264
265
266
267
268
				merge_trees_right :: !*HashTableEntry !*HashTableEntry !Int !Int -> (!Int,!.HashTableEntry)
				merge_trees_right hte_left (HTE_Ident hte_ident hte_class hte_mark hte_right_left hte_right_right) depth_left depth_right
					# (depth_left,hte_left)=merge_trees hte_left hte_right_left depth_left (depth_right-1)
					# depth_left=depth_left+1
					= (if (depth_left>=depth_right) depth_left depth_right,HTE_Ident hte_ident hte_class hte_mark hte_left hte_right_right)