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 (:constructor make-sset ()))
  27   (elements (list nil) :type list))
  28 (defprinter (sset)
  29   (elements :prin1 (cdr elements)))
  30
  31 ;;; Iterate over the elements in SSET, binding VAR to each element in
  32 ;;; turn.
  33 (defmacro do-sset-elements ((var sset &optional result) &body body)
  34   `(dolist (,var (cdr (sset-elements ,sset)) ,result) ,@body))
  35
  36 ;;; Destructively add Element to Set. If Element was not in the set,
  37 ;;; then we return true, otherwise we return false.
  38 (declaim (ftype (function (sset-element sset) boolean) sset-adjoin))
  39 (defun sset-adjoin (element set)
  40   (let ((number (sset-element-number element))
  41         (elements (sset-elements set)))
  42     (do ((prev elements current)
  43          (current (cdr elements) (cdr current)))
  44         ((null current)
  45          (setf (cdr prev) (list element))
  46          t)
  47       (let ((el (car current)))
  48         (when (>= (sset-element-number el) number)
  49           (when (eq el element)
  50             (return nil))
  51           (setf (cdr prev) (cons element current))
  52           (return t))))))
  53
  54 ;;; Destructively remove Element from Set. If element was in the set,
  55 ;;; then return true, otherwise return false.
  56 (declaim (ftype (function (sset-element sset) boolean) sset-delete))
  57 (defun sset-delete (element set)
  58   (let ((elements (sset-elements set)))
  59     (do ((prev elements current)
  60          (current (cdr elements) (cdr current)))
  61         ((null current) nil)
  62       (when (eq (car current) element)
  63         (setf (cdr prev) (cdr current))
  64         (return t)))))
  65
  66 ;;; Return true if Element is in Set, false otherwise.
  67 (declaim (ftype (function (sset-element sset) boolean) sset-member))
  68 (defun sset-member (element set)
  69   (declare (inline member))
  70   (not (null (member element (cdr (sset-elements set)) :test #'eq))))
  71
  72 ;;; Return true if SET contains no elements, false otherwise.
  73 (declaim (ftype (function (sset) boolean) sset-empty))
  74 (defun sset-empty (set)
  75   (null (cdr (sset-elements set))))
  76
  77 ;;; Return a new copy of SET.
  78 (declaim (ftype (function (sset) sset) copy-sset))
  79 (defun copy-sset (set)
  80   (let ((res (make-sset)))
  81     (setf (sset-elements res) (copy-list (sset-elements set)))
  82     res))
  83
  84 ;;; Perform the appropriate set operation on SET1 and SET2 by destructively
  85 ;;; modifying SET1. We return true if SET1 was modified, false otherwise.
  86 (declaim (ftype (function (sset sset) boolean) sset-union sset-intersection
  87                 sset-difference))
  88 (defun sset-union (set1 set2)
  89   (let* ((prev-el1 (sset-elements set1))
  90          (el1 (cdr prev-el1))
  91          (changed nil))
  92     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
  93         ((null el2) changed)
  94       (let* ((e (car el2))
  95              (num2 (sset-element-number e)))
  96         (loop
  97           (when (null el1)
  98             (setf (cdr prev-el1) (copy-list el2))
  99             (return-from sset-union t))
 100           (let ((num1 (sset-element-number (car el1))))
 101             (when (>= num1 num2)
 102               (if (> num1 num2)
 103                   (let ((new (cons e el1)))
 104                     (setf (cdr prev-el1) new)
 105                     (setq prev-el1 new  changed t))
 106                   (shiftf prev-el1 el1 (cdr el1)))
 107               (return))
 108             (shiftf prev-el1 el1 (cdr el1))))))))
 109 (defun sset-intersection (set1 set2)
 110   (let* ((prev-el1 (sset-elements set1))
 111          (el1 (cdr prev-el1))
 112          (changed nil))
 113     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
 114         ((null el2)
 115          (cond (el1
 116                 (setf (cdr prev-el1) nil)
 117                 t)
 118                (t changed)))
 119       (let ((num2 (sset-element-number (car el2))))
 120         (loop
 121           (when (null el1)
 122             (return-from sset-intersection changed))
 123           (let ((num1 (sset-element-number (car el1))))
 124             (when (>= num1 num2)
 125               (when (= num1 num2)
 126                 (shiftf prev-el1 el1 (cdr el1)))
 127               (return))
 128             (pop el1)
 129             (setf (cdr prev-el1) el1)
 130             (setq changed t)))))))
 131 (defun sset-difference (set1 set2)
 132   (let* ((prev-el1 (sset-elements set1))
 133          (el1 (cdr prev-el1))
 134          (changed nil))
 135     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
 136         ((null el2) changed)
 137       (let ((num2 (sset-element-number (car el2))))
 138         (loop
 139           (when (null el1)
 140             (return-from sset-difference changed))
 141           (let ((num1 (sset-element-number (car el1))))
 142             (when (>= num1 num2)
 143               (when (= num1 num2)
 144                 (pop el1)
 145                 (setf (cdr prev-el1) el1)
 146                 (setq changed t))
 147               (return))
 148             (shiftf prev-el1 el1 (cdr el1))))))))
 149
 150 ;;; Destructively modify Set1 to include its union with the difference
 151 ;;; of Set2 and Set3. We return true if Set1 was modified, false
 152 ;;; otherwise.
 153 (declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference))
 154 (defun sset-union-of-difference (set1 set2 set3)
 155   (let* ((prev-el1 (sset-elements set1))
 156          (el1 (cdr prev-el1))
 157          (el3 (cdr (sset-elements set3)))
 158          (changed nil))
 159     (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
 160         ((null el2) changed)
 161       (let* ((e (car el2))
 162              (num2 (sset-element-number e)))
 163         (loop
 164           (when (null el3)
 165             (loop
 166               (when (null el1)
 167                 (setf (cdr prev-el1) (copy-list el2))
 168                 (return-from sset-union-of-difference t))
 169               (let ((num1 (sset-element-number (car el1))))
 170                 (when (>= num1 num2)
 171                   (if (> num1 num2)
 172                       (let ((new (cons e el1)))
 173                         (setf (cdr prev-el1) new)
 174                         (setq prev-el1 new  changed t))
 175                       (shiftf prev-el1 el1 (cdr el1)))
 176                   (return))
 177                 (shiftf prev-el1 el1 (cdr el1))))
 178             (return))
 179           (let ((num3 (sset-element-number (car el3))))
 180             (when (<= num2 num3)
 181               (unless (= num2 num3)
 182                 (loop
 183                   (when (null el1)
 184                     (do ((el2 el2 (cdr el2)))
 185                         ((null el2)
 186                          (return-from sset-union-of-difference changed))
 187                       (let* ((e (car el2))
 188                              (num2 (sset-element-number e)))
 189                         (loop
 190                           (when (null el3)
 191                             (setf (cdr prev-el1) (copy-list el2))
 192                             (return-from sset-union-of-difference t))
 193                           (setq num3 (sset-element-number (car el3)))
 194                           (when (<= num2 num3)
 195                             (unless (= num2 num3)
 196                               (let ((new (cons e el1)))
 197                                 (setf (cdr prev-el1) new)
 198                                 (setq prev-el1 new  changed t)))
 199                             (return))
 200                           (pop el3)))))
 201                   (let ((num1 (sset-element-number (car el1))))
 202                     (when (>= num1 num2)
 203                       (if (> num1 num2)
 204                           (let ((new (cons e el1)))
 205                             (setf (cdr prev-el1) new)
 206                             (setq prev-el1 new  changed t))
 207                           (shiftf prev-el1 el1 (cdr el1)))
 208                       (return))
 209                     (shiftf prev-el1 el1 (cdr el1)))))
 210               (return)))
 211           (pop el3))))))