bootstrap: f172f7b54064 church/runtime/hashtable.state

bootstrap

view church/runtime/hashtable.state @ 835:f172f7b54064

add code to cache the slot-count for object allocations in a hashtable (turns out to be slower than walking the class hierarchy)

add opts for comparisons and branches

unroll loop in allocator, remove recursive calls

author	John Leuner <jewel@subvert-the-dominant-paradigm.net>
date	Mon Sep 12 21:36:42 2011 +0200 (8 months ago)
parents	f1cc298bae7b
children	f5417ff321cb

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")))

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 (define church_equal_compare_function (lambda (a b)

288 (let ((result (apply 'equal? a b)))

289 (if (= result TAG_TRUE)

290 0

291 (- b a)))))

292

293

294 ; two key hashtable

295

296 ; new hash table

297

298 (define church-two-key-hashtable-allocate (lambda (size)

299 (church-assert (church-> size 0) "size must be greater than 0")

300 (if (not (= (band size (- size 1)) 0))

301 (let ((highest-bit (bsr size))

302 (new-size (bshl 1 (+ highest-bit 1))))

303 ; (call-c-extern printf "church-two-key-hashtable-allocate given size %lu, new size %lu

304 ;" size new-size)

305 (set! size new-size)))

306 ; size must be a power of 2

307 (church-assert (church-= (band size (- size 1)) 0) "hash table size must be a power of 2")

308 ; hash table is 8 words, plus 4 * size words

309 (let ((ht-alloc-size (+ (* 8 CHURCH_WORD_SIZE) (* size (* 4 CHURCH_WORD_SIZE))))

310 (ht (state-gc-alloc-and-zero ht-alloc-size)))

311 (if (= ht 0)

312 (state-abort "hash table alloc failed"))

313 ; clear memory

314 (call-c-extern memset ht 0 ht-alloc-size)

315 (set-hashtable-size! ht size)

316 (set-hashtable-count! ht 0)

317 ; 0 probes

318 ; (set-long! ht (* 7 CHURCH_WORD_SIZE) 0)

319 ht)))

320

321 ;(define church-two-key-hashtable-print-stats (lambda (ht)

322 ; (call-c-extern printf "two hash-table count %lu probes %lu, avg probes %lu

323 ;" (hashtable-count ht) (deref ht (* 7 CHURCH_WORD_SIZE)) (/ (deref ht (* 7 CHURCH_WORD_SIZE)) (hashtable-count ht) ))))

324

325

326 (define church-two-key-hashtable-has-keys? (lambda (ht key1 key2)

327 (state-abort "has keys")

328 (let ((hash-table (hashtable-table ht))

329 (hash-table-size (hashtable-size ht))

330 (hash-fn (hashtable-hash-function ht))

331 (comp-fn (hashtable-comp-function ht))

332 (h (bor (hash-fn key1) (hash-fn key2)))

333 (index (mod h hash-table-size))

334 ; align to 4 word boundary

335 (base-index (band (* index 4) -4))

336 (orig-index base-index))

337 (tagbody

338 check

339 (let ((lookup1 (deref hash-table (* base-index CHURCH_WORD_SIZE)))

340 (lookup2 (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE))))

341 (if (and (= lookup1 0)

342 (= lookup2 0))

343 (return TAG_NIL))

344 (if (and (= (comp-fn lookup1 key1) 0)

345 (= (comp-fn lookup2 key2) 0))

346 (return TAG_TRUE)))

347 (set! base-index (+ base-index 4))

348 ; check if we have wrappend around the top of the table

349 (if (= base-index (* hash-table-size 4))

350 (set! base-index 0))

351 (go check)))))

352

353 ; return a pointer to the result

354 ; 0 if not found

355 (define church-two-key-hashtable-lookup-keys (lambda (ht key1 key2)

356 (let ((hash-table (hashtable-table ht))

357 (hash-table-size (hashtable-size ht))

358 (h (church-two-key-hash-function key1 key2))

359 (index (* (mod h hash-table-size) 4))

360 (probe-step (church-two-key-second-hash-function key1 key2)))

361 (tagbody

362 check

363 ; note that the first key cannot be a fixnum

364 (let ((l1 (deref hash-table (* index CHURCH_WORD_SIZE)) 0))

365 (if (= l1 0)

366 (return 0))

367 (if (= l1 key1)

368 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) key2)

369 (return (+ hash-table (* (+ index 2) CHURCH_WORD_SIZE))))))

370 (set! h (+ h probe-step))

371 ; mask out high bit

372 (set! h (band h (band -1 (bnot (bshl 1 31)))))

373 (set! index (* (mod h hash-table-size) 4))

374 (go check)))

375 (state-abort "failed find hash entry")))

376

377

378 (define church-two-key-hashtable-add-or-replace (lambda (ht key1 key2 value1 value2)

379 (let ((new-count (church-two-key-hashtable-add-or-replace-helper ht key1 key2 value1 value2)))

380 (if (> new-count 0)

381 (begin

382 (set-hashtable-count! ht (+ (hashtable-count ht) 1))

383 ; (call-c-extern printf "after add two-key ht %p count %lu size %lu

384 ;" ht (hashtable-count ht) (hashtable-size ht))

385 ; check if we should grow

386 (if (> (/ (* (hashtable-count ht) 100) (hashtable-size ht)) 60)

387 (let ((newsize (* (hashtable-size ht) 2))

388 (new-ht (church-two-key-hashtable-allocate newsize)))

389 ;(call-c-extern printf "growing two key ht %p count %lu size %lu

390 ;" ht (hashtable-count ht) newsize)

391 ; copy the old functions into the new table

392 (church-hashtable-set-functions new-ht (hashtable-hash-function1 ht) (hashtable-hash-function2 ht) (hashtable-comp-function ht))

393 (church-two-key-hashtable-rehash-from-old-table ht new-ht)

394 (return new-ht))

395 ht))

396 ht))))

397

398 (define church-two-key-hashtable-add-or-replace-helper (lambda (ht key1 key2 value1 value2)

399 (let ((hash-table (hashtable-table ht))

400 (hash-table-size (hashtable-size ht))

401 (h (church-two-key-hash-function key1 key2))

402 (index (* (mod h hash-table-size) 4))

403 (probe-step (church-two-key-second-hash-function key1 key2)))

404 ; (call-c-extern printf "add key1 %p key2 %p, h %p index %lu at index %lu (%p)

405 ;" key1 key2 h index index index)

406 (tagbody

407 check

408

409 (let ((l1 (deref hash-table (* index CHURCH_WORD_SIZE)) 0))

410 (if (= l1 0)

411 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) 0)

412 (begin

413 (set-long! hash-table (* index CHURCH_WORD_SIZE) key1)

414 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) key2)

415 (set-long! hash-table (* (+ index 2) CHURCH_WORD_SIZE) value1)

416 (set-long! hash-table (* (+ index 3) CHURCH_WORD_SIZE) value2)

417 (return 1) ; new entry

418 )))

419 (if (= l1 key1)

420 (if (= (deref hash-table (* (+ index 1) CHURCH_WORD_SIZE)) key2)

421 (begin

422 (set-long! hash-table (* index CHURCH_WORD_SIZE) key1)

423 (set-long! hash-table (* (+ index 1) CHURCH_WORD_SIZE) key2)

424 (set-long! hash-table (* (+ index 2) CHURCH_WORD_SIZE) value1)

425 (set-long! hash-table (* (+ index 3) CHURCH_WORD_SIZE) value2)

426 (return 0) ; new entry

427 ))))

428 ; (call-c-extern printf "add key1 %p key2 %p, h %p index %lu at index %lu (%p) PROBING

429 ;" key1 key2 h index index index)

430 ; count the number of probes

431 ; (set-long! ht (* 7 CHURCH_WORD_SIZE) (+ 1 (deref ht (* 7 CHURCH_WORD_SIZE))))

432 (set! h (+ h probe-step))

433 ; mask out high bit

434 (set! h (band h (band -1 (bnot (bshl 1 31)))))

435 (set! index (mod h hash-table-size))

436 (go check)))

437 (state-abort "failed find hash entry")))

438

439 (define church-two-key-hashtable-rehash-from-old-table (lambda (ht new-ht)

440 (let ((hash-table (hashtable-table ht))

441 (hash-table-size (hashtable-size ht)))

442 (let ((counter 0)

443 (base-index 0))

444 (tagbody

445 check

446 (if (< counter hash-table-size)

447 (let ((key1 (deref hash-table (* base-index CHURCH_WORD_SIZE)))

448 (key2 (deref hash-table (* (+ base-index 1) CHURCH_WORD_SIZE)))

449 (value1 (deref hash-table (* (+ base-index 2) CHURCH_WORD_SIZE) ))

450 (value2 (deref hash-table (* (+ base-index 3) CHURCH_WORD_SIZE) )) (value1 (deref hash-table (* (+ base-index 2) CHURCH_WORD_SIZE) )))

451 (if (not (and (= key1 0)

452 (= key2 0)))

453 (begin

454 (church-two-key-hashtable-add-or-replace-helper new-ht key1 key2 value1 value2)

455 (set-hashtable-count! new-ht (+ (hashtable-count new-ht) 1)))

456 )

457 (set! base-index (+ base-index 4)))

458 (go end))

459 (set! counter (+ counter 1))

460 (go check)

461 end)))))

462

463 ; Modified FNV from Pluto Scarab, http://home.comcast.net/~bretm/hash/6.html

464

465 (define church-two-key-hash-function (lambda (key1 key2)

466 (let ((p 16777619)

467 (h 2166136261))

468 (do ((i 0 (+ i 1)))

469 (< i 4)

470 (set! h (* p (bxor h (band key1 #xff))))

471 ; (call-c-extern printf "hash1 %p key1 %p

472 ;" h key1)

473 (set! key1 (bshr key1 8)))

474 (do ((i 0 (+ i 1)))

475 (< i 4)

476 (set! h (* p (bxor h (band key2 #xff))))

477 ; (call-c-extern printf "hash1 %p key2 %p

478 ;" h key2)

479 (set! key2 (bshr key2 8)))

480 (set! h (+ h (bshl h 13)))

481 (set! h (bxor h (bshr h 7)))

482 (set! h (+ h (bshl h 3)))

483 (set! h (bxor h (bshr h 17)))

484 (set! h (+ h (bshl h 5)))

485 (band h (band -1 (bnot (bshl 1 31)))) )))

486

487

488 ; Jenkins hash function from wikipedia / dr. dobbs

489

490 (define church-two-key-second-hash-function (lambda (key1 key2)

491 (let ((hash 0))

492 (do ((i 0 (+ i 1)))

493 (< i 4)

494 (set! hash (+ hash (band key1 #xff)))

495 (set! hash (+ hash (bshl hash 10)))

496 (set! hash (bxor hash (bshr hash 6)))

497 (set! key1 (bshr key1 8))

498 )

499 (do ((i 0 (+ i 1)))

500 (< i 4)

501 (set! hash (+ hash (band key2 #xff)))

502 (set! hash (+ hash (bshl hash 10)))

503 (set! hash (bxor hash (bshr hash 6)))

504 (set! key2 (bshr key1 8))

505 )

506 (set! hash (+ hash (bshl hash 3)))

507 (set! hash (bxor hash (bshr hash 11)))

508 (set! hash (+ hash (bshl hash 15)))

509 ; our result must always be odd to be relatively prime to the size of table (multiple of 2)

510 (bor

511 (band hash (band -1 (bnot (bshl 1 31))))

512 1))))

513

514