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