[Sbcl-commits] CVS: sbcl/src/code xset.lisp, NONE, 1.1 cross-type.lisp, 1.31, 1.32 early-extensions.lisp, 1.91, 1.92 early-type.lisp, 1.52, 1.53 late-type.lisp, 1.137, 1.138 typep.lisp, 1.22, 1.23

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3470/src/code

Modified Files:
	cross-type.lisp early-extensions.lisp early-type.lisp 
	late-type.lisp typep.lisp 
Added Files:
	xset.lisp 
Log Message:
1.0.12.18: faster member-type operations

* XSET is a generic set implementation, that uses lists of small sets,
  and switches to hashes for larger ones. Current switchoff point is
  12 -- but some operations would benefit from a larger one. TODO:
  There are other places in SBCL that will probably want to use XSET
  as well.

* Instead of storing members directly in the set object, store them in
  an XSET -- except for floating point zeros which go into a list of
  their own, simplifying the canonicalization a bit. (By adding
  complexity elsewhere, of course. Maybe this is not TRT after all...)

* ...now member type arithmetic is mostly O(1) or O(N), instead of
  O(BAD), but some operations cons more then before: old implemenation
  manageg eg. union without consing when either set was the subset of
  the other one -- not so anymore.


--- NEW FILE: xset.lisp ---
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

;;;; XSET
;;;;
;;;; A somewhat effcient set implementation that can store arbitrary
;;;; objects. For small sets the data is stored in a list, but when
;;;; the amount of elements grows beyond +XSET-LIST-SIZE-LIMIT+, we
;;;; switch to a hash-table instead.
;;;;
;;;; ALLOC-XSET allocates an empty XSET. ADD-TO-XSET adds an element
;;;; to an XSET: it should be used only on freshly allocated XSETs.
;;;;
;;;; XSET-EMPTY-P, XSET-INTERSECTION, XSET-SUBSET-P, and XSET-MEMBER-P
;;;; do the obvious things. MAP-XSET maps over the element, but
;;;; requires a function as the first argument -- not a function
;;;; designator.
;;;;
;;;; XSET-LIST-SIZE is true only for XSETs whose data is stored into a
;;;; list -- XSET-COUNT returns the real value.

(in-package "SB!KERNEL")

#!-sb-fluid
(declaim (inline alloc-xset xset-data (setf xset-data) xset-list-size (setf xset-list-size)))
(defstruct (xset (:constructor alloc-xset) (:copier nil) (:predicate nil))
  (list-size 0 :type index)
  (data nil :type (or list hash-table)))

(defun xset-count (xset)
  (let ((data (xset-data xset)))
    (if (listp data)
        (xset-list-size xset)
        (hash-table-count data))))

(defun map-xset (function xset)
  (declare (function function))
  (let ((data (xset-data xset)))
    (if (listp data)
        (dolist (elt data)
          (funcall function elt))
        (maphash (lambda (k v)
                   (declare (ignore v))
                   (funcall function k))
                 data)))
  nil)

(defconstant +xset-list-size-limit+ 12)

