src/compiler/sset.lisp

   1 ;;;; This file implements a sparse set abstraction, represented as a
   2 ;;;; sorted linked list. We don't use bit-vectors to represent sets in
   3 ;;;; flow analysis, since the universe may be quite large but the
   4 ;;;; average number of elements is small. We keep the list sorted so
   5 ;;;; that we can do union and intersection in linear time.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!C")
  17
  18 ;;; Each structure that may be placed in a SSET must include the
  19 ;;; SSET-ELEMENT structure. We allow an initial value of NIL to mean
  20 ;;; that no ordering has been assigned yet (although an ordering must
  21 ;;; be assigned before doing set operations.)
  22 (defstruct (sset-element (:constructor nil)
  23                          (:copier nil))
  24   (number nil :type (or index null)))
  25
  26 (defstruct (sset (:copier nil))
  27   ;; The element at the head of the list here seems always to be
  28   ;; ignored. I think this idea is that the extra level of indirection
  29   ;; it provides is handy to allow various destructive operations on
  30   ;; SSETs to be expressed more easily. -- WHN
  31   (elements (list nil) :type cons))
  32 (defprinter (sset)
  33   (elements :prin1 (cdr elements)))
  34
  35 ;;; Iterate over the elements in SSET, binding VAR to each element in
  36 ;;; turn.
  37 (defmacro do-sset-elements ((var sset &optional result) &body body)
  38   `(dolist (,var (cdr (sset-elements ,sset)) ,result) ,@body))
  39
  40 ;;; Destructively add ELEMENT to SET. If ELEMENT was not in the set,
  41 ;;; then we return true, otherwise we return false.
  42 (declaim (ftype (function (sset-element sset) boolean) sset-adjoin))
  43 (defun sset-adjoin (element set)
  44   (let ((number (sset-element-number element))
  45         (elements (sset-elements set)))
  46     (do ((prev elements current)
  47          (current (cdr elements) (cdr current)))
  48         ((null current)
  49          (setf (cdr prev) (list element))
  50          t)
  51       (let ((el (car current)))
  52         (when (>= (sset-element-number el) number)
  53           (when (eq el element)
  54             (return nil))
  55           (setf (cdr prev) (cons element current))
  56           (return t))))))
  57
  58 ;;; Destructively remove ELEMENT from SET. If element was in the set,
  59 ;;; then return true, otherwise return false.
  60 (declaim (ftype (function (sset-element sset) boolean) sset-delete))
  61 (defun sset-delete (element set)
  62   (let ((elements (sset-elements set)))
  63     (do ((prev elements current)
  64          (current (cdr elements) (cdr current)))
  65         ((null current) nil)
  66       (when (eq (car current) element)
  67         (setf (cdr prev) (cdr current))
  68         (return t)))))
  69
  70 ;;; Return true if ELEMENT is in SET, false otherwise.
  71 (declaim (ftype (function (sset-element sset) boolean) sset-member))
  72 (defun sset-member (element set)
  73   (declare (inline member))
  74   (not (null (member element (cdr (sset-elements set)) :test #'eq))))
  75
  76 (declaim (ftype (function (sset sset) boolean) sset=))
  77 (defun sset= (set1 set2)
  78   (equal (sset-elements set1) (sset-elements set2)))
  79
  80 ;;; Return true if SET contains no elements, false otherwise.
  81 (declaim (ftype (function (sset) boolean) sset-empty))
  82 (defun sset-empty (set)
  83   (null (cdr (sset-elements set))))
  84
  85 ;;; Return a new copy of SET.
  86 (declaim (ftype (function (sset) sset) copy-sset))
  87 (defun copy-sset (set)
  88   (make-sset :elements (copy-list (sset-elements set))))
  89
  90 ;;; Perform the appropriate set operation on SET1 and SET2 by
  91 ;;; destructively modifying SET1. We return true if SET1 was modified,
  92 ;;; false otherwise.
  93 (declaim (ftype (function (sset sset) boolean) sset-union sset-intersection
  94                 sset-difference))
  95 (defun sset-union (set1 set2)
  96   (let* ((prev-el1 (sset-elements set1))
  97          (el1 (cdr prev-el1))
  98          (changed nil))
  99     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
 100         ((null el2) changed)
 101       (let* ((e (car el2))
 102              (num2 (sset-element-number e)))
 103         (loop
 104           (when (null el1)
 105             (setf (cdr prev-el1) (copy-list el2))
 106             (return-from sset-union t))
 107           (let ((num1 (sset-element-number (car el1))))
 108             (when (>= num1 num2)
 109               (if (> num1 num2)
 110                   (let ((new (cons e el1)))
 111                     (setf (cdr prev-el1) new)
 112                     (setq prev-el1 new
 113                           changed t))
 114                   (shiftf prev-el1 el1 (cdr el1)))
 115               (return))
 116             (shiftf prev-el1 el1 (cdr el1))))))))
 117 (defun sset-intersection (set1 set2)
 118   (let* ((prev-el1 (sset-elements set1))
 119          (el1 (cdr prev-el1))
 120          (changed nil))
 121     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
 122         ((null el2)
 123          (cond (el1
 124                 (setf (cdr prev-el1) nil)
 125                 t)
 126                (t changed)))
 127       (let ((num2 (sset-element-number (car el2))))
 128         (loop
 129           (when (null el1)
 130             (return-from sset-intersection changed))
 131           (let ((num1 (sset-element-number (car el1))))
 132             (when (>= num1 num2)
 133               (when (= num1 num2)
 134                 (shiftf prev-el1 el1 (cdr el1)))
 135               (return))
 136             (pop el1)
 137             (setf (cdr prev-el1) el1)
 138             (setq changed t)))))))
 139 (defun sset-difference (set1 set2)
 140   (let* ((prev-el1 (sset-elements set1))
 141          (el1 (cdr prev-el1))
 142          (changed nil))
 143     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
 144         ((null el2) changed)
 145       (let ((num2 (sset-element-number (car el2))))
 146         (loop
 147           (when (null el1)
 148             (return-from sset-difference changed))
 149           (let ((num1 (sset-element-number (car el1))))
 150             (when (>= num1 num2)
 151               (when (= num1 num2)
 152                 (pop el1)
 153                 (setf (cdr prev-el1) el1)
 154                 (setq changed t))
 155               (return))
 156             (shiftf prev-el1 el1 (cdr el1))))))))
 157
 158 ;;; Destructively modify SET1 to include its union with the difference
 159 ;;; of SET2 and SET3. We return true if SET1 was modified, false
 160 ;;; otherwise.
 161 (declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference))
 162 (defun sset-union-of-difference (set1 set2 set3)
 163   (let* ((prev-el1 (sset-elements set1))
 164          (el1 (cdr prev-el1))
 165          (el3 (cdr (sset-elements set3)))
 166          (changed nil))
 167     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
 168         ((null el2) changed)
 169       (let* ((e (car el2))
 170              (num2 (sset-element-number e)))
 171         (loop
 172           (when (null el3)
 173             (loop
 174               (when (null el1)
 175                 (setf (cdr prev-el1) (copy-list el2))
 176                 (return-from sset-union-of-difference t))
 177               (let ((num1 (sset-element-number (car el1))))
 178                 (when (>= num1 num2)
 179                   (if (> num1 num2)
 180                       (let ((new (cons e el1)))
 181                         (setf (cdr prev-el1) new)
 182                         (setq prev-el1 new  changed t))
 183                       (shiftf prev-el1 el1 (cdr el1)))
 184                   (return))
 185                 (shiftf prev-el1 el1 (cdr el1))))
 186             (return))
 187           (let ((num3 (sset-element-number (car el3))))
 188             (when (<= num2 num3)
 189               (unless (= num2 num3)
 190                 (loop
 191                   (when (null el1)
 192                     (do ((el2 el2 (cdr el2)))
 193                         ((null el2)
 194                          (return-from sset-union-of-difference changed))
 195                       (let* ((e (car el2))
 196                              (num2 (sset-element-number e)))
 197                         (loop
 198                           (when (null el3)
 199                             (setf (cdr prev-el1) (copy-list el2))
 200                             (return-from sset-union-of-difference t))
 201                           (setq num3 (sset-element-number (car el3)))
 202                           (when (<= num2 num3)
 203                             (unless (= num2 num3)
 204                               (let ((new (cons e el1)))
 205                                 (setf (cdr prev-el1) new)
 206                                 (setq prev-el1 new  changed t)))
 207                             (return))
 208                           (pop el3)))))
 209                   (let ((num1 (sset-element-number (car el1))))
 210                     (when (>= num1 num2)
 211                       (if (> num1 num2)
 212                           (let ((new (cons e el1)))
 213                             (setf (cdr prev-el1) new)
 214                             (setq prev-el1 new  changed t))
 215                           (shiftf prev-el1 el1 (cdr el1)))
 216                       (return))
 217                     (shiftf prev-el1 el1 (cdr el1)))))
 218               (return)))
 219           (pop el3))))))