From d76dbf51c6184eea35a98758df312ae031b24d6f Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 19 Oct 2010 10:22:40 +0000 Subject: [PATCH] 1.0.43.71: fix regression from 1.0.43.26 PROPAGATE-LOCAL-CALL-ARGS needs to special-case optional dispatch entry-points after all: our usual approach can load to too narrow types being derived for &OPTIONAL arguments. So just deal with &REST args in those cases. Closes bug 655203 again. --- src/compiler/ir1opt.lisp | 68 +++++++++++++++++++++++++++------------------- tests/compiler.pure.lisp | 24 ++++++++++++++++ version.lisp-expr | 2 +- 3 files changed, 65 insertions(+), 29 deletions(-) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 961d1c4..e07fe5d 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1735,6 +1735,11 @@ ;;; If the function has an entry-fun, then we don't do anything: since ;;; it has a XEP we would not discover anything. ;;; +;;; If the function is an optional-entry-point, we will just make sure +;;; &REST lists are known to be lists. Doing the regular rigamarole +;;; can erronously propagate too strict types into refs: see +;;; BUG-655203-REGRESSION in tests/compiler.pure.lisp. +;;; ;;; We can clear the LVAR-REOPTIMIZE flags for arguments in all calls ;;; corresponding to changed arguments in CALL, since the only use in ;;; IR1 optimization of the REOPTIMIZE flag for local call args is @@ -1742,34 +1747,41 @@ (defun propagate-local-call-args (call fun) (declare (type combination call) (type clambda fun)) (unless (functional-entry-fun fun) - (let* ((vars (lambda-vars fun)) - (union (mapcar (lambda (arg var) - (when (and arg - (lvar-reoptimize arg) - (null (basic-var-sets var))) - (lvar-type arg))) - (basic-combination-args call) - vars)) - (this-ref (lvar-use (basic-combination-fun call)))) - - (dolist (arg (basic-combination-args call)) - (when arg - (setf (lvar-reoptimize arg) nil))) - - (dolist (ref (leaf-refs fun)) - (let ((dest (node-dest ref))) - (unless (or (eq ref this-ref) (not dest)) - (setq union - (mapcar (lambda (this-arg old) - (when old - (setf (lvar-reoptimize this-arg) nil) - (type-union (lvar-type this-arg) old))) - (basic-combination-args dest) - union))))) - - (loop for var in vars - and type in union - when type do (propagate-to-refs var type)))) + (if (lambda-optional-dispatch fun) + ;; We can still make sure &REST is known to be a list. + (loop for var in (lambda-vars fun) + do (let ((info (lambda-var-arg-info var))) + (when (and info (eq :rest (arg-info-kind info))) + (propagate-to-refs var (specifier-type 'list))))) + ;; The normal case. + (let* ((vars (lambda-vars fun)) + (union (mapcar (lambda (arg var) + (when (and arg + (lvar-reoptimize arg) + (null (basic-var-sets var))) + (lvar-type arg))) + (basic-combination-args call) + vars)) + (this-ref (lvar-use (basic-combination-fun call)))) + + (dolist (arg (basic-combination-args call)) + (when arg + (setf (lvar-reoptimize arg) nil))) + + (dolist (ref (leaf-refs fun)) + (let ((dest (node-dest ref))) + (unless (or (eq ref this-ref) (not dest)) + (setq union + (mapcar (lambda (this-arg old) + (when old + (setf (lvar-reoptimize this-arg) nil) + (type-union (lvar-type this-arg) old))) + (basic-combination-args dest) + union))))) + + (loop for var in vars + and type in union + when type do (propagate-to-refs var type))))) (values)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index c74f9b4..7dd538f 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2684,6 +2684,16 @@ (assert (eq 'list type)) (assert derivedp))) +(with-test (:name :rest-list-type-derivation3) + (multiple-value-bind (type derivedp) + (funcall (funcall (compile nil `(lambda () + (lambda (&optional x &rest args) + (unless x (error "oops")) + (ctu:compiler-derived-type args))))) + t) + (assert (eq 'list type)) + (assert derivedp))) + (with-test (:name :base-char-typep-elimination) (assert (eq (funcall (lambda (ch) (declare (type base-char ch) (optimize (speed 3) (safety 0))) @@ -3620,3 +3630,17 @@ (assert (equal '(integer 0 (3)) (type-error-expected-type e))) :caught)))))) +(with-test (:name :bug-655203-regression) + (let ((fun (compile nil + `(LAMBDA (VARIABLE) + (LET ((CONTINUATION + (LAMBDA + (&OPTIONAL DUMMY &REST OTHER) + (DECLARE (IGNORE OTHER)) + (PRIN1 DUMMY) + (PRIN1 VARIABLE)))) + (FUNCALL CONTINUATION (LIST 1 2))))))) + ;; This used to signal a bogus type-error. + (assert (equal (with-output-to-string (*standard-output*) + (funcall fun t)) + "(1 2)T")))) diff --git a/version.lisp-expr b/version.lisp-expr index de0051d..2cac2d3 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.43.70" +"1.0.43.71" -- 1.7.10.4