;;;; -*- coding: utf-8; -*-
+changes in sbcl-1.0.10 relative to sbcl-1.0.9:
+ * optimization: member type construction is now O(N) instead
+ of O(N^2).
+ * optimization: UNION and NUNION are now O(N+M) for large
+ inputs as long as the :TEST function is one of EQ, EQL, EQUAL, or
+ EQUALP.
+
changes in sbcl-1.0.9 relative to sbcl-1.0.8:
* minor incompatible change: SB-SYS:OUTPUT-RAW-BYTES is deprecated.
* enhancement: SB-EXT:FINALIZE accepts a :DONT-SAVE keyword argument,
(members nil :type list))
(defun make-member-type (&key members)
(declare (type list members))
- ;; make sure that we've removed duplicates
- (aver (= (length members) (length (remove-duplicates members))))
;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
;; ranges are compared by arithmetic operators (while MEMBERship is
;; compared by EQL). -- CSR, 2003-04-23
- (let ((singlep (subsetp `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
- (doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))
+ (let ((n-single (load-time-value
+ (make-unportable-float :single-float-negative-zero)))
+ (n-double (load-time-value
+ (make-unportable-float :double-float-negative-zero)))
#!+long-float
- (longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)))
- (if (or singlep doublep #!+long-float longp)
- (let (union-types)
- (when singlep
- (push (ctype-of 0.0f0) union-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))
- (when doublep
- (push (ctype-of 0.0d0) union-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))
- #!+long-float
- (when longp
- (push (ctype-of 0.0l0) union-types)
- (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))
- (aver (not (null union-types)))
- (make-union-type t
- (if (null members)
- union-types
- (cons (%make-member-type members)
- union-types))))
- (%make-member-type members))))
+ (n-long (load-time-value
+ (make-unportable-float :long-float-negative-zero)))
+ (singles nil)
+ (doubles nil)
+ #!+long-float
+ (longs nil))
+ ;; Just a single traversal, please! MEMBERS2 starts as with MEMBERS,
+ ;; sans any zeroes -- if there are any paired zeroes then the
+ ;; unpaired ones are added back to it.
+ (let (members2)
+ (dolist (elt members)
+ (if (and (numberp elt) (zerop elt))
+ (typecase elt
+ (single-float (push elt singles))
+ (double-float (push elt doubles))
+ #!+long-float
+ (long-float (push elt longs)))
+ (push elt members2)))
+ (let ((singlep (and (member 0.0f0 singles)
+ (member n-single singles)
+ (or (aver (= 2 (length singles))) t)))
+ (doublep (and (member 0.0d0 doubles)
+ (member n-double doubles)
+ (or (aver (= 2 (length doubles))) t)))
+ #!+long-float
+ (longp (and (member 0.0lo longs)
+ (member n-long longs)
+ (or (aver (= 2 (lenght longs))) t))))
+ (if (or singlep doublep #!+long-float longp)
+ (let (union-types)
+ (if singlep
+ (push (ctype-of 0.0f0) union-types)
+ (setf members2 (nconc singles members2)))
+ (if doublep
+ (push (ctype-of 0.0d0) union-types)
+ (setf members2 (nconc doubles members2)))
+ #!+long-float
+ (if longp
+ (push (ctype-of 0.0l0) union-types)
+ (setf members2 (nconc longs members2)))
+ (aver (not (null union-types)))
+ (make-union-type t
+ (if (null members2)
+ union-types
+ (cons (%make-member-type members2)
+ union-types))))
+ (%make-member-type members))))))
;;; A COMPOUND-TYPE is a type defined out of a set of types, the
;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
list
(cons item list))))
+(defconstant +list-based-union-limit+ 80)
+
(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
#!+sb-doc
"Return the union of LIST1 and LIST2."
(declare (inline member))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
- ;; We assumes LIST2 is the result, adding to it from LIST1 as
- ;; necessary. LIST2 must initialize the result value, so the call to
- ;; MEMBER will apply the test to the elements from LIST1 and LIST2
- ;; in the correct order.
- (let ((key (and key (%coerce-callable-to-fun key))))
- (let ((res list2))
- (dolist (elt list1)
- (unless (with-set-keys (member (apply-key key elt) list2))
- (push elt res)))
- res)))
+ ;; We have to possibilities here: for shortish lists we pick up the
+ ;; shorter one as the result, and add the other one to it. For long
+ ;; lists we use a hash-table when possible.
+ (let ((n1 (length list1))
+ (n2 (length list2))
+ (key (and key (%coerce-callable-to-fun key)))
+ (test (if notp
+ (let ((test-not-fun (%coerce-callable-to-fun test-not)))
+ (lambda (x) (not (funcall test-not-fun x))))
+ (%coerce-callable-to-fun test))))
+ (multiple-value-bind (short long n-short)
+ (if (< n1 n2)
+ (values list1 list2 n1)
+ (values list2 list1 n2))
+ (if (or (< n-short +list-based-union-limit+)
+ (not (member test (list #'eq #'eql #'equal #'equalp))))
+ (let ((orig short))
+ (dolist (elt long)
+ (unless (member (apply-key key elt) orig :key key :test test)
+ (push elt short)))
+ short)
+ (let ((table (make-hash-table :test test :size (+ n1 n2)))
+ (union nil))
+ (dolist (elt long)
+ (setf (gethash (apply-key key elt) table) elt))
+ (dolist (elt short)
+ (setf (gethash (apply-key key elt) table) elt))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (push v union))
+ table)
+ union)))))
;;; Destination and source are SETF-able and many-evaluable. Set the
;;; SOURCE to the CDR, and "cons" the 1st elt of source to DESTINATION.
(declare (inline member))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
- (let ((key (and key (%coerce-callable-to-fun key))))
- (let ((res list2)
- (list1 list1))
- (do ()
- ((endp list1))
- (if (not (with-set-keys (member (apply-key key (car list1)) list2)))
- (steve-splice list1 res)
- (setf list1 (cdr list1))))
- res)))
+ ;; We have to possibilities here: for shortish lists we pick up the
+ ;; shorter one as the result, and add the other one to it. For long
+ ;; lists we use a hash-table when possible.
+ (let ((n1 (length list1))
+ (n2 (length list2))
+ (key (and key (%coerce-callable-to-fun key)))
+ (test (if notp
+ (let ((test-not-fun (%coerce-callable-to-fun test-not)))
+ (lambda (x) (not (funcall test-not-fun x))))
+ (%coerce-callable-to-fun test))))
+ (multiple-value-bind (short long n-short)
+ (if (< n1 n2)
+ (values list1 list2 n1)
+ (values list2 list1 n2))
+ (if (or (< n-short +list-based-union-limit+)
+ (not (member test (list #'eq #'eql #'equal #'equalp))))
+ (let ((orig short))
+ (do ((elt (car long) (car long)))
+ ((endp long))
+ (if (not (member (apply-key key elt) orig :key key :test test))
+ (steve-splice long short)
+ (setf long (cdr long))))
+ short)
+ (let ((table (make-hash-table :test test :size (+ n1 n2))))
+ (dolist (elt long)
+ (setf (gethash (apply-key key elt) table) elt))
+ (dolist (elt short)
+ (setf (gethash (apply-key key elt) table) elt))
+ (let ((union long)
+ (head long))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (if head
+ (setf (car head) v
+ head (cdr head))
+ (push v union)))
+ table)
+ union))))))
(defun intersection (list1 list2
&key key (test #'eql testp) (test-not nil notp))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.9"
+"1.0.9.1"
projects / sbcl.git / commitdiff