bootstrap
view church/runtime/hashtable.state @ 852:9ec3d595e7c3
Add experimental static optimization pass
This is not run by default, there is a target for it in the Makefile
This pass starts by loading all the church files that have changed since the last compile.
For each one it examines the exported method names and signatures.
From previous runs it also knows which files depend on methods defined in the changed files.
It builds a list of all files to recompile based on these dependencies.
During compilation it uses the knowledge of which files exported methods to be able to elide the dynamic dispatch step and instead create a direct call to the State function.
This currently only applies to methods which have all arguments of base type 'object'.
This is still fairly experimental and messy code. My tests so far show that the dispatch compiler already makes these optimizations somewhat redundant. If we can do type inference (and later control flow analysis across methods) then this type of optimization may become more powerful.
This is not run by default, there is a target for it in the Makefile
This pass starts by loading all the church files that have changed since the last compile.
For each one it examines the exported method names and signatures.
From previous runs it also knows which files depend on methods defined in the changed files.
It builds a list of all files to recompile based on these dependencies.
During compilation it uses the knowledge of which files exported methods to be able to elide the dynamic dispatch step and instead create a direct call to the State function.
This currently only applies to methods which have all arguments of base type 'object'.
This is still fairly experimental and messy code. My tests so far show that the dispatch compiler already makes these optimizations somewhat redundant. If we can do type inference (and later control flow analysis across methods) then this type of optimization may become more powerful.
| author | John Leuner <jewel@subvert-the-dominant-paradigm.net> |
|---|---|
| date | Wed Nov 02 19:38:01 2011 +0200 (6 months ago) |
| parents | f5417ff321cb |
| children | 17b7797f6a12 |
line source
1 (include "church/runtime/church_types.state")
2 (include "church/runtime/church_syntax.state")
5 (external-function |state-gc-alloc|)
6 (external-function |state-gc-alloc-and-zero|)
7 (external-function state-abort)
8 (external-function church-cons)
10 ; new hash table
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)
28 (set-hashtable-size! ht size)
29 (set-hashtable-count! ht 0)
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"))))
41 ht)))
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))
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)))))
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")))
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))))
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")))
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)))))
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))))
197 ; hash functions
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 )))
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))))
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)))
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))))
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 )))
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))))
277 (define church_default_compare_function (lambda (a b)
278 (- a b)))
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)
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)))))
295 ; two key hashtable
297 ; new hash table
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)))
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) ))))
327 (define church-two-key-hashtable-has-keys? (lambda (ht key1 key2)
328 (state-abort "has keys")
329 (let ((hash-table (hashtable-table ht))
330 (hash-table-size (hashtable-size ht))
331 (hash-fn (hashtable-hash-function ht))
332 (comp-fn (hashtable-comp-function ht))
333 (h (bor (hash-fn key1) (hash-fn key2)))
334 (index (mod h hash-table-size))
335 ; align to 4 word boundary
336 (base-index (band (* index 4) -4))
337 (orig-index base-index))
338 (tagbody
339 check
340 (let ((lookup1 (deref hash-table (* base-index CHURCH_WORD_SIZE)))
341 (lookup2 (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE))))
342 (if (and (= lookup1 0)
343 (= lookup2 0))
344 (return TAG_NIL))
345 (if (and (= (comp-fn lookup1 key1) 0)
346 (= (comp-fn lookup2 key2) 0))
347 (return TAG_TRUE)))
348 (set! base-index (+ base-index 4))
349 ; check if we have wrappend around the top of the table
350 (if (= base-index (* hash-table-size 4))
351 (set! base-index 0))
352 (go check)))))
354 ; return a pointer to the result
355 ; 0 if not found
356 (define church-two-key-hashtable-lookup-keys (lambda (ht key1 key2)
357 (let ((hash-table (hashtable-table ht))
358 (hash-table-size (hashtable-size ht))
359 (h (church-two-key-hash-function key1 key2))
360 (index (* (mod h hash-table-size) 4))
361 (probe-step (church-two-key-second-hash-function key1 key2)))
362 (tagbody
363 check
364 ; note that the first key cannot be a fixnum
365 (let ((l1 (deref hash-table (* index CHURCH_WORD_SIZE)) 0))
366 (if (= l1 0)
367 (return 0))
368 (if (= l1 key1)
369 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) key2)
370 (return (+ hash-table (* (+ index 2) CHURCH_WORD_SIZE))))))
371 (set! h (+ h probe-step))
372 ; mask out high bit
373 (set! h (band h (band -1 (bnot (bshl 1 31)))))
374 (set! index (mod h hash-table-size))
375 (set! index (* index 4))
376 (go check)))
377 (state-abort "failed find hash entry")))
380 (define church-two-key-hashtable-add-or-replace (lambda (ht key1 key2 value1 value2)
381 (let ((new-count (church-two-key-hashtable-add-or-replace-helper ht key1 key2 value1 value2)))
382 ; (call-c-extern printf "after add two-key ht %p newcount %lu
383 ;" ht new-count)
384 (if (> new-count 0)
385 (begin
386 (set-hashtable-count! ht (+ (hashtable-count ht) 1))
387 ; (call-c-extern printf "after add two-key ht %p count %lu size %lu
388 ;" ht (hashtable-count ht) (hashtable-size ht))
389 ; check if we should grow
390 (if (> (/ (* (hashtable-count ht) 100) (hashtable-size ht)) 60)
391 (let ((newsize (* (hashtable-size ht) 2))
392 (new-ht (church-two-key-hashtable-allocate newsize)))
393 ;(call-c-extern printf "growing two key ht %p count %lu size %lu
394 ;" ht (hashtable-count ht) newsize)
395 ; copy the old functions into the new table
396 (church-hashtable-set-functions new-ht (hashtable-hash-function1 ht) (hashtable-hash-function2 ht) (hashtable-comp-function ht))
397 (church-two-key-hashtable-rehash-from-old-table ht new-ht)
398 (return new-ht))
399 ht))
400 ht))))
402 (define church-two-key-hashtable-add-or-replace-helper (lambda (ht key1 key2 value1 value2)
403 (let ((hash-table (hashtable-table ht))
404 (hash-table-size (hashtable-size ht))
405 (h (church-two-key-hash-function key1 key2))
406 (index (* (mod h hash-table-size) 4))
407 (probe-step (church-two-key-second-hash-function key1 key2)))
408 ; (call-c-extern printf "probe-step %p %lu %i
409 ;" probe-step probe-step probe-step)
410 ; (call-c-extern printf "add key1 %p key2 %p, h %p index %lu at index %lu (%p)
411 ;" key1 key2 h index index index)
412 (tagbody
413 check
415 (let ((l1 (deref hash-table (* index CHURCH_WORD_SIZE)) 0))
416 (if (= l1 0)
417 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) 0)
418 (begin
419 (set-long! hash-table (* index CHURCH_WORD_SIZE) key1)
420 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) key2)
421 (set-long! hash-table (* (+ index 2) CHURCH_WORD_SIZE) value1)
422 (set-long! hash-table (* (+ index 3) CHURCH_WORD_SIZE) value2)
423 (return 1) ; new entry
424 )))
425 (if (= l1 key1)
426 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) key2)
427 (begin
428 (set-long! hash-table (* index CHURCH_WORD_SIZE) key1)
429 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) key2)
430 (set-long! hash-table (* (+ index 2) CHURCH_WORD_SIZE) value1)
431 (set-long! hash-table (* (+ index 3) CHURCH_WORD_SIZE) value2)
432 (return 0) ; existing entry
433 ))))
434 ; (call-c-extern printf "add key1 %p key2 %p, h %p index %lu at index %lu (%p) PROBING
435 ;" key1 key2 h index index index)
436 ; count the number of probes
437 ; (set-long! ht (* 7 CHURCH_WORD_SIZE) (+ 1 (deref ht (* 7 CHURCH_WORD_SIZE))))
438 (set! h (+ h probe-step))
439 ; mask out high bit
440 (set! h (band h (band -1 (bnot (bshl 1 31)))))
441 ; (call-c-extern printf "h after mask %p
442 ;" h)
443 (set! index (mod h hash-table-size))
444 (set! index (* index 4))
445 ; (call-c-extern printf "index after mask %p
446 ;" index)
447 (go check)))
448 (state-abort "failed find hash entry")))
450 (define church-two-key-hashtable-rehash-from-old-table (lambda (ht new-ht)
451 (let ((hash-table (hashtable-table ht))
452 (hash-table-size (hashtable-size ht)))
453 (let ((counter 0)
454 (base-index 0))
455 (tagbody
456 check
457 (if (< counter hash-table-size)
458 (let ((key1 (deref hash-table (* base-index CHURCH_WORD_SIZE)))
459 (key2 (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE)))
460 (value1 (deref hash-table (* (+ base-index 2) CHURCH_WORD_SIZE) ))
461 (value2 (deref hash-table (* (+ base-index 3) CHURCH_WORD_SIZE) )) (value1 (deref hash-table (* (+ base-index 2) CHURCH_WORD_SIZE) )))
462 (if (not (and (= key1 0)
463 (= key2 0)))
464 (begin
465 (church-two-key-hashtable-add-or-replace-helper new-ht key1 key2 value1 value2)
466 (set-hashtable-count! new-ht (+ (hashtable-count new-ht) 1)))
467 )
468 (set! base-index (+ base-index 4)))
469 (go end))
470 (set! counter (+ counter 1))
471 (go check)
472 end)))))
474 ; Modified FNV from Pluto Scarab, http://home.comcast.net/~bretm/hash/6.html
476 (define church-two-key-hash-function (lambda (key1 key2)
477 (let ((p 16777619)
478 (h 2166136261))
479 (do ((i 0 (+ i 1)))
480 (< i 4)
481 (set! h (* p (bxor h (band key1 #xff))))
482 ; (call-c-extern printf "hash1 %p key1 %p
483 ;" h key1)
484 (set! key1 (bshr key1 8)))
485 (do ((i 0 (+ i 1)))
486 (< i 4)
487 (set! h (* p (bxor h (band key2 #xff))))
488 ; (call-c-extern printf "hash1 %p key2 %p
489 ;" h key2)
490 (set! key2 (bshr key2 8)))
491 (set! h (+ h (bshl h 13)))
492 (set! h (bxor h (bshr h 7)))
493 (set! h (+ h (bshl h 3)))
494 (set! h (bxor h (bshr h 17)))
495 (set! h (+ h (bshl h 5)))
496 (band h (band -1 (bnot (bshl 1 31)))) )))
499 ; Jenkins hash function from wikipedia / dr. dobbs
501 (define church-two-key-second-hash-function (lambda (key1 key2)
502 (let ((hash 0))
503 (do ((i 0 (+ i 1)))
504 (< i 4)
505 (set! hash (+ hash (band key1 #xff)))
506 (set! hash (+ hash (bshl hash 10)))
507 (set! hash (bxor hash (bshr hash 6)))
508 (set! key1 (bshr key1 8))
509 )
510 (do ((i 0 (+ i 1)))
511 (< i 4)
512 (set! hash (+ hash (band key2 #xff)))
513 (set! hash (+ hash (bshl hash 10)))
514 (set! hash (bxor hash (bshr hash 6)))
515 (set! key2 (bshr key1 8))
516 )
517 (set! hash (+ hash (bshl hash 3)))
518 (set! hash (bxor hash (bshr hash 11)))
519 (set! hash (+ hash (bshl hash 15)))
520 ; our result must always be odd to be relatively prime to the size of table (multiple of 2)
521 (bor
522 (band hash (band -1 (bnot (bshl 1 31))))
523 1))))
