From 23cadc8d86d40f5b1e625ae0469043fa3e8362ce Mon Sep 17 00:00:00 2001 From: Cyrus Harmon Date: Sat, 13 May 2006 16:27:50 +0000 Subject: [PATCH] 0.9.12.12: * Fix bug 401: IR1-transform for TYPEP aborts transformation if invalid type is encountered. NOTE: reapplying changes lost in the sf.net CVS outage --- BUGS | 19 +--------- NEWS | 2 ++ src/compiler/typetran.lisp | 84 +++++++++++++++++++++++--------------------- version.lisp-expr | 2 +- 4 files changed, 48 insertions(+), 59 deletions(-) diff --git a/BUGS b/BUGS index 4b009c1..4860f07 100644 --- a/BUGS +++ b/BUGS @@ -2130,21 +2130,4 @@ WORKAROUND: (c-string :deport-gen) ...) in host-c-call.lisp. 401: "optimizer runaway on bad constant type specifiers in TYPEP" - In 0.9.12.3 (and probably many earlier versions), COMPILE-FILE on - (defun ouch401 () - (etypecase (signum (- x y)) - ((-1 nil)) - ((0 1) (oops "shouldn't happen")))) - or just - (defun foo401 (x) - (typep x '(-1 nil))) - spins emitting what seems to be an endless series of compiler - warnings like - ; --> TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP - ; --> TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP TYPEP - ; --> TYPEP - ; ==> - ; (TYPEP SB-C::OBJECT '(-1 NIL)) - ; - ; caught WARNING: - ; illegal type specifier for TYPEP: (-1 NIL) + (fixed in 0.9.12.12) diff --git a/NEWS b/NEWS index 5330664..c315a2f 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,8 @@ changes in sbcl-0.9.13 relative to sbcl-0.9.12: * new feature: source path information is generated for macro-expansion errors for use in IDE's like Slime (thanks to Helmut Eller) * bug fix: calls to the compiler no longer modify *RANDOM-STATE* + * bug fix: compiler does not loop forever on an invalid type in + TYPEP. * improvement: compilation of most CLOS applications is significantly faster diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 584e86f..6405bdd 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -57,10 +57,14 @@ ;;; constant. At worst, it will convert to %TYPEP, which will prevent ;;; spurious attempts at transformation (and possible repeated ;;; warnings.) -(deftransform typep ((object type)) +(deftransform typep ((object type) * * :node node) (unless (constant-lvar-p type) (give-up-ir1-transform "can't open-code test of non-constant type")) - `(typep object ',(lvar-value type))) + (multiple-value-bind (expansion fail-p) + (source-transform-typep 'object (lvar-value type)) + (if fail-p + (abort-ir1-transform) + expansion))) ;;; If the lvar OBJECT definitely is or isn't of the specified ;;; type, then return T or NIL as appropriate. Otherwise quietly @@ -488,6 +492,43 @@ ;;; to that predicate. Otherwise, we dispatch off of the type's type. ;;; These transformations can increase space, but it is hard to tell ;;; when, so we ignore policy and always do them. +(defun source-transform-typep (object type) + (let ((ctype (careful-specifier-type type))) + (or (when (not ctype) + (compiler-warn "illegal type specifier for TYPEP: ~S" type) + (return-from source-transform-typep (values nil t))) + (let ((pred (cdr (assoc ctype *backend-type-predicates* + :test #'type=)))) + (when pred `(,pred ,object))) + (typecase ctype + (hairy-type + (source-transform-hairy-typep object ctype)) + (negation-type + (source-transform-negation-typep object ctype)) + (union-type + (source-transform-union-typep object ctype)) + (intersection-type + (source-transform-intersection-typep object ctype)) + (member-type + `(if (member ,object ',(member-type-members ctype)) t)) + (args-type + (compiler-warn "illegal type specifier for TYPEP: ~S" type) + (return-from source-transform-typep (values nil t))) + (t nil)) + (typecase ctype + (numeric-type + (source-transform-numeric-typep object ctype)) + (classoid + `(%instance-typep ,object ',type)) + (array-type + (source-transform-array-typep object ctype)) + (cons-type + (source-transform-cons-typep object ctype)) + (character-set-type + (source-transform-character-set-typep object ctype)) + (t nil)) + `(%typep ,object ',type)))) + (define-source-transform typep (object spec) ;; KLUDGE: It looks bad to only do this on explicitly quoted forms, ;; since that would overlook other kinds of constants. But it turns @@ -496,44 +537,7 @@ ;; source transform another chance, so it all works out OK, in a ;; weird roundabout way. -- WHN 2001-03-18 (if (and (consp spec) (eq (car spec) 'quote)) - (let ((type (careful-specifier-type (cadr spec)))) - (block bail - (or (when (not type) - (compiler-warn "illegal type specifier for TYPEP: ~S" - (cadr spec)) - (return-from bail (values nil t))) - (let ((pred (cdr (assoc type *backend-type-predicates* - :test #'type=)))) - (when pred `(,pred ,object))) - (typecase type - (hairy-type - (source-transform-hairy-typep object type)) - (negation-type - (source-transform-negation-typep object type)) - (union-type - (source-transform-union-typep object type)) - (intersection-type - (source-transform-intersection-typep object type)) - (member-type - `(if (member ,object ',(member-type-members type)) t)) - (args-type - (compiler-warn "illegal type specifier for TYPEP: ~S" - (cadr spec)) - (return-from bail (values nil t))) - (t nil)) - (typecase type - (numeric-type - (source-transform-numeric-typep object type)) - (classoid - `(%instance-typep ,object ,spec)) - (array-type - (source-transform-array-typep object type)) - (cons-type - (source-transform-cons-typep object type)) - (character-set-type - (source-transform-character-set-typep object type)) - (t nil)) - `(%typep ,object ,spec)))) + (source-transform-typep object (cadr spec)) (values nil t))) ;;;; coercion diff --git a/version.lisp-expr b/version.lisp-expr index e9b2ce8..b3c76ae 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.9.12.11" +"0.9.12.12" -- 1.7.10.4