From dbe82b489260b2ef76e916d0aeaee8b3850f5f52 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 18 Nov 2010 11:28:46 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ package-data-list.lisp-expr | 1 + src/code/late-type.lisp | 19 +++++++++------ src/compiler/srctran.lisp | 37 +++++++++++++++++++--------- tests/compiler.pure.lisp | 57 +++++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 98 insertions(+), 20 deletions(-) diff --git a/NEWS b/NEWS index 200ea48..5cba2f6 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,8 @@ changes relative to sbcl-1.0.44: in the DEFMETHOD body. * bug fix: # should no longer appear in compiler messages, being instead replaced with the corresponding function name. + * bug fix: don't derive overly complex unions of numeric types for arithmetic + operators. (lp#309448) changes in sbcl-1.0.44 relative to sbcl-1.0.43: * enhancement: RUN-PROGRAM accepts :EXTERNAL-FORMAT argument to select the diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 161165b..e99ff95 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1350,6 +1350,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%WITH-ARRAY-DATA" "%WITH-ARRAY-DATA/FP" "%WITH-ARRAY-DATA-MACRO" + "*APPROXIMATE-NUMERIC-UNIONS*" "*CURRENT-LEVEL-IN-PRINT*" "*EMPTY-TYPE*" "*EVAL-CALLS*" diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 16b605d..34b5f0d 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -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 diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 76d880a..50d4d3c 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1127,21 +1127,26 @@ (t type-list))) -;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably -;;; belong in the kernel's type logic, invoked always, instead of in -;;; the compiler, invoked only during some type optimizations. (In -;;; fact, as of 0.pre8.100 or so they probably are, under -;;; MAKE-MEMBER-TYPE, so probably this code can be deleted) - ;;; Take a list of types and return a canonical type specifier, ;;; combining any MEMBER types together. If both positive and negative ;;; MEMBER types are present they are converted to a float type. ;;; XXX This would be far simpler if the type-union methods could handle ;;; member/number unions. -(defun make-canonical-union-type (type-list) +;;; +;;; If we're about to generate an overly complex union of numeric types, start +;;; collapse the ranges together. +;;; +;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and +;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic, +;;; invoked always, instead of in the compiler, invoked only during some type +;;; optimizations. +(defvar *derived-numeric-union-complexity-limit* 6) + +(defun make-derived-union-type (type-list) (let ((xset (alloc-xset)) (fp-zeroes '()) - (misc-types '())) + (misc-types '()) + (numeric-type *empty-type*)) (dolist (type type-list) (cond ((member-type-p type) (mapc-member-type-members @@ -1151,11 +1156,19 @@ (pushnew member fp-zeroes)) (add-to-xset member xset))) type)) + ((numeric-type-p type) + (let ((*approximate-numeric-unions* + (when (and (union-type-p numeric-type) + (nthcdr *derived-numeric-union-complexity-limit* + (union-type-types numeric-type))) + t))) + (setf numeric-type (type-union type numeric-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)))) + (apply #'type-union numeric-type misc-types) + (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) + numeric-type misc-types)))) ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) @@ -1220,7 +1233,7 @@ (setf results (append results result)) (push result results)))) (if (rest results) - (make-canonical-union-type results) + (make-derived-union-type results) (first results))))))) ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes @@ -1293,7 +1306,7 @@ (setf results (append results result)) (push result results)))))) (if (rest results) - (make-canonical-union-type results) + (make-derived-union-type results) (first results))))))) #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index ebb61ac..060010b 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -3693,3 +3693,60 @@ (declare (boolean k1)) (declare (ignore x y k1)) t)))))) + +(with-test (:name :bug-309448) + ;; Like all tests trying to verify that something doesn't blow up + ;; compile-times this is bound to be a bit brittle, but at least + ;; here we try to establish a decent baseline. + (flet ((time-it (lambda want) + (let* ((start (get-internal-run-time)) + (fun (compile nil lambda)) + (end (get-internal-run-time)) + (got (funcall fun))) + (unless (eql want got) + (error "wanted ~S, got ~S" want got)) + (- end start)))) + (let ((time-1/simple + ;; This is mostly identical as the next one, but doesn't create + ;; hairy unions of numeric types. + (time-it `(lambda () + (labels ((bar (baz bim) + (let ((n (+ baz bim))) + (* n (+ n 1) bim)))) + (let ((a (bar 1 1)) + (b (bar 1 1)) + (c (bar 1 1))) + (- (+ a b) c)))) + 6)) + (time-1/hairy + (time-it `(lambda () + (labels ((bar (baz bim) + (let ((n (+ baz bim))) + (* n (+ n 1) bim)))) + (let ((a (bar 1 1)) + (b (bar 1 5)) + (c (bar 1 15))) + (- (+ a b) c)))) + -3864))) + (assert (>= (* 10 (1+ time-1/simple)) time-1/hairy))) + (let ((time-2/simple + ;; This is mostly identical as the next one, but doesn't create + ;; hairy unions of numeric types. + (time-it `(lambda () + (labels ((sum-d (n) + (let ((m (truncate 999 n))) + (/ (* n m (1+ m)) 2)))) + (- (+ (sum-d 3) + (sum-d 3)) + (sum-d 3)))) + 166833)) + (time-2/hairy + (time-it `(lambda () + (labels ((sum-d (n) + (let ((m (truncate 999 n))) + (/ (* n m (1+ m)) 2)))) + (- (+ (sum-d 3) + (sum-d 5)) + (sum-d 15)))) + 233168))) + (assert (>= (* 10 (1+ time-2/simple)) time-2/hairy))))) diff --git a/version.lisp-expr b/version.lisp-expr index 449d9eb..a773c8e 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.44.27" +"1.0.44.28" -- 1.7.10.4