src/compiler/sset.lisp

   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.
  10
  11 ;;;; This software is part of the SBCL system. See the README file for
  12 ;;;; more information.
  13 ;;;;
  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)
  19
  20 (in-package "SB!C")
  21
  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)
  27                          (:copier nil))
  28   (number nil :type (or index null)))
  29
  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
  34   ;; longer do.
  35   (vector #() :type simple-vector)
  36   ;; How many buckets currently contain or used to contain an element.
  37   (free 0 :type index)
  38   ;; How many elements are currently members of the set.
  39   (count 0 :type index))
  40 (defprinter (sset) vector)
  41
  42 ;;; Iterate over the elements in SSET, binding VAR to each element in
  43 ;;; turn.
  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+))
  47               ,@body)
  48          finally (return ,result)))
  49
  50 ;;; Primary hash.
  51 (declaim (inline sset-hash1))
  52 (defun sset-hash1 (element)
  53   #+sb-xc-host
  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)))))
  61   #-sb-xc-host
  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))))
  73
  74 ;;; Secondary hash (for double hash probing). Needs to return an odd
  75 ;;; number.
  76 (declaim (inline sset-hash2))
  77 (defun sset-hash2 (element)
  78   (let ((number (sset-element-number element)))
  79     (declare (fixnum number))
  80     (logior 1 number)))
  81
  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))
  86                                      2
  87                                      (* (length vector) 2))
  88                                  :initial-element 0)))
  89     (setf (sset-vector set) new-vector
  90           (sset-free set) (length new-vector)
  91           (sset-count set) 0)
  92     (loop for element across vector
  93           do (unless (member element '(0 +deleted+))
  94                (sset-adjoin element set)))))
  95
  96 ;;; Rehash the sset when the proportion of free cells in the set is
  97 ;;; lower than this.
  98 (eval-when (:compile-toplevel :load-toplevel :execute)
  99   (defconstant +sset-rehash-threshold+ 1/4))
 100
 101 ;;; Destructively add ELEMENT to SET. If ELEMENT was not in the set,
 102 ;;; then we return true, otherwise we return false.
 103 (declaim (ftype (sfunction (sset-element sset) boolean) sset-adjoin))
 104 (defun sset-adjoin (element set)
 105   (declare (optimize (speed 2)))
 106   (when (<= (sset-free set)
 107             (max 1 (truncate (length (sset-vector set))
 108                              #.(round (/ +sset-rehash-threshold+)))))
 109     (sset-grow set))
 110   (loop with vector = (sset-vector set)
 111         with mask of-type fixnum = (1- (length vector))
 112         with secondary-hash = (sset-hash2 element)
 113         for hash of-type index = (logand mask (sset-hash1 element)) then
 114           (logand mask (+ hash secondary-hash))
 115         for current = (aref vector hash)
 116         for deleted-index = nil
 117         do (cond ((eql current 0)
 118                   (incf (sset-count set))
 119                   (cond (deleted-index
 120                          (setf (aref vector deleted-index) element))
 121                         (t
 122                          (decf (sset-free set))
 123                          (setf (aref vector hash) element)))
 124                   (return t))
 125                  ((and (eql current '+deleted+)
 126                        (not deleted-index))
 127                   (setf deleted-index hash))
 128                  ((eq current element)
 129                   (return nil)))))
 130
 131 ;;; Destructively remove ELEMENT from SET. If element was in the set,
 132 ;;; then return true, otherwise return false.
 133 (declaim (ftype (sfunction (sset-element sset) boolean) sset-delete))
 134 (defun sset-delete (element set)
 135   (when (zerop (length (sset-vector set)))
 136     (return-from sset-delete nil))
 137   (loop with vector = (sset-vector set)
 138         with mask fixnum = (1- (length vector))
 139         with secondary-hash = (sset-hash2 element)
 140         for hash of-type index = (logand mask (sset-hash1 element)) then
 141           (logand mask (+ hash secondary-hash))
 142         for current = (aref vector hash)
 143         do (cond ((eql current 0)
 144                   (return nil))
 145                  ((eq current element)
 146                   (decf (sset-count set))
 147                   (setf (aref vector hash) '+deleted+)
 148                   (return t)))))
 149
 150 ;;; Return true if ELEMENT is in SET, false otherwise.
 151 (declaim (ftype (sfunction (sset-element sset) boolean) sset-member))
 152 (defun sset-member (element set)
 153   (when (zerop (length (sset-vector set)))
 154     (return-from sset-member nil))
 155   (loop with vector = (sset-vector set)
 156         with mask fixnum = (1- (length vector))
 157         with secondary-hash = (sset-hash2 element)
 158         for hash of-type index = (logand mask (sset-hash1 element)) then
 159           (logand mask (+ hash secondary-hash))
 160         for current = (aref vector hash)
 161         do (cond ((eql current 0)
 162                   (return nil))
 163                  ((eq current element)
 164                   (return t)))))
 165
 166 (declaim (ftype (sfunction (sset sset) boolean) sset=))
 167 (defun sset= (set1 set2)
 168   (unless (eql (sset-count set1)
 169                (sset-count set2))
 170     (return-from sset= nil))
 171   (do-sset-elements (element set1)
 172     (unless (sset-member element set2)
 173       (return-from sset= nil)))
 174   t)
 175
 176 ;;; Return true if SET contains no elements, false otherwise.
 177 (declaim (ftype (sfunction (sset) boolean) sset-empty))
 178 (defun sset-empty (set)
 179   (zerop (sset-count set)))
 180
 181 ;;; Return a new copy of SET.
 182 (declaim (ftype (sfunction (sset) sset) copy-sset))
 183 (defun copy-sset (set)
 184   (make-sset :vector (let* ((vector (sset-vector set))
 185                             (new-vector (make-array (length vector))))
 186                        (declare (type simple-vector vector new-vector)
 187                                 (optimize speed (safety 0)))
 188                        ;; There's no REPLACE deftransform for simple-vectors.
 189                        (dotimes (i (length vector))
 190                          (setf (aref new-vector i)
 191                                (aref vector i)))
 192                        new-vector)
 193              :count (sset-count set)
 194              :free (sset-free set)))
 195
 196 ;;; Perform the appropriate set operation on SET1 and SET2 by
 197 ;;; destructively modifying SET1. We return true if SET1 was modified,
 198 ;;; false otherwise.
 199 (declaim (ftype (sfunction (sset sset) boolean) sset-union sset-intersection
 200                 sset-difference))
 201 (defun sset-union (set1 set2)
 202   (loop with modified = nil
 203         for element across (sset-vector set2)
 204         do (unless (member element '(0 +deleted+))
 205              (when (sset-adjoin element set1)
 206                (setf modified t)))
 207         finally (return modified)))
 208 (defun sset-intersection (set1 set2)
 209   (loop with modified = nil
 210         for element across (sset-vector set1)
 211         for index of-type index from 0
 212         do (unless (member element '(0 +deleted+))
 213              (unless (sset-member element set2)
 214                (decf (sset-count set1))
 215                (setf (aref (sset-vector set1) index) '+deleted+
 216                      modified t)))
 217         finally (return modified)))
 218 (defun sset-difference (set1 set2)
 219   (loop with modified = nil
 220         for element across (sset-vector set1)
 221         for index of-type index from 0
 222         do (unless (member element '(0 +deleted+))
 223              (when (sset-member element set2)
 224                (decf (sset-count set1))
 225                (setf (aref (sset-vector set1) index) '+deleted+
 226                      modified t)))
 227         finally (return modified)))
 228
 229 ;;; Destructively modify SET1 to include its union with the difference
 230 ;;; of SET2 and SET3. We return true if SET1 was modified, false
 231 ;;; otherwise.
 232 (declaim (ftype (sfunction (sset sset sset) boolean) sset-union-of-difference))
 233 (defun sset-union-of-difference (set1 set2 set3)
 234   (loop with modified = nil
 235         for element across (sset-vector set2)
 236         do (unless (member element '(0 +deleted+))
 237              (unless (sset-member element set3)
 238                (when (sset-adjoin element set1)
 239                  (setf modified t))))
 240         finally (return modified)))