From 47042c85e19c07dbaa0ade4f6f8afd5c1eee129b Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 4 Nov 2004 11:21:19 +0000 Subject: [PATCH] 0.8.16.32: Fix #302 * PRIMITIVE-TYPE used to return (any) for all intersection types. Make it smarter. --- BUGS | 8 ----- NEWS | 2 ++ src/compiler/generic/primtype.lisp | 69 ++++++++++++++++++++++++------------ tests/compiler.pure.lisp | 7 ++++ version.lisp-expr | 2 +- 5 files changed, 56 insertions(+), 32 deletions(-) diff --git a/BUGS b/BUGS index 5105302..0c13efc 100644 --- a/BUGS +++ b/BUGS @@ -1101,14 +1101,6 @@ WORKAROUND: gives the error failed AVER: "(NOT (AND (NOT EQUALP) CERTAINP))" -302: Undefined type messes up DATA-VECTOR-REF expansion. - Compiling this file - (defun dis (s ei x y) - (declare (type (simple-array function (2)) s) (type ei ei)) - (funcall (aref s ei) x y)) - on sbcl-0.8.7.36/X86/Linux causes a BUG to be signalled: - full call to SB-KERNEL:DATA-VECTOR-REF - 303: "nonlinear LVARs" (aka MISC.293) (defun buu (x) (multiple-value-call #'list diff --git a/NEWS b/NEWS index 6c17834..03e3eba 100644 --- a/NEWS +++ b/NEWS @@ -16,6 +16,8 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16: * minor incompatible change: SB-C::*COMPILER-ERROR-PRINT-FOO* variables are no longer supported: use SB-EXT:*COMPILER-PRINT-VARIABLE-ALIST* instead. + * fixed bug #302: better primitive-type selection for intersection + types. * fixed bug #308: non-graphic characters now all have names, as required. (reported by Bruno Haible) * bug fix: Cyclic structures and unprintable objects in compiler diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 962b22f..a219a4f 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -283,12 +283,35 @@ (primitive-type type) (unless ptype-exact (setq exact nil)) (unless (eq ptype res) - (let ((new-ptype - (or (maybe-numeric-type-union res ptype) + (let ((new-ptype + (or (maybe-numeric-type-union res ptype) (maybe-numeric-type-union ptype res)))) (if new-ptype (setq res new-ptype) (return (any))))))))))) + (intersection-type + (let ((types (intersection-type-types type)) + (res (any)) + (exact nil)) + (dolist (type types (values res exact)) + (when (eq type (specifier-type 'function)) + ;; KLUDGE: Deal with (and function instance), both of which + ;; have an exact primitive type. + (return (part-of function))) + (multiple-value-bind (ptype ptype-exact) + (primitive-type type) + (when ptype-exact + ;; Apart from the previous kludge exact primitive + ;; types should match, if indeed there are any. It + ;; may be that this assumption isn't really safe, + ;; but at least we'll see what breaks. -- NS 20041104 + (aver (or (not exact) (eq ptype res))) + (setq exact t)) + (when (or ptype-exact (and (not exact) (eq res (any)))) + ;; Try to find a narrower representation then + ;; (any). Takes care of undecidable types in + ;; intersections with decidable ones. + (setq res ptype)))))) (member-type (let* ((members (member-type-members type)) (res (primitive-type-of (first members)))) @@ -311,26 +334,26 @@ (= (cdar pairs) (1- sb!xc:char-code-limit))) (exactly character) (part-of character)))) - (built-in-classoid - (case (classoid-name type) - ((complex function instance - system-area-pointer weak-pointer) - (values (primitive-type-or-lose (classoid-name type)) t)) - (funcallable-instance - (part-of function)) - (cons-type - (part-of list)) - (t - (any)))) - (fun-type - (exactly function)) - (classoid - (if (csubtypep type (specifier-type 'function)) - (part-of function) - (part-of instance))) - (ctype - (if (csubtypep type (specifier-type 'function)) - (part-of function) - (any))))))) + (built-in-classoid + (case (classoid-name type) + ((complex function instance + system-area-pointer weak-pointer) + (values (primitive-type-or-lose (classoid-name type)) t)) + (funcallable-instance + (part-of function)) + (cons-type + (part-of list)) + (t + (any)))) + (fun-type + (exactly function)) + (classoid + (if (csubtypep type (specifier-type 'function)) + (part-of function) + (part-of instance))) + (ctype + (if (csubtypep type (specifier-type 'function)) + (part-of function) + (any))))))) (/show0 "primtype.lisp end of file") diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 3bbe2c5..e9ca625 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1598,3 +1598,10 @@ (compilation-speed 0) (speed 1))) (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) 805))) + +;;; bug #302 +(assert (compile + nil + '(lambda (s ei x y) + (declare (type (simple-array function (2)) s) (type ei ei)) + (funcall (aref s ei) x y)))) diff --git a/version.lisp-expr b/version.lisp-expr index 6dcb422..c15a297 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".) -"0.8.16.31" +"0.8.16.32" -- 1.7.10.4