From cb674c899ffc5a332a00d991f91513455bf06a75 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Fri, 20 Mar 2009 14:54:29 +0000 Subject: [PATCH] This big of code causes CMUCL to spend huge amounts of time trying to simplify the union of disjoint double-float types: (defun foo (arg) (declare (type double-double-float arg) (optimize (speed 3) (space 0))) (let* ((x arg) (xx 0w0) (k 0) (px (coerce k 'double-double-float)) (qx 0w0)) (declare (type double-double-float x xx px qx) (notinline poly-eval poly-eval-1)) (setf x (- (- x (* px log2-c1)) (* px log2-c2))) (+ x 0d0) )) Fix it: code/type.lisp: o Rename SIMPLIFY-BIG-INTEGER-UNION to SIMPLIFY-BIG-UNION o SIMPLIFY-BIG-UNION takes an extra arg to specify the resulting type. o Modify SIMPLIFY-UNIONS to handle float unions as well as integer unions. general-info/release-20a.txt: o Update --- code/type.lisp | 26 +++++++++++++++++++------- general-info/release-20a.txt | 4 ++++ 2 files changed, 23 insertions(+), 7 deletions(-) diff --git a/code/type.lisp b/code/type.lisp index 5f7bf8fc7..ded424a80 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 0b86717ef..df760c8f1 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 -- GitLab