From 8bb34dad31b73a7bd4ca17b1630f4f5bdc94f347 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 27 Aug 2007 14:44:21 +0000 Subject: [PATCH] 1.0.9.1: faster MAKE-MEMBER-TYPE, UNION, and NUNION * MAKE-MEMBER-TYPE was doing several SUBSETP calls, instead just walk once over the list of members. * UNION and NUNION were using an O(N^2) implementation for all input sizes. Use a hashtable (giving O(N)) for large inputs when :TEST is something we can use with a hash-table. Thanks to Damien Diederen for catching a typo in the new UNION / NUNION code. --- NEWS | 7 ++++ src/code/early-type.lisp | 75 ++++++++++++++++++++++++++------------ src/code/list.lisp | 91 ++++++++++++++++++++++++++++++++++++---------- version.lisp-expr | 2 +- 4 files changed, 131 insertions(+), 44 deletions(-) diff --git a/NEWS b/NEWS index 08610cb..fc41d57 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,11 @@ ;;;; -*- 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, diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 6bc004e..92ada6e 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -398,35 +398,62 @@ (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. diff --git a/src/code/list.lisp b/src/code/list.lisp index a48af26..5f96806 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -780,22 +780,46 @@ 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. @@ -813,15 +837,44 @@ (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)) diff --git a/version.lisp-expr b/version.lisp-expr index 7bb9674..d931dd8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4