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