diff --git a/code/type.lisp b/code/type.lisp index 5f7bf8fc738839d5851d627ea6f6af760eab591f..ded424a80262f5bb90078ffea5caad85d87b3aae 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.80 2008/12/23 14:36:58 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.81 2009/03/20 14:54:28 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -1137,7 +1137,7 @@ ((null (cdr simplified)) (car simplified)) (t (make-union-type simplified))))) -(defun simplify-big-integer-union (first rest) +(defun simplify-big-union (type first rest) ;; (let ((lowest (numeric-type-low first)) (highest (numeric-type-high first))) @@ -1151,7 +1151,7 @@ (if (and (numberp highest) (numberp type-hi)) (setf highest (max highest type-hi)) (setf highest nil)))) - (list (specifier-type `(integer ,(or lowest '*) ,(or highest '*)))))) + (list (specifier-type `(,type ,(or lowest '*) ,(or highest '*)))))) (defparameter *union-length-threshold* 50 @@ -1168,16 +1168,28 @@ (values (car types) (cdr types))) (cond ((and (> (length rest) *union-length-threshold*) + (csubtypep first (specifier-type 'integer)) (every #'(lambda (x) (and (numeric-type-p x) (eq (numeric-type-class x) 'integer))) (cons first rest))) ;; FIXME: We sometimes spend huge amounts of time computing - ;; the union of a bunch of disjoint integer types. This is a + ;; the union of a bunch of disjoint numeric types. This is a ;; hack to shortcut that. If the union is long enough and - ;; they're all integer types, we give up and try to return an - ;; interval that is a superset of each type. - (simplify-big-integer-union first rest)) + ;; they're all of the same type, we give up and try to return + ;; an interval that is a superset of each type. + (simplify-big-union 'integer first rest)) + ((and (> (length rest) *union-length-threshold*) + (csubtypep first (specifier-type 'float)) + (let ((class (numeric-type-class first)) + (format (numeric-type-format first))) + (every #'(lambda (x) + (and (numeric-type-p x) + (eq (numeric-type-class x) class) + (eq (numeric-type-format x) format))) + (cons first rest)))) + ;; Same as above, but for floats. + (simplify-big-union (or (numeric-type-format first) 'float) first rest)) (t (let ((rest (simplify-unions rest)) u) (dolist (r rest (cons first rest)) diff --git a/general-info/release-20a.txt b/general-info/release-20a.txt index 0b86717ef520974036a9e1991dc2258d3ab86b2e..df760c8f1c2fcc30afbf7896608174c41fc64e1a 100644 --- a/general-info/release-20a.txt +++ b/general-info/release-20a.txt @@ -24,6 +24,10 @@ New in this release: * ANSI compliance fixes: * Bugfixes: + - CMUCL sometimes gets "stuck" during compilation where it is + trying to simplify the union of a large number of disjoint + numeric types. Previously, we handled the case of integer + types. Extend this to handle floats as well. * Trac Tickets: #31: pathname bug with :case :common