From 5a2c8811f297b21b5e4142ce29d2c7981cbb2697 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 23 Jan 2012 14:27:17 +0200 Subject: [PATCH] weakening hairy integer types Fixes lp#913232. Deal with intersection types and unions including non-integer component types, such as: (OR (INTEGER * -1) (AND (SATISFIES ODDP) (INTEGER 1))) --- NEWS | 3 ++ src/compiler/array-tran.lisp | 6 ++-- src/compiler/checkgen.lisp | 80 +++++++++++++++++++++++++++++------------- tests/compiler.pure.lisp | 12 +++++++ 4 files changed, 75 insertions(+), 26 deletions(-) diff --git a/NEWS b/NEWS index 8bbebd1..affcb0c 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,7 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes relative to sbcl-1.0.55: + * bug fix: compiler errors when weakening hairy integer types. (lp#913232) + changes in sbcl-1.0.55 relative to sbcl-1.0.54: * enhancements to building SBCL using make.sh: ** --fancy can be specified to enable all supported feature enhancements. diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 34d8840..0cf9279 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -180,9 +180,11 @@ (flet ((subscript-bounds (subscript) (let* ((type1 (lvar-type subscript)) (type2 (if (csubtypep type1 (specifier-type 'integer)) - (weaken-integer-type type1) + (weaken-integer-type type1 :range-only t) (give-up))) - (low (numeric-type-low type2)) + (low (if (integer-type-p type2) + (numeric-type-low type2) + (give-up))) (high (numeric-type-high type2))) (cond ((and (or (not (bound-known-p low)) (minusp low)) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index b461851..12681b3 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -77,27 +77,58 @@ (t (fun-guessed-cost 'typep))))) -(defun weaken-integer-type (type) - (cond ((union-type-p type) - (let* ((types (union-type-types type)) - (one (pop types)) - (low (numeric-type-low one)) - (high (numeric-type-high one))) - (flet ((maximize (bound) - (if (and bound high) - (setf high (max high bound)) - (setf high nil))) - (minimize (bound) - (if (and bound low) - (setf low (min low bound)) - (setf low nil)))) - (dolist (a types) - (minimize (numeric-type-low a)) - (maximize (numeric-type-high a)))) - (specifier-type `(integer ,(or low '*) ,(or high '*))))) - (t - (aver (integer-type-p type)) - type))) +(defun weaken-integer-type (type &key range-only) + ;; FIXME: Our canonicalization isn't quite ideal for this. We get + ;; types such as: + ;; + ;; (OR (AND (SATISFIES FOO) (INTEGER -100 -50)) + ;; (AND (SATISFIES FOO) (INTEGER 100 200))) + ;; + ;; here, and weakening that into + ;; + ;; (AND (SATISFIES FOO) (INTEGER -100 200)) + ;; + ;; is too much work to do here ... but if we canonicalized things + ;; differently, we could get it for free with trivial changes here. + (labels ((weaken-integer-type-part (type base) + (cond ((intersection-type-p type) + (let ((new (specifier-type base))) + (dolist (part (intersection-type-types type)) + (when (if range-only + (numeric-type-p part) + (not (unknown-type-p part))) + (setf new (type-intersection + new (weaken-integer-type-part part t))))) + new)) + ((union-type-p type) + (let ((low t) (high t) (rest *empty-type*)) + (flet ((maximize (bound) + (if (and bound high) + (setf high (if (eq t high) + bound + (max high bound))) + (setf high nil))) + (minimize (bound) + (if (and bound low) + (setf low (if (eq t low) + bound + (min low bound))) + (setf low nil)))) + (dolist (part (union-type-types type)) + (let ((weak (weaken-integer-type-part part t))) + (cond ((numeric-type-p weak) + (minimize (numeric-type-low weak)) + (maximize (numeric-type-high weak))) + ((not range-only) + (setf rest (type-union rest weak))))))) + (if (eq t low) + rest + (type-union rest + (specifier-type + `(integer ,(or low '*) ,(or high '*))))))) + (t + type)))) + (weaken-integer-type-part type 'integer))) (defun-cached (weaken-type :hash-bits 8 @@ -108,9 +139,10 @@ (cond ((named-type-p type) type) ((csubtypep type (specifier-type 'integer)) - ;; KLUDGE: Simple range checks are not that expensive, and we *don't* - ;; want to accidentally lose eg. array bounds checks due to weakening, - ;; so for integer types we simply collapse all ranges into one. + ;; Simple range checks are not that expensive, and we *don't* + ;; want to accidentally lose eg. array bounds checks due to + ;; weakening, so for integer types we simply collapse all + ;; ranges into one. (weaken-integer-type type)) (t (let ((min-cost (type-test-cost type)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 81fc0f7..e081b4e 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -4167,3 +4167,15 @@ (declare (type (integer -1 -1) d)) (let ((i (unwind-protect 32 (shiftf d -1)))) (or (if (= d c) 2 (= 3 b)) 4))))) + +(with-test (:name :bug-913232) + (compile nil `(lambda (x) + (declare (optimize speed) + (type (or (and (or (integer -100 -50) + (integer 100 200)) (satisfies foo)) + (and (or (integer 0 10) (integer 20 30)) a)) x)) + x)) + (compile nil `(lambda (x) + (declare (optimize speed) + (type (and fixnum a) x)) + x))) -- 1.7.10.4