Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv32227/src/code

Modified Files:
	late-type.lisp 
Log Message:
allow approximating unions of numeric types

 * Binding *APPROXIMATE-NUMERIC-UNIONS* does that. It must be bound
   only by callers of TYPE-UNION that know what they want -- in general

     (OR (INTEGER 1 2) (INTEGER 3 4)) => (INTEGER 1 4)

   is wrong, as (NOT (INTEGER 1 4)) doesn't include 3. But in special cases
   like deriving the return type of a function it can be done.

 * Rename MAKE-CANONICAL-UNION-TYPE MAKE-DERIVED-UNION-TYPE, and bind *A-N-U*
   there if we start accumulating an overly large union of numeric types.
   Definition of "overly large" can be adjusted via
   *DERIVED-NUMERIC-UNION-COMPLEXITY-LIMIT*.

 * Fixes lp#309448 and the recent compiler performance regression due
   to new CONCATENATE deftransform as reported on sbcl-devel.


Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.146
retrieving revision 1.147
diff -u -d -r1.146 -r1.147
--- late-type.lisp	12 Oct 2010 04:46:02 -0000	1.146
+++ late-type.lisp	18 Nov 2010 11:28:47 -0000	1.147
@@ -1883,10 +1883,12 @@
 
 ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
 ;;;
-;;; Old comment, probably no longer applicable:
-;;;
-;;;   ### Note: we give up early to keep from dropping lots of
-;;;   information on the floor by returning overly general types.
+;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent
+;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128),
+;;; the compiler does this occasionally during type-derivation to avoid
+;;; creating absurdly complex unions of numeric types.
+(defvar *approximate-numeric-unions* nil)
+
 (!define-type-method (number :simple-union2) (type1 type2)
   (declare (type numeric-type type1 type2))
   (cond ((csubtypep type1 type2) type2)
@@ -1902,7 +1904,8 @@
              ((and (eq class1 class2)
                    (eq format1 format2)
                    (eq complexp1 complexp2)
-                   (or (numeric-types-intersect type1 type2)
+                   (or *approximate-numeric-unions*
+                       (numeric-types-intersect type1 type2)
                        (numeric-types-adjacent type1 type2)
                        (numeric-types-adjacent type2 type1)))
               (make-numeric-type
@@ -1924,7 +1927,8 @@
                    (integerp (numeric-type-low type2))
                    (integerp (numeric-type-high type2))
                    (= (numeric-type-low type2) (numeric-type-high type2))
-                   (or (numeric-types-adjacent type1 type2)
+                   (or *approximate-numeric-unions*
+                       (numeric-types-adjacent type1 type2)
                        (numeric-types-adjacent type2 type1)))
               (make-numeric-type
                :class 'rational
@@ -1943,7 +1947,8 @@
                    (integerp (numeric-type-low type1))
                    (integerp (numeric-type-high type1))
                    (= (numeric-type-low type1) (numeric-type-high type1))
-                   (or (numeric-types-adjacent type1 type2)
+                   (or *approximate-numeric-unions*
+                       (numeric-types-adjacent type1 type2)
                        (numeric-types-adjacent type2 type1)))
               (make-numeric-type
                :class 'rational