bootstrap

view church/runtime/hashtable.state @ 867:3557dbdaf618

find changesets by author, revision, files, or words in the commit message
add new macros for getting and setting array values, which can work on both byte and word sized arrays

comment out some debugging print statements
author John Leuner <jewel@subvert-the-dominant-paradigm.net>
date Sun Apr 15 19:17:11 2012 +0200 (4 weeks ago)
parents 9ec3d595e7c3
children
line source
1 (include "church/runtime/church_types.state")
2 (include "church/runtime/church_syntax.state")
3
4
5 (external-function |state-gc-alloc|)
6 (external-function |state-gc-alloc-and-zero|)
7 (external-function state-abort)
8 (external-function church-cons)
9
10 ; new hash table
11
12 (define church-hashtable-allocate (lambda (size)
13 (church-assert (church-> size 0) "size must be greater than 0")
14 (if (not (= (band size (- size 1)) 0))
15 (let ((highest-bit (bsr size))
16 (new-size (bshl 1 (+ highest-bit 1))))
17 ; (call-c-extern printf "given size %lu, new size %lu
18 ;" size new-size)
19 (set! size new-size) ))
20 ; size must be a power of 2
21 (church-assert (church-= (band size (- size 1)) 0) "hash table size must be a power of 2")
22 ; hash table is 8 words, plus 2 * size words
23 (let ((ht-alloc-size (+ (* 8 CHURCH_WORD_SIZE) (* size (* 2 CHURCH_WORD_SIZE))))
24 (ht (state-gc-alloc-and-zero ht-alloc-size)))
25 ; clear memory
26 (call-c-extern memset ht 0 ht-alloc-size)
27
28 (set-hashtable-size! ht size)
29 (set-hashtable-count! ht 0)
30
31
32 ; (do ((i 0 (+ i 1)))
33 ; (< i (hashtable-size ht))
34 ; (if (not (= (deref (hashtable-table ht) (* 8 i)) 0))
35 ; (begin
36 ; (call-c-extern printf "ht %p
37 ;" ht)
38 ; (state-abort "dirty hashtable"))))
39
40
41 ht)))
42
43 ;(define church-hashtable-set-functions (lambda (ht hash-fn comp-fn)
44 ; (set-hashtable-hash-function! ht hash-fn)
45 ; (set-hashtable-comp-function! ht comp-fn)
46 ; ht))
47 ;; set hash and compare function
48 (define church-hashtable-set-functions (lambda (ht hash-fn1 hash-fn2 comp-fn)
49 (set-hashtable-hash-function1! ht hash-fn1)
50 (set-hashtable-hash-function2! ht hash-fn2)
51 (set-hashtable-comp-function! ht comp-fn)
52 ht))
53
54 (define church-hashtable-has-key? (lambda (ht key)
55 (let ((hash-table (hashtable-table ht))
56 (hash-table-size (hashtable-size ht))
57 (comp-fn (hashtable-comp-function ht))
58 (h ((hashtable-hash-function1 ht) key))
59 (index (* (mod h hash-table-size) 2))
60 (probe-step ((hashtable-hash-function2 ht) key)))
61 (tagbody
62 check
63 (let ((lookup (deref hash-table (* index CHURCH_WORD_SIZE))))
64 (if (= lookup 0)
65 (return TAG_NIL)
66 )
67 (if (= (comp-fn lookup key) 0)
68 (return TAG_TRUE)
69 ))
70 (set! h (+ h probe-step))
71 ; mask out high bit
72 (set! h (band h (band -1 (bnot (bshl 1 31)))))
73 (set! index (* (mod h hash-table-size) 2))
74 (go check)))))
75
76 (define church-hashtable-lookup-key (lambda (ht key default-value)
77 (let ((hash-table (hashtable-table ht))
78 (hash-table-size (hashtable-size ht))
79 (hash-fn (hashtable-hash-function1 ht))
80 (comp-fn (hashtable-comp-function ht))
81 (h (hash-fn key))
82 (index (* (mod h hash-table-size) 2))
83 (probe-step ((hashtable-hash-function2 ht) key)))
84 (tagbody
85 check
86 ; (call-c-extern printf "find_hash_entry at index %lu
87 ;" base-index)
88 (let ((lookup (deref hash-table (* index CHURCH_WORD_SIZE))))
89 (if (= lookup 0)
90 (return default-value)
91 )
92 (if (= (comp-fn lookup key) 0)
93 (return (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)))
94 ))
95 (set! h (+ h probe-step))
96 ; mask out high bit
97 (set! h (band h (band -1 (bnot (bshl 1 31)))))
98 (set! index (* (mod h hash-table-size) 2))
99 (go check)))
100 (state-abort "failed find hash entry")))
101
102 (define church-hashtable-add-or-replace (lambda (ht key value)
103 ; (call-c-extern printf "church-hashtable-add-or-replace %p size %lu count %lu
104 ;" ht (hashtable-size ht) (hashtable-count ht))
105 (let ((new-count (church-hashtable-add-or-replace-helper ht key value)))
106 (if (> new-count 0)
107 (begin
108 (set-hashtable-count! ht (+ (hashtable-count ht) 1))
109 ; (call-c-extern printf "ht %p count %lu size %lu
110 ;" ht (hashtable-count ht) (hashtable-size ht))
111 ; check if we should grow
112 (if (> (/ (* (hashtable-count ht) 100) (hashtable-size ht)) 60)
113 (let ((newsize (* (hashtable-size ht) 2))
114 (new-ht (church-hashtable-allocate newsize)))
115 ; copy the old functions into the new table
116 (church-hashtable-set-functions new-ht (hashtable-hash-function1 ht) (hashtable-hash-function2 ht) (hashtable-comp-function ht))
117 (church-hashtable-rehash-from-old-table ht new-ht)
118 (return new-ht))
119 ht))
120 ht))))
121
122 (define church-hashtable-add-or-replace-helper (lambda (ht key value)
123 (let ((hash-table (hashtable-table ht))
124 (hash-table-size (hashtable-size ht))
125 (hash-fn (hashtable-hash-function1 ht))
126 (comp-fn (hashtable-comp-function ht))
127 (h (hash-fn key))
128 (index (* (mod h hash-table-size) 2))
129 (probe-step ((hashtable-hash-function2 ht) key)))
130 (tagbody
131 check
132 ; (call-c-extern printf "ht %p h %p index %lu, key %p value %p probe-step %p
133 ;" ht h index key value probe-step)
134 (let ((lookup (deref hash-table (* index CHURCH_WORD_SIZE))))
135 (if (= lookup 0)
136 ;add a new entry
137 (begin
138 (set-long! hash-table (* index CHURCH_WORD_SIZE) key)
139 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) value)
140 (return 1))) ; 1 for new entry
141 (if (= (comp-fn lookup key) 0)
142 ; overwrite current entry
143 (begin
144 ; (call-c-extern printf "h %p index %lu at index %lu, overwrite %p %p %lu
145 ;" h index index lookup key (comp-fn lookup key))
146 (set-long! hash-table (* index CHURCH_WORD_SIZE) key)
147 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) value)
148 (return 0)))) ; 0 for replacement of old entry
149 (set! h (+ h probe-step))
150 ; mask out high bit
151 (set! h (band h (band -1 (bnot (bshl 1 31)))))
152 (set! index (* (mod h hash-table-size) 2))
153 (go check)))
154 (state-abort "failed find hash entry")))
155
156 (define church-hashtable-rehash-from-old-table (lambda (ht new-ht)
157 (let ((hash-table (hashtable-table ht))
158 (hash-table-size (hashtable-size ht)))
159 (let ((counter 0)
160 (base-index 0))
161 (tagbody
162 check
163 (if (< counter hash-table-size)
164 (let ((key (deref hash-table (* base-index CHURCH_WORD_SIZE)))
165 (value (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE))))
166 (if (not (= key 0))
167 (begin
168 (church-hashtable-add-or-replace-helper new-ht key value)
169 (set-hashtable-count! new-ht (+ (hashtable-count new-ht) 1)))
170 )
171 (set! base-index (+ base-index 2)))
172 (go end))
173 (set! counter (+ counter 1))
174 (go check)
175 end)))))
176
177 (external-function church-reverse!)
178 (define church-hashtable-keys (lambda (ht)
179 (let ((hash-table (hashtable-table ht))
180 (hash-table-size (hashtable-size ht))
181 (counter 0)
182 (base-index 0)
183 (keys TAG_NIL))
184 (tagbody
185 check
186 (if (< counter hash-table-size)
187 (let ((key (deref hash-table (* base-index CHURCH_WORD_SIZE))))
188 (if (not (= key 0))
189 (push key keys))
190 (set! base-index (+ base-index 2)))
191 (go end))
192 (set! counter (+ counter 1))
193 (go check)
194 end)
195 (church-reverse! keys))))
196
197 ; hash functions
198
199 (define church_hash_string_function (lambda (str)
200 (let ((h 0))
201 (tagbody
202 check
203 (if (= (get-byte str 0) 0)
204 (go done)
205 (begin
206 (set! h (+ (* h 31) (get-byte str 0)))
207 (set! str (+ str 1))
208 (go check)))
209 done)
210 (bshr (bshl h 1) 1) ; mask out any sign bit
211 )))
212
213 (define church_second_hash_string_function (lambda (str)
214 (let ((hash 0))
215 (tagbody
216 check
217 (if (= (get-byte str 0) 0)
218 (go done)
219 (begin
220 (set! hash (+ hash (get-byte str 0)))
221 (set! hash (+ hash (bshl hash 10)))
222 (set! hash (bxor hash (bshr hash 6)))
223 (set! str (+ str 1))
224 ))
225 done)
226 (set! hash (+ hash (bshl hash 3)))
227 (set! hash (bxor hash (bshr hash 11)))
228 (set! hash (+ hash (bshl hash 15)))
229 ; our result must always be odd to be relatively prime to the size of table (multiple of 2)
230 (bor
231 (bshr (bshl hash 1) 1) ; mask out any sign bit
232 1))))
233
234 (define church_compare_string_function (lambda (a b)
235 ; (call-c-extern printf "comparing strings %p %p '%s' '%s'
236 ;" a b a b)
237 (call-c-extern strcmp a b)))
238
239 (define church_default_hash_function (lambda (key1)
240 (let ((p 16777619)
241 (h 2166136261))
242 ; unroll 4 times for each byte in the key
243 (set! h (* p (bxor h (band key1 #xff))))
244 (set! key1 (bshr key1 8))
245 (set! h (* p (bxor h (band key1 #xff))))
246 (set! key1 (bshr key1 8))
247 (set! h (* p (bxor h (band key1 #xff))))
248 (set! key1 (bshr key1 8))
249 (set! h (* p (bxor h (band key1 #xff))))
250
251 (set! h (+ h (bshl h 13)))
252 (set! h (bxor h (bshr h 7)))
253 (set! h (+ h (bshl h 3)))
254 (set! h (bxor h (bshr h 17)))
255 (set! h (+ h (bshl h 5)))
256 (band h (band -1 (bnot (bshl 1 31))))
257 )))
258
259
260 (define church_default_second_hash_function (lambda (key1)
261 (let ((hash 0))
262 (do ((i 0 (+ i 1)))
263 (< i 4)
264 (set! hash (+ hash (band key1 #xff)))
265 (set! hash (+ hash (bshl hash 10)))
266 (set! hash (bxor hash (bshr hash 6)))
267 (set! key1 (bshr key1 8))
268 )
269 (set! hash (+ hash (bshl hash 3)))
270 (set! hash (bxor hash (bshr hash 11)))
271 (set! hash (+ hash (bshl hash 15)))
272 ; our result must always be odd to be relatively prime to the size of table (multiple of 2)
273 (bor
274 (band hash (band -1 (bnot (bshl 1 31))))
275 1))))
276
277 (define church_default_compare_function (lambda (a b)
278 (- a b)))
279
280 (external-function church_profiled_apply1)
281 (external-function church_profiled_apply2)
282 (external-function state-init-constant)
283 (external-function state-alloc-constant-vector)
284
285 (define church_equal_hash_function (lambda (obj)
286 ;(apply 'hash obj)
287 1))
288 (define church_equal_compare_function (lambda (a b)
289 (let ((result (apply 'equal? a b)))
290 (if (= result TAG_TRUE)
291 0
292 (- b a)))))
293
294
295 ; two key hashtable
296
297 ; new hash table
298
299 (define church-two-key-hashtable-allocate (lambda (size)
300 (church-assert (church-> size 0) "size must be greater than 0")
301 (if (not (= (band size (- size 1)) 0))
302 (let ((highest-bit (bsr size))
303 (new-size (bshl 1 (+ highest-bit 1))))
304 ; (call-c-extern printf "church-two-key-hashtable-allocate given size %lu, new size %lu
305 ;" size new-size)
306 (set! size new-size)))
307 ; size must be a power of 2
308 (church-assert (church-= (band size (- size 1)) 0) "hash table size must be a power of 2")
309 ; hash table is 8 words, plus 4 * size words
310 (let ((ht-alloc-size (+ (* 8 CHURCH_WORD_SIZE) (* size (* 4 CHURCH_WORD_SIZE))))
311 (ht (state-gc-alloc-and-zero ht-alloc-size)))
312 (if (= ht 0)
313 (state-abort "hash table alloc failed"))
314 ; clear memory
315 (call-c-extern memset ht 0 ht-alloc-size)
316 (set-hashtable-size! ht size)
317 (set-hashtable-count! ht 0)
318 ; 0 probes
319 ; (set-long! ht (* 7 CHURCH_WORD_SIZE) 0)
320 ht)))
321
322 ;(define church-two-key-hashtable-print-stats (lambda (ht)
323 ; (call-c-extern printf "two hash-table count %lu probes %lu, avg probes %lu
324 ;" (hashtable-count ht) (deref ht (* 7 CHURCH_WORD_SIZE)) (/ (deref ht (* 7 CHURCH_WORD_SIZE)) (hashtable-count ht) ))))
325
326
327 (define church-two-key-hashtable-has-keys? (lambda (ht key1 key2)
328 (state-abort "has keys")
329 ; unimplemented
330 ))
331
332 ; return a pointer to the result
333 ; 0 if not found
334 (define church-two-key-hashtable-lookup-keys (lambda (ht key1 key2)
335 (let ((hash-table (hashtable-table ht))
336 (hash-table-size (hashtable-size ht))
337 (h (church-two-key-hash-function key1 key2))
338 (index (* (mod h hash-table-size) 4))
339 (probe-step (church-two-key-second-hash-function key1 key2)))
340 (tagbody
341 check
342 ; note that the first key cannot be a fixnum
343 (let ((l1 (deref hash-table (* index CHURCH_WORD_SIZE)) 0))
344 (if (= l1 0)
345 (return 0))
346 (if (= l1 key1)
347 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) key2)
348 (return (+ hash-table (* (+ index 2) CHURCH_WORD_SIZE))))))
349 (set! h (+ h probe-step))
350 ; mask out high bit
351 (set! h (band h (band -1 (bnot (bshl 1 31)))))
352 (set! index (mod h hash-table-size))
353 (set! index (* index 4))
354 (go check)))
355 (state-abort "failed find hash entry")))
356
357
358 (define church-two-key-hashtable-add-or-replace (lambda (ht key1 key2 value1 value2)
359 (let ((new-count (church-two-key-hashtable-add-or-replace-helper ht key1 key2 value1 value2)))
360 ; (call-c-extern printf "after add two-key ht %p newcount %lu
361 ;" ht new-count)
362 (if (> new-count 0)
363 (begin
364 (set-hashtable-count! ht (+ (hashtable-count ht) 1))
365 ; (call-c-extern printf "after add two-key ht %p count %lu size %lu
366 ;" ht (hashtable-count ht) (hashtable-size ht))
367 ; check if we should grow
368 (if (> (/ (* (hashtable-count ht) 100) (hashtable-size ht)) 60)
369 (let ((newsize (* (hashtable-size ht) 2))
370 (new-ht (church-two-key-hashtable-allocate newsize)))
371 ;(call-c-extern printf "growing two key ht %p count %lu size %lu
372 ;" ht (hashtable-count ht) newsize)
373 ; copy the old functions into the new table
374 (church-hashtable-set-functions new-ht (hashtable-hash-function1 ht) (hashtable-hash-function2 ht) (hashtable-comp-function ht))
375 (church-two-key-hashtable-rehash-from-old-table ht new-ht)
376 (return new-ht))
377 ht))
378 ht))))
379
380 (define church-two-key-hashtable-add-or-replace-helper (lambda (ht key1 key2 value1 value2)
381 (let ((hash-table (hashtable-table ht))
382 (hash-table-size (hashtable-size ht))
383 (h (church-two-key-hash-function key1 key2))
384 (index (* (mod h hash-table-size) 4))
385 (probe-step (church-two-key-second-hash-function key1 key2)))
386 ; (call-c-extern printf "probe-step %p %lu %i
387 ;" probe-step probe-step probe-step)
388 ; (call-c-extern printf "add key1 %p key2 %p, h %p index %lu at index %lu (%p)
389 ;" key1 key2 h index index index)
390 (tagbody
391 check
392
393 (let ((l1 (deref hash-table (* index CHURCH_WORD_SIZE)) 0))
394 (if (= l1 0)
395 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) 0)
396 (begin
397 (set-long! hash-table (* index CHURCH_WORD_SIZE) key1)
398 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) key2)
399 (set-long! hash-table (* (+ index 2) CHURCH_WORD_SIZE) value1)
400 (set-long! hash-table (* (+ index 3) CHURCH_WORD_SIZE) value2)
401 (return 1) ; new entry
402 )))
403 (if (= l1 key1)
404 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) key2)
405 (begin
406 (set-long! hash-table (* index CHURCH_WORD_SIZE) key1)
407 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) key2)
408 (set-long! hash-table (* (+ index 2) CHURCH_WORD_SIZE) value1)
409 (set-long! hash-table (* (+ index 3) CHURCH_WORD_SIZE) value2)
410 (return 0) ; existing entry
411 ))))
412 ; (call-c-extern printf "add key1 %p key2 %p, h %p index %lu at index %lu (%p) PROBING
413 ;" key1 key2 h index index index)
414 ; count the number of probes
415 ; (set-long! ht (* 7 CHURCH_WORD_SIZE) (+ 1 (deref ht (* 7 CHURCH_WORD_SIZE))))
416 (set! h (+ h probe-step))
417 ; mask out high bit
418 (set! h (band h (band -1 (bnot (bshl 1 31)))))
419 ; (call-c-extern printf "h after mask %p
420 ;" h)
421 (set! index (mod h hash-table-size))
422 (set! index (* index 4))
423 ; (call-c-extern printf "index after mask %p
424 ;" index)
425 (go check)))
426 (state-abort "failed find hash entry")))
427
428 (define church-two-key-hashtable-rehash-from-old-table (lambda (ht new-ht)
429 (let ((hash-table (hashtable-table ht))
430 (hash-table-size (hashtable-size ht)))
431 (let ((counter 0)
432 (base-index 0))
433 (tagbody
434 check
435 (if (< counter hash-table-size)
436 (let ((key1 (deref hash-table (* base-index CHURCH_WORD_SIZE)))
437 (key2 (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE)))
438 (value1 (deref hash-table (* (+ base-index 2) CHURCH_WORD_SIZE) ))
439 (value2 (deref hash-table (* (+ base-index 3) CHURCH_WORD_SIZE) )) (value1 (deref hash-table (* (+ base-index 2) CHURCH_WORD_SIZE) )))
440 (if (not (and (= key1 0)
441 (= key2 0)))
442 (begin
443 (church-two-key-hashtable-add-or-replace-helper new-ht key1 key2 value1 value2)
444 (set-hashtable-count! new-ht (+ (hashtable-count new-ht) 1)))
445 )
446 (set! base-index (+ base-index 4)))
447 (go end))
448 (set! counter (+ counter 1))
449 (go check)
450 end)))))
451
452 ; Modified FNV from Pluto Scarab, http://home.comcast.net/~bretm/hash/6.html
453
454 (define church-two-key-hash-function (lambda (key1 key2)
455 (let ((p 16777619)
456 (h 2166136261))
457 (do ((i 0 (+ i 1)))
458 (< i 4)
459 (set! h (* p (bxor h (band key1 #xff))))
460 ; (call-c-extern printf "hash1 %p key1 %p
461 ;" h key1)
462 (set! key1 (bshr key1 8)))
463 (do ((i 0 (+ i 1)))
464 (< i 4)
465 (set! h (* p (bxor h (band key2 #xff))))
466 ; (call-c-extern printf "hash1 %p key2 %p
467 ;" h key2)
468 (set! key2 (bshr key2 8)))
469 (set! h (+ h (bshl h 13)))
470 (set! h (bxor h (bshr h 7)))
471 (set! h (+ h (bshl h 3)))
472 (set! h (bxor h (bshr h 17)))
473 (set! h (+ h (bshl h 5)))
474 (band h (band -1 (bnot (bshl 1 31)))) )))
475
476
477 ; Jenkins hash function from wikipedia / dr. dobbs
478
479 (define church-two-key-second-hash-function (lambda (key1 key2)
480 (let ((hash 0))
481 (do ((i 0 (+ i 1)))
482 (< i 4)
483 (set! hash (+ hash (band key1 #xff)))
484 (set! hash (+ hash (bshl hash 10)))
485 (set! hash (bxor hash (bshr hash 6)))
486 (set! key1 (bshr key1 8))
487 )
488 (do ((i 0 (+ i 1)))
489 (< i 4)
490 (set! hash (+ hash (band key2 #xff)))
491 (set! hash (+ hash (bshl hash 10)))
492 (set! hash (bxor hash (bshr hash 6)))
493 (set! key2 (bshr key1 8))
494 )
495 (set! hash (+ hash (bshl hash 3)))
496 (set! hash (bxor hash (bshr hash 11)))
497 (set! hash (+ hash (bshl hash 15)))
498 ; our result must always be odd to be relatively prime to the size of table (multiple of 2)
499 (bor
500 (band hash (band -1 (bnot (bshl 1 31))))
501 1))))
502
503