0.9.10.44:
[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 ;;; 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 (def!struct (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 (sfunction (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 (sfunction (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 (sfunction (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 (sfunction (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 (sfunction (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 (sfunction (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 (sfunction (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 (sfunction (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))))))