« back to all changes in this revision
Viewing changes to fixhash.lisp
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Peter Van Eynde
- Date: 2005-04-06 21:05:07 UTC
- Revision ID: james.westby@ubuntu.com-20050406210507-c5scopf13gkyikqs
Tags: upstream-0.7.1
Import upstream version 0.7.1
added
removed
fixhash.lisp
1
;;;
2
;;; fixhash.lisp
3
;;;
4
;;; Created: 2005-03-19 by Zach Beane <xach@xach.com>
5
;;;
6
;;; A hashtable whose keys and values are known to be fixnums^Wof a
7
;;; fixed, relatively small size. Sadly, not small enough to be
8
;;; fixnums on LispWorks.
9
;;;
10
;;; This table isn't general; it assumes that the compressor never
11
;;; uses zero for a key.
12
;;;
13
;;; Copyright (c) 2005 Zachary Beane, All Rights Reserved
14
;;;
15
;;; Redistribution and use in source and binary forms, with or without
16
;;; modification, are permitted provided that the following conditions
17
;;; are met:
18
;;;
19
;;; * Redistributions of source code must retain the above copyright
20
;;; notice, this list of conditions and the following disclaimer.
21
;;;
22
;;; * Redistributions in binary form must reproduce the above
23
;;; copyright notice, this list of conditions and the following
24
;;; disclaimer in the documentation and/or other materials
25
;;; provided with the distribution.
26
;;;
27
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
28
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
29
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
30
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
31
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
32
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
33
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
34
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
35
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
36
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
37
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
38
;;;
39
;;; $Id: fixhash.lisp,v 1.7 2005/04/01 21:55:24 xach Exp $
40
41
(defpackage :fixhash
42
(:use :cl)
43
(:export :make-fixhash-table
44
:getfixhash
45
:clrfixhash))
46
47
(in-package :fixhash)
48
49
(deftype fixhash-integer ()
50
"#xFFFFFF is out of fixnum range on LispWorks."
51
'(integer 0 #xFFFFFF))
52
53
(defparameter *sizes*
54
#(4096
55
16384
56
65536
57
131072))
58
59
(defstruct fixhash-table
60
(level 0 :type fixnum)
61
(size 4096 :type fixnum)
62
(keys/values (make-array (* 4096 2)
63
:element-type 'fixhash-integer
64
:initial-element 0)
65
:type (simple-array fixhash-integer (*)))
66
(last-key 0 :type fixhash-integer)
67
(last-key-pos 0 :type fixnum))
68
69
(defmethod print-object ((fixhash-table fixhash-table) stream)
70
(print-unreadable-object (fixhash-table stream :type t :identity t)
71
(format stream "~D/~D"
72
(fixhash-table-level fixhash-table)
73
(fixhash-table-size fixhash-table))))
74
75
(defun rehash (table)
76
(declare (optimize (speed 3) (safety 0)))
77
(let ((level (fixhash-table-level table))
78
(keys/values (fixhash-table-keys/values table))
79
(size (fixhash-table-size table)))
80
(when (= 3 level)
81
(error "Hash table full"))
82
(let* ((new-size (svref *sizes* (incf level)))
83
(new-keys/values (make-array (the fixnum (* new-size 2))
84
:initial-element 0
85
:element-type 'fixhash-integer)))
86
(dotimes (i (* size 2))
87
(setf (aref new-keys/values i) (aref keys/values i)))
88
(setf (fixhash-table-keys/values table) new-keys/values
89
(fixhash-table-size table) new-size
90
(fixhash-table-level table) level))))
91
92
(defun getfixhash (k fixhash-table)
93
(declare (optimize (speed 3) (safety 0) (debug 0)
94
#+lispworks (hcl:fixnum-safety 0))
95
(type fixhash-integer k))
96
(let* ((size (fixhash-table-size fixhash-table))
97
(mask (1- size))
98
(h1 (logand k mask))
99
(h2 (logior 1 (mod k (1- size))))
100
(j 0)
101
(i*h2 0)
102
(table (fixhash-table-keys/values fixhash-table)))
103
(declare (type (integer 0 131072) size mask h1 h2 j i*h2))
104
(dotimes (i size (and (rehash fixhash-table) 0))
105
(declare (fixnum i))
106
(incf i*h2 h2)
107
(setf j (ash (logand mask (+ h1 i*h2)) 1))
108
(let ((kt (aref table j)))
109
(when (= k kt)
110
(return (aref table (1+ j))))
111
(when (zerop kt)
112
(setf (fixhash-table-last-key fixhash-table) k
113
(fixhash-table-last-key-pos fixhash-table) j)
114
(return 0))))))
115
116
(defun (setf getfixhash) (new-value k fixhash-table)
117
(declare (optimize (speed 3) (safety 0) (debug 0)
118
#+lispworks (hcl:fixnum-safety 0))
119
(type fixhash-integer new-value k))
120
(let ((last-key (fixhash-table-last-key fixhash-table))
121
(last-key-pos (fixhash-table-last-key-pos fixhash-table))
122
(table (fixhash-table-keys/values fixhash-table)))
123
(if (= last-key k)
124
(setf (aref table last-key-pos) k
125
(aref table (1+ last-key-pos)) new-value)
126
(let* ((size (fixhash-table-size fixhash-table))
127
(mask (1- size))
128
(h1 (logand k mask))
129
(h2 (logior 1 (mod k (1- size))))
130
(i*h2 0)
131
(j 0))
132
(declare (type (integer 0 131072) h2 h1 i*h2 size mask))
133
(dotimes (i size)
134
(declare (fixnum i))
135
(incf i*h2 h2)
136
(setf j (ash (logand mask (+ h1 i*h2)) 1))
137
(let ((kt (aref table j)))
138
(when (or (= k kt) (zerop kt))
139
(setf (aref table j) k
140
(aref table (1+ j)) new-value)
141
(return new-value))))))))
142
143
(defun clrfixhash (fixhash-table)
144
(declare (optimize (speed 3) (safety 0)
145
#+lispworks (hcl:fixnum-safety 0)))
146
(let ((table (fixhash-table-keys/values fixhash-table)))
147
(dotimes (i (length table))
148
(declare (fixnum i))
149
(setf (aref table i) 0)))
150
fixhash-table)
151
Loggerhead is a web-based interface for Breezy
Version: 2.0.1