bootstrap

annotate church/runtime/hashtable.state @ 841:f32bc9d22355

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