From edf8d3701ba59bd9f0c1bd027f3179b98250cfd0 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 9 Dec 2007 14:37:22 +0000 Subject: [PATCH] 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. --- build-order.lisp-expr | 2 +- package-data-list.lisp-expr | 23 ++++- src/code/cross-type.lisp | 2 +- src/code/early-extensions.lisp | 25 ++++++ src/code/early-type.lisp | 124 ++++++++++++++------------ src/code/late-type.lisp | 177 +++++++++++++++++++------------------ src/code/typep.lisp | 3 +- src/code/xset.lisp | 132 +++++++++++++++++++++++++++ src/compiler/checkgen.lisp | 2 +- src/compiler/generic/primtype.lisp | 28 +++--- src/compiler/ir1opt.lisp | 9 +- src/compiler/srctran.lisp | 72 ++++++++------- tests/gray-streams.impure.lisp | 6 +- version.lisp-expr | 2 +- 14 files changed, 406 insertions(+), 201 deletions(-) create mode 100644 src/code/xset.lisp diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 09b111121..e0f43e753 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -347,7 +347,7 @@ ;; for e.g. DESCRIPTOR-REG, needed by primtype.lisp ("src/compiler/target/vm") - + ("src/code/xset") ;; for e.g. SPECIFIER-TYPE, needed by primtype.lisp ("src/code/early-type") diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ace5f0be2..87a4140f1 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -789,6 +789,23 @@ possibly temporariliy, because it might be used internally." :export (;; lambda list keyword extensions "&MORE" + ;; utilities for floating point zero handling + "FP-ZERO-P" + "NEG-FP-ZERO" + + ;; generic set implementation + "ADD-TO-XSET" + "ALLOC-XSET" + "MAP-XSET" + "XSET" + "XSET-COUNT" + "XSET-EMPTY-P" + "XSET-INTERSECTION" + "XSET-MEMBER-P" + "XSET-MEMBERS" + "XSET-SUBSET-P" + "XSET-UNION" + ;; communication between the runtime and Lisp "*CORE-STRING*" @@ -1355,8 +1372,10 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY" "MAKE-UNPORTABLE-FLOAT" "%MAKE-INSTANCE" "MAKE-SHORT-VALUES-TYPE" "MAKE-SINGLE-VALUE-TYPE" - "MAKE-VALUE-CELL" "MAKE-VALUES-TYPE" "MEMBER-TYPE" - "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" "MERGE-BITS" + "MAKE-VALUE-CELL" "MAKE-VALUES-TYPE" + "MAPC-MEMBER-TYPE-MEMBERS" "MAPCAR-MEMBER-TYPE-MEMBERS" + "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" + "MEMBER-TYPE-SIZE" "MERGE-BITS" "MODIFIED-NUMERIC-TYPE" "MUTATOR-SELF" "NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P" "NATIVE-BYTE-ORDER" "NEGATE" "NEGATION-TYPE" "NEGATION-TYPE-TYPE" diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index fee588431..730a764e0 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -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) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 9337589f4..d52a0dc0a 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1264,3 +1264,28 @@ to :INTERPRET, an interpreter will be used.") 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)))) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 0aa097449..e7b96f8d9 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -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. diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 007950a4e..e41201c92 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -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 @@ used for a COMPLEX component.~:@>" (!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 @@ used for a COMPLEX component.~:@>" (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 @@ used for a COMPLEX component.~:@>" (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 @@ used for a COMPLEX component.~:@>" (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 @@ used for a COMPLEX component.~:@>" (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 '*) diff --git a/src/code/typep.lisp b/src/code/typep.lisp index f52c5e705..bcc2934d6 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -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)) diff --git a/src/code/xset.lisp b/src/code/xset.lisp new file mode 100644 index 000000000..38a9a2b71 --- /dev/null +++ b/src/code/xset.lisp @@ -0,0 +1,132 @@ +;;;; 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))) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 6274c3053..0a932453d 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -59,7 +59,7 @@ (compound-type (reduce #'+ (compound-type-types type) :key 'type-test-cost)) (member-type - (* (length (member-type-members type)) + (* (member-type-size type) (fun-guessed-cost 'eq))) (numeric-type (* (if (numeric-type-complexp type) 2 1) diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 5bf2533b9..2ee50b094 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -126,7 +126,8 @@ (!def-vm-support-routine primitive-type-of (object) (let ((type (ctype-of object))) (cond ((not (member-type-p type)) (primitive-type type)) - ((equal (member-type-members type) '(nil)) + ((and (eql 1 (member-type-size type)) + (equal (member-type-members type) '(nil))) (primitive-type-or-lose 'list)) (t *backend-t-primitive-type*)))) @@ -341,16 +342,21 @@ ;; Punt. (t (return (any)))))))) (member-type - (let* ((members (member-type-members type)) - (res (primitive-type-of (first members)))) - (dolist (mem (rest members) (values res nil)) - (let ((ptype (primitive-type-of mem))) - (unless (eq ptype res) - (let ((new-ptype (or (maybe-numeric-type-union res ptype) - (maybe-numeric-type-union ptype res)))) - (if new-ptype - (setq res new-ptype) - (return (any))))))))) + (let (res) + (block nil + (mapc-member-type-members + (lambda (member) + (let ((ptype (primitive-type-of member))) + (if res + (unless (eq ptype res) + (let ((new-ptype (or (maybe-numeric-type-union res ptype) + (maybe-numeric-type-union ptype res)))) + (if new-ptype + (setq res new-ptype) + (return (any))))) + (setf res ptype)))) + type)) + res)) (named-type (ecase (named-type-name type) ((t *) (values *backend-t-primitive-type* t)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index c93f4b07e..d2008e78f 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -60,7 +60,7 @@ ((or (null current) (eq res *wild-type*)) res))) (t - (node-derived-type (lvar-uses lvar)))))) + (node-derived-type uses))))) ;;; Return the derived type for LVAR's first value. This is guaranteed ;;; not to be a VALUES or FUNCTION type. @@ -182,7 +182,7 @@ (lambda-var-p (ref-leaf node))) (let ((type (single-value-type int))) (when (and (member-type-p type) - (null (rest (member-type-members type)))) + (eql 1 (member-type-size type))) (change-ref-leaf node (find-constant (first (member-type-members type))))))) (reoptimize-lvar lvar))))) @@ -1444,8 +1444,8 @@ *policy*))) (setf (cast-type-to-check cast) *wild-type*) (substitute-lvar-uses value arg - ;; FIXME - t) + ;; FIXME + t) (%delete-lvar-use ref) (add-lvar-use cast lvar))))) (setf (node-derived-type ref) *wild-type*) @@ -1550,7 +1550,6 @@ ;;; right here. (defun propagate-local-call-args (call fun) (declare (type combination call) (type clambda fun)) - (unless (or (functional-entry-fun fun) (lambda-optional-dispatch fun)) (let* ((vars (lambda-vars fun)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 5ca87190b..9d5fb9046 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -925,11 +925,13 @@ (if (member-type-p arg) ;; Run down the list of members and convert to a list of ;; member types. - (dolist (member (member-type-members arg)) - (push (if (numberp member) - (make-member-type :members (list member)) - *empty-type*) - new-args)) + (mapc-member-type-members + (lambda (member) + (push (if (numberp member) + (make-member-type :members (list member)) + *empty-type*) + new-args)) + arg) (push arg new-args))) (unless (member *empty-type* new-args) new-args))))) @@ -1088,25 +1090,23 @@ ;;; XXX This would be far simpler if the type-union methods could handle ;;; member/number unions. (defun make-canonical-union-type (type-list) - (let ((members '()) + (let ((xset (alloc-xset)) + (fp-zeroes '()) (misc-types '())) (dolist (type type-list) - (if (member-type-p type) - (setf members (union members (member-type-members type))) - (push type misc-types))) - #!+long-float - (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)) - (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) - (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) - (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (if members - (apply #'type-union (make-member-type :members members) misc-types) - (apply #'type-union misc-types)))) + (cond ((member-type-p type) + (mapc-member-type-members + (lambda (member) + (if (fp-zero-p member) + (unless (member member fp-zeroes) + (pushnew member fp-zeroes)) + (add-to-xset member xset))) + type)) + (t + (push type misc-types)))) + (if (and (xset-empty-p xset) (not fp-zeroes)) + (apply #'type-union misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -3888,17 +3888,16 @@ ;; we're prepared to handle which is basically something ;; that array-element-type can return. (or (and (member-type-p cons-type) - (null (rest (member-type-members cons-type))) + (eql 1 (member-type-size cons-type)) (null (first (member-type-members cons-type)))) (let ((car-type (cons-type-car-type cons-type))) (and (member-type-p car-type) - (null (rest (member-type-members car-type))) - (or (symbolp (first (member-type-members car-type))) - (numberp (first (member-type-members car-type))) - (and (listp (first (member-type-members - car-type))) - (numberp (first (first (member-type-members - car-type)))))) + (eql 1 (member-type-members car-type)) + (let ((elt (first (member-type-members car-type)))) + (or (symbolp elt) + (numberp elt) + (and (listp elt) + (numberp (first elt))))) (good-cons-type-p (cons-type-cdr-type cons-type)))))) (unconsify-type (good-cons-type) ;; Convert the "printed" respresentation of a cons @@ -3949,10 +3948,15 @@ ;; (DOUBLE-FLOAT 10d0 20d0) instead of just ;; double-float. (cond ((member-type-p type) - (let ((members (member-type-members type))) - (if (every #'coerceable-p members) - (specifier-type `(or ,@members)) - *universal-type*))) + (block punt + (let (members) + (mapc-member-type-members + (lambda (member) + (if (coerceable-p member) + (push member members) + (return-from punt *universal-type*))) + type) + (specifier-type `(or ,@members))))) ((and (cons-type-p type) (good-cons-type-p type)) (let ((c-type (unconsify-type (type-specifier type)))) diff --git a/tests/gray-streams.impure.lisp b/tests/gray-streams.impure.lisp index 5b878177d..77a8334bd 100644 --- a/tests/gray-streams.impure.lisp +++ b/tests/gray-streams.impure.lisp @@ -290,7 +290,7 @@ (defvar *gray-binary-data* (let ((vector (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0))) - (dotimes (i (length vector)) + (dotimes (i (length vector)) (setf (aref vector i) (random 256))) vector)) @@ -321,9 +321,9 @@ (dotimes (i 1024) (unless (eql (aref *gray-binary-data* i) (aref binary-buffer i)) - (error "wanted ~S at ~S, got ~S (~S)" + (error "wanted ~S at ~S, got ~S (~S)" (aref *gray-binary-data* i) - i + i (aref binary-buffer i) stream)))))) diff --git a/version.lisp-expr b/version.lisp-expr index cc2c4176e..74b1c7024 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.12.17" +"1.0.12.18" -- 2.11.4.GIT