/[cmucl]/src/code/hash.lisp
ViewVC logotype

Contents of /src/code/hash.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9.2.1 - (hide annotations)
Tue Jul 30 00:39:51 1991 UTC (22 years, 8 months ago) by wlott
Changes since 1.9: +260 -274 lines
Random mods for generational GC system.
1 ram 1.1 ;;; -*- Log: code.log; Package: Lisp -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.9 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.9.2.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/hash.lisp,v 1.9.2.1 1991/07/30 00:39:51 wlott Exp $")
11 ram 1.9 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; Hashing and hash table functions for Spice Lisp.
15     ;;; Written by Skef Wholey.
16     ;;;
17     (in-package 'lisp)
18     (export '(hash-table hash-table-p make-hash-table
19     gethash remhash maphash clrhash
20 wlott 1.8 hash-table-count sxhash
21     with-hash-table-iterator))
22 ram 1.1
23 wlott 1.9.2.1 ;;; Hash-values are all positive fixnums:
24     (deftype hash-value ()
25     '(and fixnum (unsigned-byte)))
26 wlott 1.2
27 ram 1.1 (defstruct (hash-table (:constructor make-hash-table-structure)
28     (:conc-name hash-table-)
29     (:print-function %print-hash-table))
30     "Structure used to implement hash tables."
31 wlott 1.9.2.1 (kind 'eq :type (member eq eql equal))
32     (rehash-size 101 :type real) ; might be a float
33 ram 1.1 (rehash-threshold 57 :type fixnum)
34     (number-entries 0 :type fixnum)
35 wlott 1.9.2.1 (table (required-argument) :type simple-vector)
36     (needing-rehash nil :type list))
37     ;;;
38 ram 1.1 (defun %print-hash-table (structure stream depth)
39     (declare (ignore depth))
40     (format stream "#<~A Hash Table {~X}>"
41     (symbol-name (hash-table-kind structure))
42 wlott 1.2 (system:%primitive make-fixnum structure)))
43 ram 1.1
44    
45 wlott 1.9.2.1 (defstruct (hash-table-bucket
46     (:print-function %print-hash-table-bucket)
47     (:constructor %make-bucket (key hash value next)))
48     (key nil :type t)
49     (hash 0 :type hash-value)
50     (value nil :type t)
51     (next nil :type (or null hash-table-bucket))
52     (scavhook nil :type (or null scavenger-hook)))
53     ;;;
54     (defun %print-hash-table-bucket (bucket stream depth)
55     (declare (ignore depth))
56     (format stream "#<hash-table-bucket ~S->~S>"
57     (hash-table-bucket-key bucket)
58     (hash-table-bucket-value bucket)))
59    
60     (defun make-hash-table-bucket (table key hash value next scav-hook-p)
61     (declare (type hash-table table) (type hash-value hash)
62     (type hash-table-bucket next))
63     (let ((bucket (%make-bucket key hash value next)))
64     (when scav-hook-p
65     (setf (hash-table-bucket-scavhook bucket)
66     (make-scavenger-hook
67     key
68     #'(lambda ()
69     (push bucket (hash-table-needing-rehash table))
70     (setf (scavenger-hook-value
71     (hash-table-bucket-scavhook bucket))
72     nil)))))
73     bucket))
74    
75    
76 ram 1.1
77     ;;; Hashing functions for the three kinds of hash tables:
78    
79 wlott 1.9.2.1 (eval-when (compile eval)
80 ram 1.1
81     (defmacro eq-hash (object)
82     "Gives us a hashing of an object such that (eq a b) implies
83     (= (eq-hash a) (eq-hash b))"
84 wlott 1.9.2.1 `(values (truly-the hash-value (%primitive make-fixnum ,object))
85     t))
86 ram 1.1
87     (defmacro eql-hash (object)
88     "Gives us a hashing of an object such that (eql a b) implies
89     (= (eql-hash a) (eql-hash b))"
90     `(if (numberp ,object)
91 wlott 1.9.2.1 (values (%eql-hash object) nil)
92     (eq-hash object)))
93 ram 1.1
94     (defmacro equal-hash (object)
95     "Gives us a hashing of an object such that (equal a b) implies
96     (= (equal-hash a) (equal-hash b))"
97 wlott 1.9.2.1 `(values (sxhash ,object) nil))
98 ram 1.1
99     )
100 wlott 1.9.2.1
101     (defun %eql-hash (number)
102     (etypecase number
103     (fixnum
104     (logand number most-positive-fixnum))
105     (integer
106     (logand number most-positive-fixnum))
107     (float
108     (%eql-hash (integer-decode-float number)))
109     (ratio
110     (logxor (%eql-hash (numerator number))
111     (%eql-hash (denominator number))))
112     (complex
113     (logxor (%eql-hash (realpart number))
114     (%eql-hash (imagpart number))))))
115    
116    
117     (defun hash (table object)
118     (ecase (hash-table-kind table)
119     (eq (eq-hash object))
120     (eql (eql-hash object))
121     (equal (equal-hash object))))
122    
123 ram 1.1
124     ;;; Rehashing functions:
125    
126     (defun almost-primify (num)
127     (declare (fixnum num))
128     "Almost-Primify returns an almost prime number greater than or equal
129     to NUM."
130 wlott 1.9.2.1 (when (zerop (rem num 2))
131     (incf num))
132     (when (zerop (rem num 3))
133     (incf num 2))
134     (when (zerop (rem num 7))
135     (incf num 4))
136 ram 1.1 num)
137    
138 wlott 1.9.2.1 (defun rehash (table)
139     "Rehashes all the entries in the hash table TABLE. Must only be called
140     inside a WITHOUT-GCING."
141     (let* ((old-vector (hash-table-table table))
142     (old-length (length old-vector))
143     (rehash-size (hash-table-rehash-size table))
144     (new-length (if (floatp rehash-size)
145     (ceiling (* rehash-size old-length))
146     (+ rehash-size old-length)))
147     (new-vector (make-array new-length :initial-element nil)))
148     (declare (type simple-vector old-vector new-vector)
149     (type index old-length new-length))
150     (flet ((reenter-bucket (bucket)
151     (let ((key (hash-table-bucket-key bucket)))
152     (multiple-value-bind
153     (hashing needs-scav-hook)
154     (hash table key)
155     (let ((index (rem hashing new-length))
156     (value (hash-table-bucket-value bucket)))
157     (setf (svref new-vector index)
158     (make-hash-table-bucket table key hashing value
159     (svref new-vector index)
160     needs-scav-hook)))))))
161     (dotimes (i old-length)
162     (do ((bucket (aref old-vector i) (hash-table-bucket-next bucket)))
163     ((null bucket))
164     (reenter-bucket bucket))
165     (setf (aref old-vector i) nil))
166     (dolist (bucket (hash-table-needing-rehash table))
167     (reenter-bucket bucket)))
168     (setf (hash-table-table table) new-vector)
169     (setf (hash-table-needing-rehash table) nil)
170     (when (> new-length old-length)
171     (setf (hash-table-rehash-threshold table) new-length))))
172 ram 1.1
173 wlott 1.9.2.1 (defun find-bucket (hash-table bucket-list key hashing)
174     (declare (type hash-table hash-table)
175     (type hash-table-bucket bucket-list)
176     (type hash-value hashing))
177     (flet ((frob (test)
178     (do ((prev nil bucket)
179     (bucket bucket-list (hash-table-bucket-next bucket)))
180     ((or (null bucket)
181     (and (= hashing (hash-table-bucket-hash bucket))
182     (funcall test (hash-table-bucket-key bucket) key)))
183     (values bucket prev)))))
184     (declare (inline frob))
185     (ecase (hash-table-kind hash-table)
186     (equal (frob #'equal))
187     (eql (frob #'eql))
188     (eq (frob #'eq)))))
189 ram 1.1
190 wlott 1.9.2.1 (defun flush-needing-rehash (table)
191     (declare (type hash-table table))
192     (let* ((vector (hash-table-table table))
193     (length (length vector)))
194     (declare (type simple-vector vector)
195     (type index length))
196     (dolist (bucket (hash-table-needing-rehash table))
197     (declare (type (or null hash-table-bucket) bucket))
198     (let ((index (rem (hash-table-bucket-hash bucket) length)))
199     (declare (type index index))
200     (do ((prev nil ptr)
201     (ptr (svref vector index) (hash-table-bucket-next ptr)))
202     ((or (null bucket) (eq bucket ptr)))
203     (declare (type (or null hash-table-bucket) prev ptr))
204     (unless bucket
205     (error "Can't find the bucket in the hash table. ~
206     Something is broken bigtime."))
207     (if prev
208     (setf (hash-table-bucket-next prev)
209     (hash-table-bucket-next bucket))
210     (setf (svref vector index)
211     (hash-table-bucket-next bucket)))))
212     (let* ((key (hash-table-bucket-key bucket))
213     (hashing (hash table key))
214     (index (rem hashing length)))
215     (declare (type hash-value hashing) (type index index))
216     (setf (hash-table-bucket-next bucket) (svref vector index))
217     (setf (svref vector index) bucket)
218     (setf (scavenger-hook-value (hash-table-bucket-scavhook bucket)) key)
219     (setf (hash-table-bucket-hash bucket) hashing))))
220     (setf (hash-table-needing-rehash table) nil))
221 ram 1.1
222    
223    
224     ;;; Making hash tables:
225    
226     (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)
227     rehash-threshold)
228     "Creates and returns a hash table. See manual for details."
229     (declare (fixnum size))
230 wlott 1.9.2.1 (let* ((test (cond ((eq test #'eq) 'eq)
231     ((eq test #'eql) 'eql)
232     ((eq test #'equal) 'equal)
233     ((member test '(eq eql equal) :test #'eq)
234     test)
235     (t
236     (error "~S is an illegal :Test for hash tables." test))))
237     (size (if (<= size 37)
238     37
239     (almost-primify size)))
240     (rehash-threshold (cond ((null rehash-threshold)
241     size)
242     ((floatp rehash-threshold)
243     (ceiling (* rehash-threshold size)))
244     (t
245     rehash-threshold))))
246     (make-hash-table-structure :rehash-size rehash-size
247 ram 1.1 :rehash-threshold rehash-threshold
248 wlott 1.9.2.1 :table (make-array size :initial-element nil)
249 ram 1.1 :kind test)))
250 wlott 1.9.2.1
251    
252 ram 1.1
253     ;;; Manipulating hash tables:
254    
255     (defun gethash (key hash-table &optional default)
256     "Finds the entry in Hash-Table whose key is Key and returns the associated
257     value and T as multiple values, or returns Default and Nil if there is no
258     such entry."
259 wlott 1.9.2.1 (without-gcing
260     (when (hash-table-needing-rehash hash-table)
261     (flush-needing-rehash hash-table))
262     (let* ((vector (hash-table-table hash-table))
263     (size (length vector))
264     (hashing (hash hash-table key))
265     (index (rem hashing size))
266     (bucket (find-bucket hash-table (svref vector index) key hashing)))
267     (if bucket
268     (values (hash-table-bucket-value bucket) t)
269     (values default nil)))))
270 ram 1.1
271 wlott 1.9.2.1
272 ram 1.1 (defun %puthash (key hash-table value)
273     "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
274     is an entry for KEY, replace it. Returns VALUE."
275 wlott 1.9.2.1 (without-gcing
276     (cond ((> (hash-table-number-entries hash-table)
277     (hash-table-rehash-threshold hash-table))
278     (rehash hash-table))
279     ((hash-table-needing-rehash hash-table)
280     (flush-needing-rehash hash-table)))
281     (let* ((vector (hash-table-table hash-table))
282     (size (length vector)))
283     (multiple-value-bind (hashing scav-hook-p) (hash hash-table key)
284     (let* ((index (rem hashing size))
285     (bucket (find-bucket hash-table (svref vector index)
286     key hashing)))
287     (if bucket
288     (setf (hash-table-bucket-value bucket) value)
289     (setf (svref vector index)
290     (make-hash-table-bucket hash-table key hashing value
291     (svref vector index)
292     scav-hook-p)))))))
293     value)
294 ram 1.1
295     (defun remhash (key hash-table)
296     "Remove any entry for KEY in HASH-TABLE. Returns T if such an entry
297 wlott 1.9.2.1 existed, and NIL if not."
298     (without-gcing
299     (when (hash-table-needing-rehash hash-table)
300     (flush-needing-rehash hash-table))
301     (let* ((vector (hash-table-table hash-table))
302     (size (length vector))
303     (hashing (hash hash-table key))
304     (index (rem hashing size)))
305     (multiple-value-bind
306     (bucket prev)
307     (find-bucket hash-table (svref vector index) key hashing)
308     (when bucket
309     (if prev
310     (setf (hash-table-bucket-next prev)
311     (hash-table-bucket-next bucket))
312     (setf (svref vector index)
313     (hash-table-bucket-next bucket)))
314     (decf (hash-table-number-entries hash-table))
315     t)))))
316    
317    
318 ram 1.1 (defun maphash (map-function hash-table)
319     "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
320     of the entry; returns T."
321     (let ((vector (hash-table-table hash-table)))
322     (declare (simple-vector vector))
323 wlott 1.9.2.1 (dotimes (index (length vector))
324     (do ((bucket (aref vector index) (hash-table-bucket-next bucket)))
325 ram 1.1 ((null bucket))
326 wlott 1.9.2.1 (funcall map-function
327     (hash-table-bucket-key bucket)
328     (hash-table-bucket-value bucket))))))
329 ram 1.1
330     (defun clrhash (hash-table)
331     "Removes all entries of HASH-TABLE and returns the hash table itself."
332 wlott 1.9.2.1 (declare (type hash-table hash-table))
333 ram 1.1 (let ((vector (hash-table-table hash-table)))
334     (declare (simple-vector vector))
335     (setf (hash-table-number-entries hash-table) 0)
336 wlott 1.9.2.1 (dotimes (i (length vector))
337     (setf (svref vector i) nil))
338     (setf (hash-table-needing-rehash hash-table) nil))
339     hash-table)
340 ram 1.1
341     (defun hash-table-count (hash-table)
342     "Returns the number of entries in the given Hash-Table."
343     (hash-table-number-entries hash-table))
344 wlott 1.9.2.1
345    
346 ram 1.1
347     ;;; Primitive Hash Function
348    
349     ;;; The maximum length and depth to which we hash lists.
350     (defconstant sxhash-max-len 7)
351     (defconstant sxhash-max-depth 3)
352    
353     (eval-when (compile eval)
354    
355 ram 1.3 (defconstant sxhash-bits-byte (byte 23 0))
356 wlott 1.2 (defconstant sxmash-total-bits 26)
357     (defconstant sxmash-rotate-bits 7)
358    
359     (defmacro sxmash (place with)
360     (let ((n-with (gensym)))
361     `(let ((,n-with ,with))
362     (declare (fixnum ,n-with))
363     (setf ,place
364     (logxor (ash ,n-with ,(- sxmash-rotate-bits sxmash-total-bits))
365     (ash (logand ,n-with
366     ,(1- (ash 1
367     (- sxmash-total-bits
368     sxmash-rotate-bits))))
369     ,sxmash-rotate-bits)
370     (the fixnum ,place))))))
371    
372 ram 1.1 (defmacro sxhash-simple-string (sequence)
373 wlott 1.6 `(%sxhash-simple-string ,sequence))
374 ram 1.1
375     (defmacro sxhash-string (sequence)
376     (let ((data (gensym))
377     (start (gensym))
378     (end (gensym)))
379     `(with-array-data ((,data ,sequence)
380     (,start)
381 wlott 1.2 (,end))
382 ram 1.1 (if (zerop ,start)
383 wlott 1.6 (%sxhash-simple-substring ,data ,end)
384 ram 1.1 (sxhash-simple-string (coerce (the string ,sequence)
385     'simple-string))))))
386    
387     (defmacro sxhash-list (sequence depth)
388     `(if (= ,depth sxhash-max-depth)
389     0
390     (do ((sequence ,sequence (cdr (the list sequence)))
391     (index 0 (1+ index))
392     (hash 2))
393     ((or (atom sequence) (= index sxhash-max-len)) hash)
394     (declare (fixnum hash index))
395 wlott 1.2 (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))
396 ram 1.1
397 wlott 1.2
398 ram 1.1 ); eval-when (compile eval)
399    
400    
401     (defun sxhash (s-expr)
402     "Computes a hash code for S-EXPR and returns it as an integer."
403     (internal-sxhash s-expr 0))
404    
405 wlott 1.2
406 ram 1.1 (defun internal-sxhash (s-expr depth)
407     (typecase s-expr
408 wlott 1.2 ;; The pointers and immediate types.
409     (list (sxhash-list s-expr depth))
410     (fixnum
411 ram 1.3 (ldb sxhash-bits-byte s-expr))
412 wlott 1.4 (structure
413     (internal-sxhash (type-of s-expr) depth))
414 wlott 1.2 ;; Other-pointer types.
415     (simple-string (sxhash-simple-string s-expr))
416 ram 1.1 (symbol (sxhash-simple-string (symbol-name s-expr)))
417     (number
418     (etypecase s-expr
419 ram 1.3 (integer (ldb sxhash-bits-byte s-expr))
420     (single-float
421 wlott 1.7 (let ((bits (single-float-bits s-expr)))
422 ram 1.3 (ldb sxhash-bits-byte
423     (logxor (ash bits (- sxmash-rotate-bits))
424     bits))))
425     (double-float
426     (let* ((val s-expr)
427 wlott 1.7 (lo (double-float-low-bits val))
428     (hi (double-float-high-bits val)))
429 ram 1.3 (ldb sxhash-bits-byte
430     (logxor (ash lo (- sxmash-rotate-bits))
431     (ash hi (- sxmash-rotate-bits))
432     lo hi))))
433 ram 1.1 (ratio (the fixnum (+ (internal-sxhash (numerator s-expr) 0)
434     (internal-sxhash (denominator s-expr) 0))))
435     (complex (the fixnum (+ (internal-sxhash (realpart s-expr) 0)
436     (internal-sxhash (imagpart s-expr) 0))))))
437 wlott 1.2 (array
438     (typecase s-expr
439     (string (sxhash-string s-expr))
440     (t (array-rank s-expr))))
441     ;; Everything else.
442 ram 1.3 (t 42)))
443 wlott 1.8
444    
445    
446     ;;;; WITH-HASH-TABLE-ITERATOR
447    
448     (defmacro with-hash-table-iterator ((function hash-table) &body body)
449     "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
450     provides a method of manually looping over the elements of a hash-table.
451     function is bound to a generator-macro that, withing the scope of the
452     invocation, returns three values. First, whether there are any more objects
453     in the hash-table, second, the key, and third, the value."
454     (let ((counter (gensym))
455 wlott 1.9.2.1 (bucket (gensym))
456 wlott 1.8 (table (gensym))
457 wlott 1.9.2.1 (size (gensym)))
458     `(let* ((,table (hash-table-table ,hash-table))
459     (,size (length ,table))
460 wlott 1.8 (,counter 0)
461 wlott 1.9.2.1 (,bucket (svref ,table 0)))
462     (declare (type index ,counter ,size)
463     (type simple-vector ,table)
464     (type (or null hash-table-bucket) ,bucket))
465 wlott 1.8 (macrolet ((,function ()
466     `(loop
467 wlott 1.9.2.1 (when (= ,',counter ,',size)
468     (return))
469     (if ,',bucket
470     (return
471     (multiple-value-prog1
472     (values t
473     (hash-table-bucket-key ,',bucket)
474     (hash-table-bucket-value ,',bucket))
475     (setf ,',bucket
476     (hash-table-bucket-next ,',bucket))))
477     (setf ,',bucket
478     (svref ,table (incf ,',counter)))))))
479 wlott 1.8 ,@body))))

  ViewVC Help
Powered by ViewVC 1.1.5