|
[Sbcl-commits] CVS: sbcl/src/compiler ir1opt.lisp,1.144,1.145
From: Nikodemus Siivola <demoss@us...> - 2010-10-19 10:22
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv21057/src/compiler Modified Files: ir1opt.lisp Log Message: 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. Index: ir1opt.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v retrieving revision 1.144 retrieving revision 1.145 diff -u -d -r1.144 -r1.145 --- ir1opt.lisp 14 Oct 2010 16:32:52 -0000 1.144 +++ ir1opt.lisp 19 Oct 2010 10:22:41 -0000 1.145 @@ -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)))) + (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 (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))))) + (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)))) + (loop for var in vars + and type in union + when type do (propagate-to-refs var type))))) (values)) |
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] CVS: sbcl/src/compiler ir1opt.lisp,1.144,1.145 | Nikodemus Siivola <demoss@us...> |