/[cmucl]/src/compiler/sset.lisp
ViewVC logotype

Contents of /src/compiler/sset.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Fri Mar 19 15:19:01 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.7: +2 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/sset.lisp,v 1.8 2010/03/19 15:19:01 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; A sparse set abstraction, implemented as a sorted linked list. We don't
13 ;;; use bit-vectors to represent sets in flow analysis, since the universe may
14 ;;; be quite large but the average number of elements is small. We keep the
15 ;;; list sorted so that we can do union and intersection in linear time.
16 ;;;
17 ;;; Written by Rob MacLachlan
18 ;;;
19 (in-package "C")
20 (intl:textdomain "cmucl")
21
22 ;;;
23 ;;; Each structure that may be placed in a SSet must include the SSet-Element
24 ;;; structure. We allow an initial value of NIL to mean that no ordering has
25 ;;; been assigned yet (although an ordering must be assigned before doing set
26 ;;; operations.)
27 ;;;
28 (defstruct sset-element
29 (number nil :type (or index null)))
30
31
32 (defstruct (sset (:constructor make-sset ())
33 (:copier nil)
34 (:print-function %print-sset))
35 (elements (list nil) :type list))
36
37
38 (defprinter sset
39 (elements :prin1 (cdr elements)))
40
41
42 ;;; Do-Elements -- Interface
43 ;;;
44 ;;; Iterate over the elements in Set, binding Var to each element in turn.
45 ;;;
46 (defmacro do-elements ((var set &optional result) &body body)
47 `(dolist (,var (cdr (sset-elements ,set)) ,result) ,@body))
48
49
50 ;;; SSet-Adjoin -- Interface
51 ;;;
52 ;;; Destructively add Element to Set. If Element was not in the set, then
53 ;;; we return true, otherwise we return false.
54 ;;;
55 (defun sset-adjoin (element set)
56 (declare (type sset-element element) (type sset set) (values boolean))
57 (let ((number (sset-element-number element))
58 (elements (sset-elements set)))
59 (do ((prev elements current)
60 (current (cdr elements) (cdr current)))
61 ((null current)
62 (setf (cdr prev) (list element))
63 t)
64 (let ((el (car current)))
65 (when (>= (sset-element-number el) number)
66 (when (eq el element)
67 (return nil))
68 (setf (cdr prev) (cons element current))
69 (return t))))))
70
71
72 ;;; SSet-Delete -- Interface
73 ;;;
74 ;;; Destructively remove Element from Set. If element was in the set,
75 ;;; then return true, otherwise return false.
76 ;;;
77 (defun sset-delete (element set)
78 (declare (type sset-element element) (type sset set) (values boolean))
79 (let ((elements (sset-elements set)))
80 (do ((prev elements current)
81 (current (cdr elements) (cdr current)))
82 ((null current) nil)
83 (when (eq (car current) element)
84 (setf (cdr prev) (cdr current))
85 (return t)))))
86
87
88 ;;; SSet-Member -- Interface
89 ;;;
90 ;;; Return true if Element is in Set, false otherwise.
91 ;;;
92 (defun sset-member (element set)
93 (declare (type sset-element element) (type sset set) (values boolean)
94 (inline member))
95 (not (null (member element (cdr (sset-elements set)) :test #'eq))))
96
97
98 ;;; SSet-Empty -- Interface
99 ;;;
100 ;;; Return true if Set contains no elements, false otherwise.
101 ;;;
102 (defun sset-empty (set)
103 (declare (type sset set) (values boolean))
104 (null (cdr (sset-elements set))))
105
106
107 ;;; SSet-Singleton -- Interface
108 ;;;
109 ;;; If Set contains exactly one element, then return it, otherwise return
110 ;;; NIL.
111 ;;;
112 (defun sset-singleton (set)
113 (declare (type sset set) (values (or sset-element null)))
114 (let ((elements (cdr (sset-elements set))))
115 (if (and elements (not (cdr elements)))
116 (car elements)
117 nil)))
118
119
120 ;;; SSet-Subsetp -- Interface
121 ;;;
122 ;;; If Set1 is a (not necessarily proper) subset of Set2, then return true,
123 ;;; otherwise return false.
124 ;;;
125 (defun sset-subsetp (set1 set2)
126 (declare (type sset set1 set2) (values boolean))
127 (let ((el2 (cdr (sset-elements set2))))
128 (do ((el1 (cdr (sset-elements set1)) (cdr el1)))
129 ((null el1) t)
130 (let ((num1 (sset-element-number (car el1))))
131 (loop
132 (when (null el2) (return-from sset-subsetp nil))
133 (let ((num2 (sset-element-number (pop el2))))
134 (when (>= num2 num1)
135 (when (> num2 num1) (return-from sset-subsetp nil))
136 (return))))))))
137
138
139 ;;; SSet-Equal -- Interface
140 ;;;
141 ;;; Return true if Set1 and Set2 contain the same elements, false otherwise.
142 ;;;
143 (defun sset-equal (set1 set2)
144 (declare (type sset set1 set2) (values boolean))
145 (do ((el1 (cdr (sset-elements set1)) (cdr el1))
146 (el2 (cdr (sset-elements set2)) (cdr el2)))
147 (())
148 (when (null el1) (return (null el2)))
149 (when (null el2) (return nil))
150 (unless (eq (car el1) (car el2)) (return nil))))
151
152
153 ;;; Copy-SSet -- Interface
154 ;;;
155 ;;; Return a new copy of Set.
156 ;;;
157 (defun copy-sset (set)
158 (declare (type sset set) (values sset))
159 (let ((res (make-sset)))
160 (setf (sset-elements res) (copy-list (sset-elements set)))
161 res))
162
163
164 ;;; SSet-Union, SSet-Intersection, SSet-Difference -- Interface
165 ;;;
166 ;;; Perform the appropriate set operation on Set1 and Set2 by destructively
167 ;;; modifying Set1. We return true if Set1 was modified, false otherwise.
168 ;;;
169 (defun sset-union (set1 set2)
170 (declare (type sset set1 set2) (values boolean))
171 (let* ((prev-el1 (sset-elements set1))
172 (el1 (cdr prev-el1))
173 (changed nil))
174 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
175 ((null el2) changed)
176 (let* ((e (car el2))
177 (num2 (sset-element-number e)))
178 (loop
179 (when (null el1)
180 (setf (cdr prev-el1) (copy-list el2))
181 (return-from sset-union t))
182 (let ((num1 (sset-element-number (car el1))))
183 (when (>= num1 num2)
184 (if (> num1 num2)
185 (let ((new (cons e el1)))
186 (setf (cdr prev-el1) new)
187 (setq prev-el1 new changed t))
188 (shiftf prev-el1 el1 (cdr el1)))
189 (return))
190 (shiftf prev-el1 el1 (cdr el1))))))))
191 ;;;
192 (defun sset-intersection (set1 set2)
193 (declare (type sset set1 set2) (values boolean))
194 (let* ((prev-el1 (sset-elements set1))
195 (el1 (cdr prev-el1))
196 (changed nil))
197 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
198 ((null el2)
199 (cond (el1
200 (setf (cdr prev-el1) nil)
201 t)
202 (t changed)))
203 (let ((num2 (sset-element-number (car el2))))
204 (loop
205 (when (null el1)
206 (return-from sset-intersection changed))
207 (let ((num1 (sset-element-number (car el1))))
208 (when (>= num1 num2)
209 (when (= num1 num2)
210 (shiftf prev-el1 el1 (cdr el1)))
211 (return))
212 (pop el1)
213 (setf (cdr prev-el1) el1)
214 (setq changed t)))))))
215 ;;;
216 (defun sset-difference (set1 set2)
217 (declare (type sset set1 set2) (values boolean))
218 (let* ((prev-el1 (sset-elements set1))
219 (el1 (cdr prev-el1))
220 (changed nil))
221 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
222 ((null el2) changed)
223 (let ((num2 (sset-element-number (car el2))))
224 (loop
225 (when (null el1)
226 (return-from sset-difference changed))
227 (let ((num1 (sset-element-number (car el1))))
228 (when (>= num1 num2)
229 (when (= num1 num2)
230 (pop el1)
231 (setf (cdr prev-el1) el1)
232 (setq changed t))
233 (return))
234 (shiftf prev-el1 el1 (cdr el1))))))))
235
236
237 ;;; SSet-Union-Of-Difference -- Interface
238 ;;;
239 ;;; Destructively modify Set1 to include its union with the difference of
240 ;;; Set2 and Set3. We return true if Set1 was modified, false otherwise.
241 ;;;
242 (defun sset-union-of-difference (set1 set2 set3)
243 (declare (type sset set1 set2 set3) (values boolean))
244 (let* ((prev-el1 (sset-elements set1))
245 (el1 (cdr prev-el1))
246 (el3 (cdr (sset-elements set3)))
247 (changed nil))
248 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
249 ((null el2) changed)
250 (let* ((e (car el2))
251 (num2 (sset-element-number e)))
252 (loop
253 (when (null el3)
254 (loop
255 (when (null el1)
256 (setf (cdr prev-el1) (copy-list el2))
257 (return-from sset-union-of-difference t))
258 (let ((num1 (sset-element-number (car el1))))
259 (when (>= num1 num2)
260 (if (> num1 num2)
261 (let ((new (cons e el1)))
262 (setf (cdr prev-el1) new)
263 (setq prev-el1 new changed t))
264 (shiftf prev-el1 el1 (cdr el1)))
265 (return))
266 (shiftf prev-el1 el1 (cdr el1))))
267 (return))
268 (let ((num3 (sset-element-number (car el3))))
269 (when (<= num2 num3)
270 (unless (= num2 num3)
271 (loop
272 (when (null el1)
273 (do ((el2 el2 (cdr el2)))
274 ((null el2)
275 (return-from sset-union-of-difference changed))
276 (let* ((e (car el2))
277 (num2 (sset-element-number e)))
278 (loop
279 (when (null el3)
280 (setf (cdr prev-el1) (copy-list el2))
281 (return-from sset-union-of-difference t))
282 (setq num3 (sset-element-number (car el3)))
283 (when (<= num2 num3)
284 (unless (= num2 num3)
285 (let ((new (cons e el1)))
286 (setf (cdr prev-el1) new)
287 (setq prev-el1 new changed t)))
288 (return))
289 (pop el3)))))
290 (let ((num1 (sset-element-number (car el1))))
291 (when (>= num1 num2)
292 (if (> num1 num2)
293 (let ((new (cons e el1)))
294 (setf (cdr prev-el1) new)
295 (setq prev-el1 new changed t))
296 (shiftf prev-el1 el1 (cdr el1)))
297 (return))
298 (shiftf prev-el1 el1 (cdr el1)))))
299 (return)))
300 (pop el3))))))

  ViewVC Help
Powered by ViewVC 1.1.5