source: branches/portable/disk-page-hash.lisp@ 31

Last change on this file since 31 was 12, checked in by wws, 10 years ago

Checkpoint. It builds in x8664 CCL, with lots of warnings. Not close to working yet.
  • Property svn:eol-style set to native
File size: 21.0 KB
Line 
1;;;-*- Mode: Lisp; Package: WOOD -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; disk-page-hash.lisp
6;; A simple and very fast hashing mechanism for disk pages
7;;
8;; Portions Copyright © 2006 Clozure Associates and Anvita eReference (www.Anvita.info)
9;; Copyright © 1996-1999 Digitool, Inc.
10;; Copyright © 1992-1995 Apple Computer, Inc.
11;; All rights reserved.
12;; Permission is given to use, copy, and modify this software provided
13;; that Digitool is given credit in all derivative works.
14;; This software is provided "as is". Digitool makes no warranty or
15;; representation, either express or implied, with respect to this software,
16;; its quality, accuracy, merchantability, or fitness for a particular
17;; purpose.
18;;
19;; Entry points are: make-disk-page-hash, disk-page-gethash,
20;; (setf disk-page-gethash), disk-page-remhash, disk-page-maphash.
21;; They are similar to the Common Lisp hash table functions,
22;; except the table must have integer keys (fixnums if
23;; :wood-fixnum-addresses is on *features* when this file is compiled).
24;;
25
26;;;;;;;;;;;;;;;;;;;;;;;;;;
27;;
28;; Modification History
29;;
30;; 02/01/06 gz LispWorks port
31;; 01/10/00 akh moved (pushnew :wood-fixnum-addresses *features*) to block-io-mcl
32;; -------- 0.96
33;; -------- 0.95
34;; -------- 0.94
35;; 03/21/96 bill (make-array ... :INITIAL-ELEMENT NIL) in make-disk-page-hash-table-vector
36;; -------- 0.93
37;; 05/31/95 bill New file
38;;
39
40#|
41Algorithm notes.
42
43This uses the same basic Knuth algorithm as MCL's hash table implementation.
44Hashing is into a vector of size 2**n. Each entry has either a key, a
45deleted marker, or an empty marker. The first hash probe is a mask with
46the key. If that hits the looked-for key, we're done. If it hits an empty
47marker, we're done and the desired key is not in the table. If it hits
48a deleted marker or a different key, we pick a secondary key from the
49*secondary-keys* table. Then add the secondary key, modding with the table
50length until you find the key you're looking for or an empty marker.
51Since all the secondary keys are odd primes (relatively prime to the table
52size), this is guaranteed to hit every element of the vector.
53
54A sequence of insertions and deletions can leave a table that has no empty
55markers. This makes gethash for a key that isn't in the table take a long time.
56Hence, when this condition is detected, the table is rehashed to get rid of
57the deleted markers. The rehashing algorithm is the library card catalog
58algorithm. You keep a counter of which card drawer you last started with.
59pull the drawer out of that slot and increment the counter. Put the drawer
60in your hand where it goes. If this causes you to pull out another drawer,
61then put that one where it goes. Eventually, you'll put a drawer in an empty
62slot and you can go back to the counter's slot. Continue until the counter
63is greater than the number of slots.
64
65|#
66
67(in-package :wood)
68
69(defstruct (disk-page-hash (:constructor cons-disk-page-hash ())
70 (:print-function print-disk-page-hash))
71 vector ; Where the data is stored.
72 vector-length ; (length vector) - a power of 2
73 size ; number of entries that will fit
74 count ; number of entries currently in stored
75 mask ; (1- (ash vector-length -1))
76 shift ; (integer-length mask)
77 secondary-mask ; mask for length of *secondary-keys* shifted up by shift
78 (cache-address nil) ; adderss of last reference
79 (cache-value nil) ; value of last reference
80 (cache-index nil) ; vector index of last reference
81 page-size ; The page size of the disk-cache using this hash table
82 page-size-shift ; (integer-length (1- page-size))
83 bit-vector) ; for rehashing. Actually an (unsigned-byte 8) vector (faster).
84
85(defun print-disk-page-hash (hash stream level)
86 (declare (ignore level))
87 (print-unreadable-object (hash stream :identity t :type t)
88 (format stream "~d/~d"
89 (disk-page-hash-count hash)
90 (disk-page-hash-size hash))))
91
92(defconstant *secondary-keys*
93 (coerce (mapcar #'(lambda (x) (+ x x)) '(3 5 7 11 13 17 19 23)) 'vector))
94
95(defconstant *secondary-keys-length* (length *secondary-keys*))
96(defconstant *secondary-keys-mask* (1- *secondary-keys-length*))
97
98(assert (eql *secondary-keys-length*
99 (expt 2 (integer-length (1- *secondary-keys-length*)))))
100
101(defconstant *no-key-marker* nil)
102(defconstant *deleted-key-marker* :deleted)
103
104(defparameter *minimum-size*
105 (expt 2 (1- (integer-length (apply 'max (coerce *secondary-keys* 'list))))))
106
107; Not just the default; it's not a parameter.
108(defparameter *default-rehash-threshold* 0.85)
109
110(defun make-disk-page-hash-table-vector (count &optional (rehash-threshold *default-rehash-threshold*))
111 (let* ((nominal-count (max *minimum-size*
112 (1+ count)
113 (ceiling count rehash-threshold)))
114 (shift (integer-length (1- nominal-count)))
115 (real-count (expt 2 shift)))
116 (values
117 (make-array (* 2 real-count) :initial-element nil)
118 real-count
119 shift)))
120
121(defun make-disk-page-hash (&key (size 1) (page-size 1))
122 (init-disk-page-hash (cons-disk-page-hash) size page-size))
123
124(defun init-disk-page-hash (hash count page-size)
125 (multiple-value-bind (vector real-count shift) (make-disk-page-hash-table-vector count)
126 (let ((size (truncate (* real-count *default-rehash-threshold*))))
127 (when (eql size real-count)
128 (decf size))
129 (setf (disk-page-hash-vector hash) vector
130 (disk-page-hash-vector-length hash) (length vector)
131 (disk-page-hash-size hash) size
132 (disk-page-hash-count hash) 0
133 (disk-page-hash-mask hash) (1- real-count)
134 (disk-page-hash-shift hash) shift
135 (disk-page-hash-secondary-mask hash) (ash *secondary-keys-mask* shift)
136 (disk-page-hash-cache-address hash) nil
137 (disk-page-hash-cache-value hash) nil
138 (disk-page-hash-cache-index hash) nil
139 (disk-page-hash-page-size hash) page-size
140 (disk-page-hash-page-size-shift hash) (integer-length (1- page-size))
141 (disk-page-hash-bit-vector hash) nil)))
142 hash)
143
144#+wood-fixnum-addresses
145(defun-inline address-iasr (count address)
146 (declare (fixnum count address))
147 (the fixnum (%iasr count address)))
148
149#-wood-fixnum-addresses
150(defun-inline address-iasr (count address)
151 (declare (fixnum count)
152 (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
153 #-LispWorks
154 (the fixnum (ash address (the fixnum (- 0 count))))
155 #+LispWorks
156 (the fixnum (sys:int32-to-integer (sys:int32>> (the integer address) count))))
157
158
159; I wanted this to be an inlined function, but MCL's compiler wouldn't inline the knowledge
160; that address was a fixnum.
161(defmacro %disk-page-gethash-macro (address hash &optional fixnum-address?)
162 `(locally (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0))
163 ,@(and fixnum-address? '((type fixnum address))))
164 (if (eql ,address (disk-page-hash-cache-address ,hash))
165 (disk-page-hash-cache-value ,hash)
166 (let* ((page-number ,(if fixnum-address?
167 `(%iasr (disk-page-hash-page-size-shift ,hash) ,address)
168 `(address-iasr (disk-page-hash-page-size-shift ,hash) ,address)))
169 (hash-code (logand page-number (the fixnum (disk-page-hash-mask ,hash))))
170 (index (+ hash-code hash-code))
171 (vector (disk-page-hash-vector ,hash))
172 (probe (svref vector index)))
173 (declare (fixnum hash-code index page-number)
174 (type simple-vector vector))
175 (cond ((eql probe ,address) (aref vector (the fixnum (1+ index))))
176 ((eq probe *no-key-marker*) nil)
177 (t (let ((secondary-key (aref *secondary-keys*
178 (%iasr (disk-page-hash-shift ,hash)
179 (logand page-number (the fixnum (disk-page-hash-secondary-mask ,hash))))))
180 (vector-length (disk-page-hash-vector-length ,hash))
181 (original-index index))
182 (declare (fixnum secondary-key vector-length original-index))
183 (loop
184 (incf index secondary-key)
185 (when (>= index vector-length)
186 (decf index vector-length))
187 (when (eql index original-index)
188 (return nil))
189 (let ((probe (aref vector index)))
190 (when (eql probe ,address)
191 (let ((value (aref vector (the fixnum (1+ index)))))
192 (setf (disk-page-hash-cache-address ,hash) ,address
193 (disk-page-hash-cache-value ,hash) value
194 (disk-page-hash-cache-index ,hash) index)
195 (return value)))
196 (when (eq probe *no-key-marker*)
197 (return nil)))))))))))
198
199#|
200;(disassemble #'fixnum-disk-page-gethash)
201(defun fixnum-disk-page-gethash (address hash)
202 (declare (type fixnum address))
203 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
204 (%disk-page-gethash-macro address hash t))
205|#
206
207; This is one of WOOD's most-called functions.
208; It's important that it be as fast as possible.
209(defun disk-page-gethash (address hash #+LispWorks &optional #+LispWorks ignore)
210 #+LispWorks (declare (ignore ignore)) ;; see def-accessor for explanation.
211 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
212 ; Assume if it's non-null that it's of the right type since
213 ; type check takes too long (unless unlined LAP?).
214 ; Need to check for null since disk cache inspectors can remain open
215 ; after their disk cache has been closed.
216 (unless hash
217 (error "Null hash table."))
218 (if #+wood-fixnum-addresses t #-wood-fixnum-addresses (fixnump address)
219 (locally (declare (fixnum address))
220 (%disk-page-gethash-macro address hash t))
221 (%disk-page-gethash-macro address hash)))
222
223(defun (setf disk-page-gethash) (value address hash &optional deleting?)
224 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
225 #+wood-fixnum-addresses (declare (fixnum address))
226 (unless (typep hash 'disk-page-hash)
227 (setq hash (require-type hash 'disk-page-hash)))
228 (let ((vector (disk-page-hash-vector hash)))
229 (if (eql address (disk-page-hash-cache-address hash))
230 (let ((index (disk-page-hash-cache-index hash)))
231 (if deleting?
232 (let ((vector (disk-page-hash-vector hash)))
233 (setf (disk-page-hash-cache-address hash) nil ;
234 (disk-page-hash-cache-value hash) nil
235 (disk-page-hash-cache-index hash) nil
236 (aref vector index) *deleted-key-marker*
237 (aref vector (the fixnum (1+ index))) nil)
238 (decf (the fixnum (disk-page-hash-count hash)))
239 t)
240 (setf (disk-page-hash-cache-value hash) value
241 (aref vector (1+ index)) value)))
242 (let* ((page-size-shift (disk-page-hash-page-size-shift hash))
243 (page-number (address-iasr page-size-shift address))
244 (hash-code (logand page-number (the fixnum (disk-page-hash-mask hash))))
245 (index (* 2 hash-code))
246 (probe (svref vector index))
247 (new-key? (not deleting?)))
248 (declare (fixnum page-size-shift hash-code index))
249 (or (when (eql probe address)
250 (setq new-key? nil)
251 t)
252 (eql probe *no-key-marker*)
253 (let ((secondary-key (aref *secondary-keys*
254 (%iasr (disk-page-hash-shift hash)
255 (logand page-number (the fixnum (disk-page-hash-secondary-mask hash))))))
256 (vector-length (length vector))
257 (first-deletion nil)
258 (original-index index))
259 (declare (fixnum secondary-key vector-length original-index))
260 (loop
261 (incf index secondary-key)
262 (when (>= index vector-length)
263 (decf index vector-length))
264 (let ((probe (aref vector index)))
265 (when (eql probe address)
266 (setq new-key? nil)
267 (return t))
268 (when (and (not deleting?)
269 (eql index original-index)
270 (< (disk-page-hash-count hash) (disk-page-hash-size hash)))
271 (incf (disk-page-hash-count hash))
272 (return-from disk-page-gethash
273 (disk-page-rehash hash address value)))
274 (when (eql probe *no-key-marker*)
275 (when first-deletion
276 (setq index first-deletion))
277 (return t))
278 (when (eql probe *deleted-key-marker*)
279 (unless first-deletion
280 (setq first-deletion index)))))))
281 (when new-key?
282 (let ((count (disk-page-hash-count hash)))
283 (declare (fixnum count))
284 (if (>= count (disk-page-hash-size hash))
285 (return-from disk-page-gethash (grow-disk-page-hash hash address value))
286 (setf (disk-page-hash-count hash) (the fixnum (1+ count))))))
287 (if deleting?
288 (when (integerp (aref vector index))
289 (decf (disk-page-hash-count hash))
290 (setf (disk-page-hash-cache-address hash) nil
291 (disk-page-hash-cache-value hash) nil
292 (disk-page-hash-cache-index hash) nil
293 (aref vector index) *deleted-key-marker*
294 (aref vector (the fixnum (1+ index))) nil)
295 t)
296 (setf (disk-page-hash-cache-address hash) address
297 (disk-page-hash-cache-value hash) value
298 (disk-page-hash-cache-index hash) index
299 (aref vector index) address
300 (aref vector (the fixnum (1+ index))) value))))))
301
302(defun disk-page-remhash (address hash)
303 (setf (disk-page-gethash address hash t) nil))
304
305(defun disk-page-maphash (function hash)
306 (disk-page-map-vector function (disk-page-hash-vector hash)))
307
308(defun disk-page-map-vector (function vector)
309 (let ((index 0)
310 (length (length vector)))
311 (declare (fixnum index length))
312 (loop
313 (let ((key (%svref vector index))
314 (value (%svref vector (incf index))))
315 (incf index)
316 (unless (or (eql key *no-key-marker*) (eql key *deleted-key-marker*))
317 (funcall function key value))
318 (when (>= index length)
319 (return))))))
320
321(defun grow-disk-page-hash (hash address value)
322 (let* ((vector (disk-page-hash-vector hash))
323 (mapper #'(lambda (key value)
324 (setf (disk-page-gethash key hash) value))))
325 (declare (dynamic-extent mapper))
326 (init-disk-page-hash hash
327 (* 2 (disk-page-hash-size hash))
328 (disk-page-hash-page-size hash))
329 (disk-page-map-vector mapper vector)
330 (setf (disk-page-gethash address hash) value)))
331
332; Rehash to get rid of deleted markers. Insert address/value pair
333; This is called when the vector has no empty slots, all are filled
334; with data or delted key markers. In that state a failing gethash
335; takes a long time, so we get rid of the delted markers to speed it up.
336(defun disk-page-rehash (hash address value)
337 (declare (optimize (speed 3) (safety 0) #+LispWorks (float 0)))
338 (locally
339 (declare (optimize (speed 3) (safety 0)))
340 (setf (disk-page-hash-cache-address hash) *no-key-marker*
341 (disk-page-hash-cache-value hash) nil
342 (disk-page-hash-cache-index hash) nil)
343 (let* ((vector (disk-page-hash-vector hash))
344 (bits (disk-page-hash-bit-vector hash))
345 (vector-length (disk-page-hash-vector-length hash))
346 (page-size-shift (disk-page-hash-page-size-shift hash))
347 (mask (disk-page-hash-mask hash))
348 (shift (disk-page-hash-shift hash))
349 (secondary-mask (disk-page-hash-secondary-mask hash))
350 (loop-index -2)
351 (loop-index+1 -1)
352 (original-value value))
353 (declare (type simple-vector vector)
354 (fixnum vector-length page-size-shift mask shift secondary-mask loop-index loop-index+1))
355 (flet ((bit-ref (bits index)
356 (declare (type (simple-array (unsigned-byte 8) (*)) bits)
357 (optimize (speed 3)(safety 0)))
358 (aref bits index))
359 ((setf bit-ref) (v bits index)
360 (declare (type (simple-array (unsigned-byte 8) (*)) bits)
361 (optimize (speed 3)(safety 0)))
362 (setf (aref bits index) v)))
363 (declare (inline bit-ref (setf bit-ref)))
364 (if (or (null bits) (< (length bits) vector-length))
365 (setq bits
366 ; not really a bit vector because that's too slow
367 (setf (disk-page-hash-bit-vector hash)
368 (make-array vector-length :element-type '(unsigned-byte 8) :initial-element 0)))
369 (dotimes (i vector-length) (setf (bit-ref bits i) 0)))
370 (loop
371 (unless address
372 (loop
373 (incf loop-index 2)
374 (incf loop-index+1 2)
375 ;(print-db loop-index)
376 (when (>= loop-index vector-length)
377 (return-from disk-page-rehash original-value))
378 (when (eql 0 (bit-ref bits loop-index))
379 (setq address (svref vector loop-index))
380 ;(print-db address)
381 (cond ((eql address *no-key-marker*))
382 ((eql address *deleted-key-marker*)
383 (setf (svref vector loop-index) *no-key-marker*
384 (svref vector loop-index+1) nil))
385 (t (setq value (svref vector loop-index+1))
386 (setf (svref vector loop-index) *no-key-marker*
387 (svref vector loop-index+1) nil)
388 (return))))))
389 (let* ((integer-address address)
390 (page-number (address-iasr page-size-shift integer-address))
391 (hash-code (logand page-number mask))
392 (index (* 2 hash-code)))
393 #+wood-fixnum-addresses (declare (fixnum integer-address page-number))
394 (declare (fixnum hash-code index))
395 (flet ((insert-p (probe)
396 (let ((index+1 (1+ index)))
397 (declare (fixnum index+1))
398 (cond ((or (eql probe *no-key-marker*) (eql probe *deleted-key-marker*))
399 (setf (svref vector index) address
400 (svref vector index+1) value)
401 (setq address nil value nil)
402 (setf (bit-ref bits index) 1))
403 ((eql 0 (bit-ref bits index))
404 (setf (svref vector index) address
405 address probe)
406 (rotatef value (svref vector index+1))
407 (setf (bit-ref bits index) 1))
408 (t nil)))))
409 (declare (dynamic-extent #'insert-p))
410 (unless (insert-p (svref vector index))
411 (let ((secondary-key (aref *secondary-keys*
412 (%iasr shift (logand page-number secondary-mask)))))
413 (declare (fixnum secondary-key))
414 (loop
415 (incf index secondary-key)
416 (when (>= index vector-length)
417 (decf index vector-length))
418 ;(print-db index)
419 (when (insert-p (svref vector index)) (return))))))))))))
420
421; For testing
422#|
423(advise disk-page-rehash
424 (destructuring-bind (hash address value) arglist
425 (prog1
426 (:do-it)
427 (let ((was (disk-page-gethash address hash)))
428 (unless (eq value was)
429 (error "address: ~s, sb: ~s, was: ~s" address value was)))
430 (let ((mapper #'(lambda (a v)
431 (let ((was (disk-page-gethash a hash)))
432 (unless (eq was v)
433 (error "Address: ~s~%, sb: ~s~%, was: ~s"
434 a v was))
435 (unless (eql a (disk-page-address v))
436 (error "Address: ~s for ~s" a v))))))
437 (declare (dynamic-extent mapper))
438 (disk-page-maphash mapper hash))))
439 :when :around
440 :name :debug)
441
442(advise (setf disk-page-gethash)
443 (destructuring-bind (value address hash &optional delete?) arglist
444 (unless (or delete? (eql address (disk-page-address value)))
445 (error "Address: ~s, value: ~s" address value))
446 (:do-it)
447 (unless (eq (disk-page-gethash address hash) value)
448 (error "Bad value")))
449 :when :around
450 :name :debug)
451|#
452;;; 1 6/02/95 bill 1.11d040
453;;; 2 8/01/95 bill 1.11d065
Note: See TracBrowser for help on using the repository browser.