From 4af56c115ef7ec63e06be677f9dfbf8116882e4c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 1 May 2009 10:35:43 +0000 Subject: [PATCH] 1.0.28.2: fix bug 201, Incautious type inference from compound types * Define LVAR-CONSERVATIVE-TYPE &co, which take into accound that a function call can change the type of a cons or a non-simple array without changing it's identity. Use this instead of LVAR-TYPE in derive-type optimizers for CAR and CDR, and in the ARRAY-DIMENSIONS transform. (There may be other places where it should be used as well, but I could not find anything else just now.) --- BUGS | 25 ------- NEWS | 2 + src/compiler/array-tran.lisp | 4 +- src/compiler/ir1opt.lisp | 157 +++++++++++++++++++++++++++++++++++++----- src/compiler/seqtran.lisp | 6 +- tests/compiler.pure.lisp | 37 ++++++++++ version.lisp-expr | 2 +- 7 files changed, 185 insertions(+), 48 deletions(-) diff --git a/BUGS b/BUGS index 1cb8b2c..c4c7cf2 100644 --- a/BUGS +++ b/BUGS @@ -524,31 +524,6 @@ WORKAROUND: c. (fixed in 0.8.4.23) -201: "Incautious type inference from compound types" - a. (reported by APD sbcl-devel 2002-09-17) - (DEFUN FOO (X) - (LET ((Y (CAR (THE (CONS INTEGER *) X)))) - (SETF (CAR X) NIL) - (FORMAT NIL "~S IS ~S, Y = ~S" - (CAR X) - (TYPECASE (CAR X) - (INTEGER 'INTEGER) - (T '(NOT INTEGER))) - Y))) - - (FOO ' (1 . 2)) => "NIL IS INTEGER, Y = 1" - - b. - * (defun foo (x) - (declare (type (array * (4 4)) x)) - (let ((y x)) - (setq x (make-array '(4 4))) - (adjust-array y '(3 5)) - (= (array-dimension y 0) (eval `(array-dimension ,y 0))))) - FOO - * (foo (make-array '(4 4) :adjustable t)) - NIL - 205: "environment issues in cross compiler" (These bugs have no impact on user code, but should be fixed or documented.) diff --git a/NEWS b/NEWS index 2cce443..f727ecf 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,8 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- * bug fix: disable address space randomization Linux/x86-64 as well, not just x86-64. (reported by Ken Olum) + * bug fix: #201; type inference for CONS and ARRAY types could derive + wrong results in the presence of eg. RPLACA or ADJUST-ARRAY. changes in sbcl-1.0.28 relative to 1.0.27: * a number of bugs in cross-compilation have been fixed, with the ultimate diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 9f90545..dfd1664 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -475,7 +475,9 @@ (array index)) (unless (constant-lvar-p axis) (give-up-ir1-transform "The axis is not constant.")) - (let ((array-type (lvar-type array)) + ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the + ;; conservative type. + (let ((array-type (lvar-conservative-type array)) (axis (lvar-value axis))) (let ((dims (array-type-dimensions-or-give-up array-type))) (unless (listp dims) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index d1d9e68..c22c25c 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -42,6 +42,22 @@ ;;; The result value is cached in the LVAR-%DERIVED-TYPE slot. If the ;;; slot is true, just return that value, otherwise recompute and ;;; stash the value there. +(eval-when (:compile-toplevel :execute) + (#+sb-xc-host cl:defmacro + #-sb-xc-host sb!xc:defmacro + lvar-type-using (lvar accessor) + `(let ((uses (lvar-uses ,lvar))) + (cond ((null uses) *empty-type*) + ((listp uses) + (do ((res (,accessor (first uses)) + (values-type-union (,accessor (first current)) + res)) + (current (rest uses) (rest current))) + ((or (null current) (eq res *wild-type*)) + res))) + (t + (,accessor uses)))))) + #!-sb-fluid (declaim (inline lvar-derived-type)) (defun lvar-derived-type (lvar) (declare (type lvar lvar)) @@ -49,18 +65,7 @@ (setf (lvar-%derived-type lvar) (%lvar-derived-type lvar)))) (defun %lvar-derived-type (lvar) - (declare (type lvar lvar)) - (let ((uses (lvar-uses lvar))) - (cond ((null uses) *empty-type*) - ((listp uses) - (do ((res (node-derived-type (first uses)) - (values-type-union (node-derived-type (first current)) - res)) - (current (rest uses) (rest current))) - ((or (null current) (eq res *wild-type*)) - res))) - (t - (node-derived-type uses))))) + (lvar-type-using lvar node-derived-type)) ;;; Return the derived type for LVAR's first value. This is guaranteed ;;; not to be a VALUES or FUNCTION type. @@ -68,6 +73,112 @@ (defun lvar-type (lvar) (single-value-type (lvar-derived-type lvar))) +;;; LVAR-CONSERVATIVE-TYPE +;;; +;;; Certain types refer to the contents of an object, which can +;;; change without type derivation noticing: CONS types and ARRAY +;;; types suffer from this: +;;; +;;; (let ((x (the (cons fixnum fixnum) (cons a b)))) +;;; (setf (car x) c) +;;; (+ (car x) (cdr x))) +;;; +;;; Python doesn't realize that the SETF CAR can change the type of X -- so we +;;; cannot use LVAR-TYPE which gets the derived results. Worse, still, instead +;;; of (SETF CAR) we might have a call to a user-defined function FOO which +;;; does the same -- so there is no way to use the derived information in +;;; general. +;;; +;;; So, the conservative option is to use the derived type if the leaf has +;;; only a single ref -- in which case there cannot be a prior call that +;;; mutates it. Otherwise we use the declared type or punt to the most general +;;; type we know to be correct for sure. +(defun lvar-conservative-type (lvar) + (let ((derived-type (lvar-type lvar)) + (t-type *universal-type*)) + ;; Recompute using NODE-CONSERVATIVE-TYPE instead of derived type if + ;; necessary -- picking off some easy cases up front. + (cond ((or (eq derived-type t-type) + ;; Can't use CSUBTYPEP! + (type= derived-type (specifier-type 'list)) + (type= derived-type (specifier-type 'null))) + derived-type) + ((and (cons-type-p derived-type) + (eq t-type (cons-type-car-type derived-type)) + (eq t-type (cons-type-cdr-type derived-type))) + derived-type) + ((and (array-type-p derived-type) + (or (not (array-type-complexp derived-type)) + (let ((dimensions (array-type-dimensions derived-type))) + (or (eq '* dimensions) + (every (lambda (dim) (eq '* dim)) dimensions))))) + derived-type) + ((type-needs-conservation-p derived-type) + (single-value-type (lvar-type-using lvar node-conservative-type))) + (t + derived-type)))) + +(defun node-conservative-type (node) + (let* ((derived-values-type (node-derived-type node)) + (derived-type (single-value-type derived-values-type))) + (if (ref-p node) + (let ((leaf (ref-leaf node))) + (if (and (basic-var-p leaf) + (cdr (leaf-refs leaf))) + (coerce-to-values + (if (eq :declared (leaf-where-from leaf)) + (leaf-type leaf) + (conservative-type derived-type))) + derived-values-type)) + derived-values-type))) + +(defun conservative-type (type) + (cond ((or (eq type *universal-type*) + (eq type (specifier-type 'list)) + (eq type (specifier-type 'null))) + type) + ((cons-type-p type) + (specifier-type 'cons)) + ((array-type-p type) + (if (array-type-complexp type) + (make-array-type + ;; ADJUST-ARRAY may change dimensions, but rank stays same. + :dimensions + (let ((old (array-type-dimensions type))) + (if (eq '* old) + old + (mapcar (constantly '*) old))) + ;; Complexity cannot change. + :complexp (array-type-complexp type) + ;; Element type cannot change. + :element-type (array-type-element-type type) + :specialized-element-type (array-type-specialized-element-type type)) + ;; Simple arrays cannot change at all. + type)) + (t + ;; If the type contains some CONS types, the conservative type contains all + ;; of them. + (when (types-equal-or-intersect type (specifier-type 'cons)) + (setf type (type-union type (specifier-type 'cons)))) + ;; Similarly for non-simple arrays -- it should be possible to preserve + ;; more information here, but really... + (let ((non-simple-arrays (specifier-type '(and array (not simple-array))))) + (when (types-equal-or-intersect type non-simple-arrays) + (setf type (type-union type non-simple-arrays)))) + type))) + +(defun type-needs-conservation-p (type) + (cond ((eq type *universal-type*) + ;; Excluding T is necessary, because we do want type derivation to + ;; be able to narrow it down in case someone (most like a macro-expansion...) + ;; actually declares something as having type T. + nil) + ((or (cons-type-p type) (and (array-type-p type) (array-type-complexp type))) + ;; Covered by the next case as well, but this is a quick test. + t) + ((types-equal-or-intersect type (specifier-type '(or cons (and array (not simple-array))))) + t))) + ;;; If LVAR is an argument of a function, return a type which the ;;; function checks LVAR for. #!-sb-fluid (declaim (inline lvar-externally-checkable-type)) @@ -1262,19 +1373,27 @@ ;;;; local call optimization -;;; Propagate TYPE to LEAF and its REFS, marking things changed. If -;;; the leaf type is a function type, then just leave it alone, since -;;; TYPE is never going to be more specific than that (and -;;; TYPE-INTERSECTION would choke.) +;;; Propagate TYPE to LEAF and its REFS, marking things changed. +;;; +;;; If the leaf type is a function type, then just leave it alone, since TYPE +;;; is never going to be more specific than that (and TYPE-INTERSECTION would +;;; choke.) +;;; +;;; Also, if the type is one requiring special care don't touch it if the leaf +;;; has multiple references -- otherwise LVAR-CONSERVATIVE-TYPE is screwed. (defun propagate-to-refs (leaf type) (declare (type leaf leaf) (type ctype type)) - (let ((var-type (leaf-type leaf))) - (unless (fun-type-p var-type) + (let ((var-type (leaf-type leaf)) + (refs (leaf-refs leaf))) + (unless (or (fun-type-p var-type) + (and (cdr refs) + (eq :declared (leaf-where-from leaf)) + (type-needs-conservation-p var-type))) (let ((int (type-approx-intersection2 var-type type))) (when (type/= int var-type) (setf (leaf-type leaf) int) (let ((s-int (make-single-value-type int))) - (dolist (ref (leaf-refs leaf)) + (dolist (ref refs) (derive-node-type ref s-int) ;; KLUDGE: LET var substitution (let* ((lvar (node-lvar ref))) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3255973..1eb4d18 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -1053,7 +1053,9 @@ ;;;; CONS accessor DERIVE-TYPE optimizers (defoptimizer (car derive-type) ((cons)) - (let ((type (lvar-type cons)) + ;; This and CDR needs to use LVAR-CONSERVATIVE-TYPE because type inference + ;; gets confused by things like (SETF CAR). + (let ((type (lvar-conservative-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) @@ -1061,7 +1063,7 @@ (cons-type-car-type type))))) (defoptimizer (cdr derive-type) ((cons)) - (let ((type (lvar-type cons)) + (let ((type (lvar-conservative-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index e9f23d8..f2cba5f 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2834,3 +2834,40 @@ (test-comparison > double-float (/ 0d0 0d0) 0d0) (test-comparison > double-float 0d0 (/ 0d0 0d0))))) +(with-test (:name :car-and-cdr-type-derivation-conservative) + (let ((f1 (compile nil + `(lambda (y) + (declare (optimize speed)) + (let ((x (the (cons fixnum fixnum) (cons 1 2)))) + (declare (type (cons t fixnum) x)) + (rplaca x y) + (+ (car x) (cdr x)))))) + (f2 (compile nil + `(lambda (y) + (declare (optimize speed)) + (let ((x (the (cons fixnum fixnum) (cons 1 2)))) + (setf (cdr x) y) + (+ (car x) (cdr x))))))) + (flet ((test-error (e value) + (assert (typep e 'type-error)) + (assert (eq 'number (type-error-expected-type e))) + (assert (eq value (type-error-datum e))))) + (let ((v1 "foo") + (v2 "bar")) + (multiple-value-bind (res err) (ignore-errors (funcall f1 v1)) + (assert (not res)) + (test-error err v1)) + (multiple-value-bind (res err) (ignore-errors (funcall f2 v2)) + (assert (not res)) + (test-error err v2)))))) + +(with-test (:name :array-dimension-derivation-conservative) + (let ((f (compile nil + `(lambda (x) + (declare (optimize speed)) + (declare (type (array * (4 4)) x)) + (let ((y x)) + (setq x (make-array '(4 4))) + (adjust-array y '(3 5)) + (array-dimension y 0)))))) + (assert (= 3 (funcall f (make-array '(4 4) :adjustable t)))))) diff --git a/version.lisp-expr b/version.lisp-expr index 336801b..7cc4d15 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.28.1" +"1.0.28.2" -- 1.7.10.4