1 ;;;; This file implements a sparse set abstraction, represented as a
2 ;;;; custom lightweight hash-table. We don't use bit-vectors to
3 ;;;; represent sets in flow analysis, since the universe may be quite
4 ;;;; large but the average number of elements is small. We also don't
5 ;;;; use sorted lists like in the original CMUCL code, since it had
6 ;;;; bad worst-case performance (on some real-life programs the
7 ;;;; hash-based sset gives a 20% compilation speedup). A custom
8 ;;;; hash-table is used since the standard one is too heavy (locking,
9 ;;;; memory use) for this use.
11 ;;;; This software is part of the SBCL system. See the README file for
12 ;;;; more information.
14 ;;;; This software is derived from the CMU CL system, which was
15 ;;;; written at Carnegie Mellon University and released into the
16 ;;;; public domain. The software is in the public domain and is
17 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
18 ;;;; files for more information. (This file no)
22 ;;; Each structure that may be placed in a SSET must include the
23 ;;; SSET-ELEMENT structure. We allow an initial value of NIL to mean
24 ;;; that no ordering has been assigned yet (although an ordering must
25 ;;; be assigned before doing set operations.)
26 (def!struct
(sset-element (:constructor nil
)
28 (number nil
:type
(or index null
)))
30 (defstruct (sset (:copier nil
))
31 ;; Vector containing the set values. 0 is used for empty (since
32 ;; initializing a vector with 0 is cheaper than with NIL), +DELETED+
33 ;; is used to mark buckets that used to contain an element, but no
35 (vector #() :type simple-vector
)
36 ;; How many buckets currently contain or used to contain an element.
38 ;; How many elements are currently members of the set.
39 (count 0 :type index
))
40 (defprinter (sset) vector
)
42 ;;; Iterate over the elements in SSET, binding VAR to each element in
44 (defmacro do-sset-elements
((var sset
&optional result
) &body body
)
45 `(loop for
,var across
(sset-vector ,sset
)
46 do
(unless (member ,var
'(0 +deleted
+))
48 finally
(return ,result
)))
51 (declaim (inline sset-hash1
))
52 (defun sset-hash1 (element)
54 (let ((result (sset-element-number element
)))
55 ;; This is performance critical, and it's not certain that the host
56 ;; compiler does modular arithmetic optimization. Instad use
57 ;; something that most CL implementations will do efficiently.
58 (the fixnum
(logxor (the fixnum result
)
59 (the fixnum
(ash result -
9))
60 (the fixnum
(ash result -
5)))))
62 (let ((result (sset-element-number element
)))
63 (declare (type sb
!vm
:word result
))
64 ;; We only use the low-order bits.
65 (macrolet ((set-result (form)
66 `(setf result
(ldb (byte #.sb
!vm
:n-word-bits
0) ,form
))))
67 (set-result (+ result
(ash result -
19)))
68 (set-result (logxor result
(ash result -
13)))
69 (set-result (+ result
(ash result -
9)))
70 (set-result (logxor result
(ash result -
5)))
71 (set-result (+ result
(ash result -
2)))
72 (logand sb
!xc
:most-positive-fixnum result
))))
74 ;;; Secondary hash (for double hash probing). Needs to return an odd
76 (declaim (inline sset-hash2
))
77 (defun sset-hash2 (element)
78 (let ((number (sset-element-number element
)))
79 (declare (fixnum number
))
82 ;;; Double the size of the hash vector of SET.
83 (defun sset-grow (set)
84 (let* ((vector (sset-vector set
))
85 (new-vector (make-array (if (zerop (length vector
))
87 (* (length vector
) 2))
89 (setf (sset-vector set
) new-vector
90 (sset-free set
) (length new-vector
)
92 (loop for element across vector
93 do
(unless (member element
'(0 +deleted
+))
94 (sset-adjoin element set
)))))
96 ;;; Rehash the sset when the proportion of free cells in the set is
97 ;;; lower than this, the value is a reciprocal.
98 (defconstant +sset-rehash-threshold
+ 4)
100 ;;; Destructively add ELEMENT to SET. If ELEMENT was not in the set,
101 ;;; then we return true, otherwise we return false.
102 (declaim (ftype (sfunction (sset-element sset
) boolean
) sset-adjoin
))
103 (defun sset-adjoin (element set
)
104 (when (<= (sset-free set
)
105 (max 1 (truncate (length (sset-vector set
))
106 +sset-rehash-threshold
+)))
108 (loop with vector
= (sset-vector set
)
109 with mask of-type fixnum
= (1- (length vector
))
110 with secondary-hash
= (sset-hash2 element
)
111 for hash of-type index
= (logand mask
(sset-hash1 element
)) then
112 (logand mask
(+ hash secondary-hash
))
113 for current
= (aref vector hash
)
114 do
(cond ((eql current
0)
115 (incf (sset-count set
))
116 (decf (sset-free set
))
117 (setf (aref vector hash
) element
)
119 ((eql current
'+deleted
+)
120 (incf (sset-count set
))
121 (setf (aref vector hash
) element
)
123 ((eq current element
)
126 ;;; Destructively remove ELEMENT from SET. If element was in the set,
127 ;;; then return true, otherwise return false.
128 (declaim (ftype (sfunction (sset-element sset
) boolean
) sset-delete
))
129 (defun sset-delete (element set
)
130 (when (zerop (length (sset-vector set
)))
131 (return-from sset-delete nil
))
132 (loop with vector
= (sset-vector set
)
133 with mask fixnum
= (1- (length vector
))
134 with secondary-hash
= (sset-hash2 element
)
135 for hash of-type index
= (logand mask
(sset-hash1 element
)) then
136 (logand mask
(+ hash secondary-hash
))
137 for current
= (aref vector hash
)
138 do
(cond ((eql current
0)
140 ((eq current element
)
141 (decf (sset-count set
))
142 (setf (aref vector hash
) '+deleted
+)
145 ;;; Return true if ELEMENT is in SET, false otherwise.
146 (declaim (ftype (sfunction (sset-element sset
) boolean
) sset-member
))
147 (defun sset-member (element set
)
148 (when (zerop (length (sset-vector set
)))
149 (return-from sset-member nil
))
150 (loop with vector
= (sset-vector set
)
151 with mask fixnum
= (1- (length vector
))
152 with secondary-hash
= (sset-hash2 element
)
153 for hash of-type index
= (logand mask
(sset-hash1 element
)) then
154 (logand mask
(+ hash secondary-hash
))
155 for current
= (aref vector hash
)
156 do
(cond ((eql current
0)
158 ((eq current element
)
161 (declaim (ftype (sfunction (sset sset
) boolean
) sset
=))
162 (defun sset= (set1 set2
)
163 (unless (eql (sset-count set1
)
165 (return-from sset
= nil
))
166 (do-sset-elements (element set1
)
167 (unless (sset-member element set2
)
168 (return-from sset
= nil
)))
171 ;;; Return true if SET contains no elements, false otherwise.
172 (declaim (ftype (sfunction (sset) boolean
) sset-empty
))
173 (defun sset-empty (set)
174 (zerop (sset-count set
)))
176 ;;; Return a new copy of SET.
177 (declaim (ftype (sfunction (sset) sset
) copy-sset
))
178 (defun copy-sset (set)
179 (make-sset :vector
(let* ((vector (sset-vector set
))
180 (new-vector (make-array (length vector
))))
181 (declare (type simple-vector vector new-vector
)
182 (optimize speed
(safety 0)))
183 ;; There's no REPLACE deftransform for simple-vectors.
184 (dotimes (i (length vector
))
185 (setf (aref new-vector i
)
188 :count
(sset-count set
)
189 :free
(sset-free set
)))
191 ;;; Perform the appropriate set operation on SET1 and SET2 by
192 ;;; destructively modifying SET1. We return true if SET1 was modified,
194 (declaim (ftype (sfunction (sset sset
) boolean
) sset-union sset-intersection
196 (defun sset-union (set1 set2
)
197 (loop with modified
= nil
198 for element across
(sset-vector set2
)
199 do
(unless (member element
'(0 +deleted
+))
200 (when (sset-adjoin element set1
)
202 finally
(return modified
)))
203 (defun sset-intersection (set1 set2
)
204 (loop with modified
= nil
205 for element across
(sset-vector set1
)
206 for index of-type index from
0
207 do
(unless (member element
'(0 +deleted
+))
208 (unless (sset-member element set2
)
209 (decf (sset-count set1
))
210 (setf (aref (sset-vector set1
) index
) '+deleted
+
212 finally
(return modified
)))
213 (defun sset-difference (set1 set2
)
214 (loop with modified
= nil
215 for element across
(sset-vector set1
)
216 for index of-type index from
0
217 do
(unless (member element
'(0 +deleted
+))
218 (when (sset-member element set2
)
219 (decf (sset-count set1
))
220 (setf (aref (sset-vector set1
) index
) '+deleted
+
222 finally
(return modified
)))
224 ;;; Destructively modify SET1 to include its union with the difference
225 ;;; of SET2 and SET3. We return true if SET1 was modified, false
227 (declaim (ftype (sfunction (sset sset sset
) boolean
) sset-union-of-difference
))
228 (defun sset-union-of-difference (set1 set2 set3
)
229 (loop with modified
= nil
230 for element across
(sset-vector set2
)
231 do
(unless (member element
'(0 +deleted
+))
232 (unless (sset-member element set3
)
233 (when (sset-adjoin element set1
)
235 finally
(return modified
)))