;;; Checks that the element is not in the set yet.
(defun add-to-xset (elt xset)
  (let ((data (xset-data xset))
        (size (xset-list-size xset)))
    (if (listp data)
        (if (< size +xset-list-size-limit+)
            (unless (member elt data :test #'eq)
              (setf (xset-list-size xset) (1+ size)
                    (xset-data xset) (cons elt data)))
            (let ((table (make-hash-table :size (* 2 size) :test #'eq)))
              (setf (gethash elt table) t)
              (dolist (x data)
                (setf (gethash x table) t))
              (setf (xset-data xset) table)))
        (setf (gethash elt data) t))))

(defun xset-union (a b)
  (let ((xset (alloc-xset)))
    (map-xset (lambda (x)
                (add-to-xset x xset))
              a)
    (map-xset (lambda (y)
                (add-to-xset y xset))
              b)
    xset))

(defun xset-member-p (elt xset)
  (let ((data (xset-data xset)))
    (if (listp data)
        (member elt data :test #'eq)
        (gethash elt data))))

(defun xset-members (xset)
  (let ((data (xset-data xset)))
    (if (listp data)
        data
        (let (members)
          (maphash (lambda (k v)
                     (declare (ignore v))
                     (push k members))
                   data)
          members))))

(defun xset-intersection (a b)
  (let ((intersection (alloc-xset)))
    (multiple-value-bind (source lookup)
        (if (< (xset-list-size a) (xset-list-size b))
            (values b a)
            (values a b))
      (let ((data (xset-data lookup)))
        (map-xset (if (listp data)
                      (lambda (elt)
                        (when (member elt data :test #'eq)
                          (add-to-xset elt intersection)))
                      (lambda (elt)
                        (when (gethash elt data)
                          (add-to-xset elt intersection))))
                 source)))
    intersection))

(defun xset-subset-p (xset1 xset2)
  (when (<= (xset-count xset1) (xset-count xset2))
    (let ((data (xset-data xset2)))
      (map-xset
       (if (listp data)
           (lambda (elt)
             (unless (member elt data :test #'eq)
               (return-from xset-subset-p nil)))
           (lambda (elt)
             (unless (gethash elt data)
               (return-from xset-subset-p nil))))
       xset1))
    t))

#!-sb-fluid (declaim (inline xset-empty-p))
(defun xset-empty-p (xset)
  (not (xset-data xset)))

Index: cross-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cross-type.lisp,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- cross-type.lisp	5 Dec 2006 17:50:20 -0000	1.31
+++ cross-type.lisp	9 Dec 2007 14:37:23 -0000	1.32
@@ -356,7 +356,7 @@
   ;; call TYPE=, that in turn may call CTYPEP). Until then, pick a few
   ;; cherries off.
   (cond ((member-type-p ctype)
-         (if (member obj (member-type-members ctype))
+         (if (member-type-member-p obj ctype)
              (values t t)
              (values nil t)))
         ((union-type-p ctype)

Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.91
retrieving revision 1.92
diff -u -d -r1.91 -r1.92
--- early-extensions.lisp	12 Nov 2007 17:14:51 -0000	1.91
+++ early-extensions.lisp	9 Dec 2007 14:37:23 -0000	1.92
@@ -1264,3 +1264,28 @@
                                           bindings)))
        ,@forms)))
 
+(in-package "SB!KERNEL")
+
+(defun fp-zero-p (x)
+  (typecase x
+    (single-float (zerop x))
+    (double-float (zerop x))
+    #!+long-float
+    (long-float (zerop x))
+    (t nil)))
+
+(defun neg-fp-zero (x)
+  (etypecase x
+    (single-float
+     (if (eql x 0.0f0)
+         (make-unportable-float :single-float-negative-zero)
+         0.0f0))
+    (double-float
+     (if (eql x 0.0d0)
+         (make-unportable-float :double-float-negative-zero)
+         0.0d0))
+    #!+long-float
+    (long-float
+     (if (eql x 0.0l0)
+         (make-unportable-float :long-float-negative-zero)
+         0.0l0))))

Index: early-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-type.lisp,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -d -r1.52 -r1.53
--- early-type.lisp	27 Sep 2007 15:56:07 -0000	1.52
+++ early-type.lisp	9 Dec 2007 14:37:23 -0000	1.53
@@ -392,68 +392,78 @@
                                   (class-info (type-class-or-lose 'member))
                                   (enumerable t))
                         (:copier nil)
-                        (:constructor %make-member-type (members))
+                        (:constructor %make-member-type (xset fp-zeroes))
                         #-sb-xc-host (:pure nil))
-  ;; the things in the set, with no duplications
-  (members nil :type list))
-(defun make-member-type (&key members)
-  (declare (type list members))
+  (xset (missing-arg) :type xset)
+  (fp-zeroes (missing-arg) :type list))
+(defun make-member-type (&key xset fp-zeroes members)
+  (unless xset
+    (aver (not fp-zeroes))
+    (setf xset (alloc-xset))
+    (dolist (elt members)
+      (if (fp-zero-p elt)
+          (pushnew elt fp-zeroes)
+          (add-to-xset elt xset))))
   ;; 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 ((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
-        (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.0l0 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))))))
+  (let ((unpaired nil)
+        (union-types nil))
+    (do ((tail (cdr fp-zeroes) (cdr tail))
+         (zero (car fp-zeroes) (car tail)))
+        ((not zero))
+      (macrolet ((frob (c)
+                   `(let ((neg (neg-fp-zero zero)))
+                      (if (member neg tail)
+                          (push (ctype-of ,c) union-types)
+                          (push zero unpaired)))))
+        (etypecase zero
+          (single-float (frob 0.0f0))
+          (double-float (frob 0.0d0))
+          #!+long-float
+          (long-float (frob 0.0l0)))))
+    ;; The actual member-type contains the XSET (with no FP zeroes),
+    ;; and a list of unpaired zeroes.
+    (let ((member-type (unless (and (xset-empty-p xset) (not unpaired))
+                         (%make-member-type xset unpaired))))
+      (cond (union-types
+             (make-union-type t (if member-type
+                                    (cons member-type union-types)
+                                    union-types)))
+            (member-type
+             member-type)
+            (t
+             *empty-type*)))))
+
+(defun member-type-size (type)
+  (+ (length (member-type-fp-zeroes type))
+     (xset-count (member-type-xset type))))
+
+(defun member-type-member-p (x type)
+  (if (fp-zero-p x)
+      (and (member x (member-type-fp-zeroes type)) t)
+      (xset-member-p x (member-type-xset type))))
+
+(defun mapcar-member-type-members (function type)
+  (declare (function function))
+  (collect ((results))
+    (map-xset (lambda (x)
+                (results (funcall function x)))
+              (member-type-xset type))
+    (dolist (zero (member-type-fp-zeroes type))
+      (results (funcall function zero)))
+    (results)))
+
+(defun mapc-member-type-members (function type)
+  (declare (function function))
+  (map-xset function (member-type-xset type))
+  (dolist (zero (member-type-fp-zeroes type))
+    (funcall function zero)))
+
+(defun member-type-members (type)
+  (append (member-type-fp-zeroes type)
+          (xset-members (member-type-xset type))))
 
 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.

Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.137
retrieving revision 1.138
diff -u -d -r1.137 -r1.138
--- late-type.lisp	28 Feb 2007 16:06:00 -0000	1.137
+++ late-type.lisp	9 Dec 2007 14:37:23 -0000	1.138
@@ -1882,8 +1882,9 @@
                            (mapcar #'do-complex (union-type-types ctype))))
                    ((typep ctype 'member-type)
                     (apply #'type-union
-                           (mapcar (lambda (x) (do-complex (ctype-of x)))
-                                   (member-type-members ctype))))
+                           (mapcar-member-type-members
+                            (lambda (x) (do-complex (ctype-of x)))
+                            ctype)))
                    ((and (typep ctype 'intersection-type)
                          ;; FIXME: This is very much a
                          ;; not-quite-worst-effort, but we are required to do
@@ -2528,39 +2529,28 @@
 (!define-type-class member)
 
 (!define-type-method (member :negate) (type)
-  (let ((members (member-type-members type)))
-    (if (some #'floatp members)
-        (let (floats)
-          (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
-                          (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
-                          #!+long-float
-                          (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))
-            (when (member (car pair) members)
-              (aver (not (member (cdr pair) members)))
-              (push (cdr pair) floats)
-              (setf members (remove (car pair) members)))
-            (when (member (cdr pair) members)
-              (aver (not (member (car pair) members)))
-              (push (car pair) floats)
-              (setf members (remove (cdr pair) members))))
-          (apply #'type-intersection
-                 (if (null members)
-                     *universal-type*
+  (let ((xset (member-type-xset type))
+        (fp-zeroes (member-type-fp-zeroes type)))
+    (if fp-zeroes
+        ;; Hairy case, which needs to do a bit of float type
+        ;; canonicalization.
+        (apply #'type-intersection
+               (if (xset-empty-p xset)
+                   *universal-type*
+                   (make-negation-type
+                    :type (make-member-type :xset xset)))
+               (mapcar
+                (lambda (x)
+                  (let* ((opposite (neg-fp-zero x))
+                         (type (ctype-of opposite)))
+                    (type-union
                      (make-negation-type
-                      :type (make-member-type :members members)))
-                 (mapcar
-                  (lambda (x)
-                    (let ((type (ctype-of x)))
-                      (type-union
-                       (make-negation-type
-                        :type (modified-numeric-type type
-                                                     :low nil :high nil))
-                       (modified-numeric-type type
-                                              :low nil :high (list x))
-                       (make-member-type :members (list x))
-                       (modified-numeric-type type
-                                              :low (list x) :high nil))))
-                  floats)))
+                      :type (modified-numeric-type type :low nil :high nil))
+                     (modified-numeric-type type :low nil :high (list opposite))
+                     (make-member-type :members (list opposite))
+                     (modified-numeric-type type :low (list opposite) :high nil))))
+                fp-zeroes))
+        ;; Easy case
         (make-negation-type :type type))))
 
 (!define-type-method (member :unparse) (type)
@@ -2571,13 +2561,23 @@
       (t `(member ,@members)))))
 
 (!define-type-method (member :simple-subtypep) (type1 type2)
-  (values (subsetp (member-type-members type1) (member-type-members type2))
-          t))
+   (values (and (xset-subset-p (member-type-xset type1)
+                                 (member-type-xset type2))
+                (subsetp (member-type-fp-zeroes type1)
+                         (member-type-fp-zeroes type2)))
+           t))
 
 (!define-type-method (member :complex-subtypep-arg1) (type1 type2)
-  (every/type (swapped-args-fun #'ctypep)
-              type2
-              (member-type-members type1)))
+  (block punt
+    (mapc-member-type-members
+     (lambda (elt)
+       (multiple-value-bind (ok surep) (ctypep elt type2)
+         (unless surep
+           (return-from punt (values nil nil)))
+         (unless ok
+           (return-from punt (values nil t)))))
+     type1)
+    (values t t)))
 
 ;;; We punt if the odd type is enumerable and intersects with the
 ;;; MEMBER type. If not enumerable, then it is definitely not a
@@ -2589,46 +2589,48 @@
         (t (values nil t))))
 
 (!define-type-method (member :simple-intersection2) (type1 type2)
-  (let ((mem1 (member-type-members type1))
-        (mem2 (member-type-members type2)))
-    (cond ((subsetp mem1 mem2) type1)
-          ((subsetp mem2 mem1) type2)
-          (t
-           (let ((res (intersection mem1 mem2)))
-             (if res
-                 (make-member-type :members res)
-                 *empty-type*))))))
+  (make-member-type :xset (xset-intersection (member-type-xset type1)
+                                             (member-type-xset type2))
+                    :fp-zeroes (intersection (member-type-fp-zeroes type1)
+                                             (member-type-fp-zeroes type2))))
 
 (!define-type-method (member :complex-intersection2) (type1 type2)
   (block punt
-    (collect ((members))
-      (let ((mem2 (member-type-members type2)))
-        (dolist (member mem2)
-          (multiple-value-bind (val win) (ctypep member type1)
-            (unless win
-              (return-from punt nil))
-            (when val (members member))))
-        (cond ((subsetp mem2 (members)) type2)
-              ((null (members)) *empty-type*)
-              (t
-               (make-member-type :members (members))))))))
+    (let ((xset (alloc-xset))
+          (fp-zeroes nil))
+      (mapc-member-type-members
+       (lambda (member)
+         (multiple-value-bind (ok sure) (ctypep member type1)
+           (unless sure
+             (return-from punt nil))
+           (when ok
+             (if (fp-zero-p member)
+                 (pushnew member fp-zeroes)
+                 (add-to-xset member xset)))))
+       type2)
+      (if (and (xset-empty-p xset) (not fp-zeroes))
+          *empty-type*
+          (make-member-type :xset xset :fp-zeroes fp-zeroes)))))
 
 ;;; We don't need a :COMPLEX-UNION2, since the only interesting case is
 ;;; a union type, and the member/union interaction is handled by the
 ;;; union type method.
 (!define-type-method (member :simple-union2) (type1 type2)
-  (let ((mem1 (member-type-members type1))
-        (mem2 (member-type-members type2)))
-    (cond ((subsetp mem1 mem2) type2)
-          ((subsetp mem2 mem1) type1)
-          (t
-           (make-member-type :members (union mem1 mem2))))))
+  (make-member-type :xset (xset-union (member-type-xset type1)
+                                      (member-type-xset type2))
+                    :fp-zeroes (union (member-type-fp-zeroes type1)
+                                      (member-type-fp-zeroes type2))))
 
 (!define-type-method (member :simple-=) (type1 type2)
-  (let ((mem1 (member-type-members type1))
-        (mem2 (member-type-members type2)))
-    (values (and (subsetp mem1 mem2)
-                 (subsetp mem2 mem1))
+  (let ((xset1 (member-type-xset type1))
+        (xset2 (member-type-xset type2))
+        (l1 (member-type-fp-zeroes type1))
+        (l2 (member-type-fp-zeroes type2)))
+    (values (and (eql (xset-count xset1) (xset-count xset2))
+                 (xset-subset-p xset1 xset2)
+                 (xset-subset-p xset2 xset1)
+                 (subsetp l1 l2)
+                 (subsetp l2 l1))
             t)))
 
 (!define-type-method (member :complex-=) (type1 type2)
@@ -3281,14 +3283,20 @@
     (collect ((res))
       (dolist (x-type x-types)
         (if (member-type-p x-type)
-            (collect ((members))
-              (dolist (mem (member-type-members x-type))
-                (multiple-value-bind (val win) (ctypep mem y)
-                  (unless win (return-from type-difference nil))
-                  (unless val
-                    (members mem))))
-              (when (members)
-                (res (make-member-type :members (members)))))
+            (let ((xset (alloc-xset))
+                  (fp-zeroes nil))
+              (mapc-member-type-members
+               (lambda (elt)
+                 (multiple-value-bind (ok sure) (ctypep elt y)
+                   (unless sure
+                     (return-from type-difference nil))
+                   (unless ok
+                     (if (fp-zero-p elt)
+                         (pushnew elt fp-zeroes)
+                         (add-to-xset elt xset)))))
+               x-type)
+              (unless (and (xset-empty-p xset) (not fp-zeroes))
+                (res (make-member-type :xset xset :fp-zeroes fp-zeroes))))
             (dolist (y-type y-types (res x-type))
               (multiple-value-bind (val win) (csubtypep x-type y-type)
                 (unless win (return-from type-difference nil))
@@ -3297,13 +3305,14 @@
                   (return-from type-difference nil))))))
       (let ((y-mem (find-if #'member-type-p y-types)))
         (when y-mem
-          (let ((members (member-type-members y-mem)))
-            (dolist (x-type x-types)
-              (unless (member-type-p x-type)
-                (dolist (member members)
-                  (multiple-value-bind (val win) (ctypep member x-type)
-                    (when (or (not win) val)
-                      (return-from type-difference nil)))))))))
+          (dolist (x-type x-types)
+            (unless (member-type-p x-type)
+              (mapc-member-type-members
+               (lambda (member)
+                 (multiple-value-bind (ok sure) (ctypep member x-type)
+                   (when (or (not sure) ok)
+                     (return-from type-difference nil))))
+               y-mem)))))
       (apply #'type-union (res)))))
 
 (!def-type-translator array (&optional (element-type '*)

Index: typep.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/typep.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- typep.lisp	28 Feb 2007 16:06:01 -0000	1.22
+++ typep.lisp	9 Dec 2007 14:37:23 -0000	1.23
@@ -105,7 +105,8 @@
                              (specifier-type (array-element-type
                                               object)))))))
     (member-type
-     (if (member object (member-type-members type)) t))
+     (when (member-type-member-p object type)
+       t))
     (classoid
      #+sb-xc-host (ctypep object type)
      #-sb-xc-host (classoid-typep (layout-of object) type object))