From 83659744f9caa97aa83eb562d872b1c0127403c0 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 8 Nov 2010 12:42:01 +0000 Subject: [PATCH] 1.0.44.4: make MAKE-FUNCTIONAL-FROM-TOPLEVEL-LAMBDA build proper XEPs Bring MAKE-FUNCTIONAL-FROM-TOPLEVEL-LAMBDA into closer alignment with MAKE-XEP. Specifically, cross-link the underlying function and the TL-XEP, and mark the TL-XEP for reanalysis. Fixes lp#310173 and lp#384892: * Show &REST arguments properly in backtraces. * Better type-derivation of function result types when the lambda-list is complex. --- NEWS | 4 +++ contrib/sb-introspect/test-driver.lisp | 6 ++-- src/compiler/dfo.lisp | 5 +++- src/compiler/ir1util.lisp | 3 +- src/compiler/locall.lisp | 32 ++++++++++++---------- src/compiler/main.lisp | 47 ++++++++++++++++++++------------ tests/compiler.pure.lisp | 18 ++++++++++-- tests/debug.impure.lisp | 27 ++++++++++++++++++ version.lisp-expr | 2 +- 9 files changed, 102 insertions(+), 42 deletions(-) diff --git a/NEWS b/NEWS index 4b162ec..e8d48df 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.0.44: + * bug fix: backtracing function with &REST arguments now shows the full + argument list. (lp#310173) + * bug fix: return types for functions with complex lambda-lists are now + derived properly (lp#384892) * bug fix: when SPEED > SPACE compiling CONCATENATE 'STRING with constant long string arguments slowed the compiler down to a crawl. diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp index 0a8abaf..0ce7187 100644 --- a/contrib/sb-introspect/test-driver.lisp +++ b/contrib/sb-introspect/test-driver.lisp @@ -378,12 +378,10 @@ (deftest function-type.2 (values (type-equal (function-type 'sun) (function-type #'sun)) - ;; Does not currently work due to Bug #384892. (1.0.31.26) - #+nil (type-equal (function-type #'sun) '(function (fixnum fixnum &key (:k1 (member nil t))) (values (member t) &optional)))) - t #+nil t) + t t) ;; Local functions @@ -516,7 +514,7 @@ '(function ((member nil t) fixnum fixnum &key (:k1 (member nil t))) - *))) + (values (member nil t) &optional)))) t t) ;; Misc diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 28c53e3..8ee0621 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -190,7 +190,10 @@ (home-kind (functional-kind home)) (home-externally-visible-p (or (eq home-kind :toplevel) - (functional-has-external-references-p home)))) + (functional-has-external-references-p home) + (let ((entry (functional-entry-fun home))) + (and entry + (functional-has-external-references-p entry)))))) (unless (or (and home-externally-visible-p (eq (functional-kind fun) :external)) (eq home-kind :deleted)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 2532768..78d92e3 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1305,7 +1305,8 @@ (aver (null (functional-entry-fun leaf))) (delete-lambda leaf)) (:external - (delete-lambda leaf)) + (unless (functional-has-external-references-p leaf) + (delete-lambda leaf))) ((:deleted :zombie :optional)))) (optional-dispatch (unless (eq (functional-kind leaf) :deleted) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index aa84315..e820d46 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -209,25 +209,29 @@ (declare (type functional fun)) (aver (null (functional-entry-fun fun))) (with-ir1-environment-from-node (lambda-bind (main-entry fun)) - (let ((res (ir1-convert-lambda (make-xep-lambda-expression fun) + (let ((xep (ir1-convert-lambda (make-xep-lambda-expression fun) :debug-name (debug-name 'xep (leaf-debug-name fun)) :system-lambda t))) - (setf (functional-kind res) :external - (leaf-ever-used res) t - (functional-entry-fun res) fun - (functional-entry-fun fun) res + (setf (functional-kind xep) :external + (leaf-ever-used xep) t + (functional-entry-fun xep) fun + (functional-entry-fun fun) xep (component-reanalyze *current-component*) t) (reoptimize-component *current-component* :maybe) - (etypecase fun - (clambda - (locall-analyze-fun-1 fun)) - (optional-dispatch - (dolist (ep (optional-dispatch-entry-points fun)) - (locall-analyze-fun-1 (force ep))) - (when (optional-dispatch-more-entry fun) - (locall-analyze-fun-1 (optional-dispatch-more-entry fun))))) - res))) + (locall-analyze-xep-entry-point fun) + xep))) + +(defun locall-analyze-xep-entry-point (fun) + (declare (type functional fun)) + (etypecase fun + (clambda + (locall-analyze-fun-1 fun)) + (optional-dispatch + (dolist (ep (optional-dispatch-entry-points fun)) + (locall-analyze-fun-1 (force ep))) + (when (optional-dispatch-more-entry fun) + (locall-analyze-fun-1 (optional-dispatch-more-entry fun)))))) ;;; Notice a REF that is not in a local-call context. If the REF is ;;; already to an XEP, then do nothing, otherwise change it to the diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 33a1967..c4cf5f5 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1097,28 +1097,39 @@ Examples: (source-name (or name '.anonymous.))) (setf (component-name component) (debug-name 'initial-component debug-name-tail) (component-kind component) :initial) - (let* ((locall-fun (let ((*allow-instrumenting* t)) - (funcall #'ir1-convert-lambdalike - lambda-expression - :source-name source-name))) - ;; Convert the XEP using the policy of the real - ;; function. Otherwise the wrong policy will be used for - ;; deciding whether to type-check the parameters of the - ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS). - ;; -- JES, 2007-02-27 - (*lexenv* (make-lexenv :policy (lexenv-policy - (functional-lexenv locall-fun)))) - (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) + (let* ((fun (let ((*allow-instrumenting* t)) + (funcall #'ir1-convert-lambdalike + lambda-expression + :source-name source-name))) + ;; Convert the XEP using the policy of the real function. Otherwise + ;; the wrong policy will be used for deciding whether to type-check + ;; the parameters of the real function (via CONVERT-CALL / + ;; PROPAGATE-TO-ARGS). -- JES, 2007-02-27 + (*lexenv* (make-lexenv :policy (lexenv-policy (functional-lexenv fun)))) + (xep (ir1-convert-lambda (make-xep-lambda-expression fun) :source-name source-name :debug-name (debug-name 'tl-xep debug-name-tail) :system-lambda t))) (when name - (assert-global-function-definition-type name locall-fun)) - (setf (functional-entry-fun fun) locall-fun - (functional-kind fun) :external - (functional-has-external-references-p locall-fun) t - (functional-has-external-references-p fun) t) - fun))) + (assert-global-function-definition-type name fun)) + (setf (functional-kind xep) :external + (functional-entry-fun xep) fun + (functional-entry-fun fun) xep + (component-reanalyze component) t + (functional-has-external-references-p xep) t) + (reoptimize-component component :maybe) + (locall-analyze-xep-entry-point fun) + ;; Any leftover REFs to FUN outside local calls get replaced with the + ;; XEP. + (substitute-leaf-if (lambda (ref) + (let* ((lvar (ref-lvar ref)) + (dest (when lvar (lvar-dest lvar))) + (kind (when (basic-combination-p dest) + (basic-combination-kind dest)))) + (neq :local kind))) + xep + fun) + xep))) ;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a ;;; description of the result. diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index fbadfe9..ebb61ac 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2706,9 +2706,10 @@ (assert derivedp))) (with-test (:name :base-char-typep-elimination) - (assert (eq (funcall (lambda (ch) - (declare (type base-char ch) (optimize (speed 3) (safety 0))) - (typep ch 'base-char)) + (assert (eq (funcall (compile nil + `(lambda (ch) + (declare (type base-char ch) (optimize (speed 3) (safety 0))) + (typep ch 'base-char))) t) t))) @@ -3681,3 +3682,14 @@ (short-avg (/ (+ d0 d1 d2) 3))) (assert (and f1 f2 f3)) (assert (< d3 (* 10 short-avg)))))) + +(with-test (:name :bug-384892) + (assert (equal + '(function (fixnum fixnum &key (:k1 (member nil t))) + (values (member t) &optional)) + (sb-kernel:%simple-fun-type + (compile nil `(lambda (x y &key k1) + (declare (fixnum x y)) + (declare (boolean k1)) + (declare (ignore x y k1)) + t)))))) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index b79e3f3..f33a966 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -386,6 +386,33 @@ (clos-emf-named-test nil)))) '(((sb-pcl::emf clos-emf-named-test) ? ? nil))))) +(with-test (:name :bug-310173) + (flet ((make-fun (n) + (let* ((names '(a b)) + (req (loop repeat n collect (pop names)))) + (compile nil + `(lambda (,@req &rest rest) + (let ((* *)) ; no tail-call + (apply '/ ,@req rest))))))) + (assert + (verify-backtrace (lambda () + (funcall (make-fun 0) 10 11 0)) + '((sb-kernel:two-arg-/ 10/11 0) + (/ 10 11 0) + ((lambda (&rest rest)) 10 11 0)))) + (assert + (verify-backtrace (lambda () + (funcall (make-fun 1) 10 11 0)) + '((sb-kernel:two-arg-/ 10/11 0) + (/ 10 11 0) + ((lambda (a &rest rest)) 10 11 0)))) + (assert + (verify-backtrace (lambda () + (funcall (make-fun 2) 10 11 0)) + '((sb-kernel:two-arg-/ 10/11 0) + (/ 10 11 0) + ((lambda (a b &rest rest)) 10 11 0)))))) + ;;;; test TRACE (defun trace-this () diff --git a/version.lisp-expr b/version.lisp-expr index fd205fc..ce1ff25 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.44.3" +"1.0.44.4" -- 1.7.10.4