From: Nikodemus Siivola Date: Mon, 13 Sep 2010 11:04:00 +0000 (+0000) Subject: 1.0.42.37: use more NAMED-LAMBDAs in PCL generated code X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6a5462ff3cc3006e9b29a59c8424e81a279320c9;p=sbcl.git 1.0.42.37: use more NAMED-LAMBDAs in PCL generated code Previously backtraces and profiles showed eg. (LAMBDA (.ARG0. .ARG1. .ARG2.)) for effective method functions, and (LAMBDA (VALUE)) for slot typechecking functions. Use NAMED-LAMBDA to name these sensibly: (DFUN ) (SLOT-TYPECHECK ) --- diff --git a/NEWS b/NEWS index b24dc75..6e88fdd 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ changes relative to sbcl-1.0.42 * enhancement: SB-EXT:WORD type is provided for use with SB-EXT:ATOMIC-INCF &co. + * enhancement: CLOS effective method functions and defclass slot typechecking + function now have debug names for use in backtraces and profiles. * enhancement: ASDF has been updated to version 2.004. (lp#605260, thanks to Faré Rideau) * enhancement: symbols are printed using fully qualified names in several diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index be7a9a8..8128f53 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -229,18 +229,19 @@ ;; Otherwise the METHOD-COMBINATION slot is not bound. (let ((combin (generic-function-method-combination gf))) (and (long-method-combination-p combin) - (long-method-combination-args-lambda-list combin)))))) + (long-method-combination-args-lambda-list combin))))) + (name `(emf ,(generic-function-name gf)))) (cond (error-p - `(lambda (.pv. .next-method-call. &rest .args.) - (declare (ignore .pv. .next-method-call.)) - (declare (ignorable .args.)) - (flet ((%no-primary-method (gf args) - (call-no-primary-method gf args)) - (%invalid-qualifiers (gf combin method) - (invalid-qualifiers gf combin method))) - (declare (ignorable #'%no-primary-method #'%invalid-qualifiers)) - ,effective-method))) + `(named-lambda ,name (.pv. .next-method-call. &rest .args.) + (declare (ignore .pv. .next-method-call.)) + (declare (ignorable .args.)) + (flet ((%no-primary-method (gf args) + (call-no-primary-method gf args)) + (%invalid-qualifiers (gf combin method) + (invalid-qualifiers gf combin method))) + (declare (ignorable #'%no-primary-method #'%invalid-qualifiers)) + ,effective-method))) (mc-args-p (let* ((required (make-dfun-required-args nreq)) (gf-args (if applyp @@ -250,17 +251,17 @@ (the (and unsigned-byte fixnum) .dfun-more-count.))) `(list ,@required)))) - `(lambda ,ll - (declare (ignore .pv. .next-method-call.)) - (let ((.gf-args. ,gf-args)) - (declare (ignorable .gf-args.)) - ,@check-applicable-keywords - ,effective-method)))) + `(named-lambda ,name ,ll + (declare (ignore .pv. .next-method-call.)) + (let ((.gf-args. ,gf-args)) + (declare (ignorable .gf-args.)) + ,@check-applicable-keywords + ,effective-method)))) (t - `(lambda ,ll - (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.)))) - ,@check-applicable-keywords - ,effective-method)))))) + `(named-lambda ,name ,ll + (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.)))) + ,@check-applicable-keywords + ,effective-method)))))) (defun expand-emf-call-method (gf form metatypes applyp env) (declare (ignore gf metatypes applyp env)) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index cec722e..846f82a 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -64,9 +64,9 @@ (defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil) -(defmacro define-internal-pcl-function-name-syntax (name &body body) +(defmacro define-internal-pcl-function-name-syntax (name (var) &body body) `(progn - (define-function-name-syntax ,name ,@body) + (define-function-name-syntax ,name (,var) ,@body) (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*))) (define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 638f561..de39bc3 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -234,10 +234,11 @@ (let* ((type-check-function (if (eq type t) nil - `('type-check-function (lambda (value) - (declare (type ,type value) - (optimize (sb-c:store-coverage-data 0))) - value)))) + `('type-check-function + (named-lambda (slot-typecheck ,class-name ,name) (value) + (declare (type ,type value) + (optimize (sb-c:store-coverage-data 0))) + value)))) (canon `(:name ',name :readers ',readers :writers ',writers :initargs ',initargs ,@type-check-function diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp index 7498eea..38eb79e 100644 --- a/src/pcl/gray-streams.lisp +++ b/src/pcl/gray-streams.lisp @@ -88,7 +88,13 @@ (setf (stream-open-p stream) nil) t) -(setf (fdefinition 'close) #'pcl-close) +(progn + ;; KLUDGE: Get in a call to PCL-CLOSE with a string-output-stream before + ;; setting it as CLOSE. Otherwise using NAMED-LAMBDAs as DFUNs causes a + ;; vicious metacircle from FORMAT NIL somewhere in the compiler. This is + ;; enough to get the dispatch settled down before we need it. + (pcl-close (make-string-output-stream)) + (setf (fdefinition 'close) #'pcl-close)) (let () (fmakunbound 'input-stream-p) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 27283ae..d54308c 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -366,6 +366,26 @@ '(((lambda (x)) 13) ((lambda (y)) 13)))) +(with-test (:name :clos-slot-typecheckfun-named) + (assert + (verify-backtrace + (lambda () + (eval `(locally (declare (optimize safety)) + (defclass clos-typecheck-test () + ((slot :type fixnum))) + (setf (slot-value (make-instance 'clos-typecheck-test) 'slot) t)))) + '(((sb-pcl::slot-typecheck clos-typecheck-test slot) t))))) + +(with-test (:name :clos-emf-named) + (assert + (verify-backtrace + (lambda () + (eval `(progn + (defmethod clos-emf-named-test ((x symbol)) x) + (defmethod clos-emf-named-test :before (x) (assert x)) + (clos-emf-named-test nil)))) + '(((sb-pcl::emf clos-emf-named-test) ? ? nil))))) + ;;;; test TRACE (defun trace-this () diff --git a/version.lisp-expr b/version.lisp-expr index 9bc051c..641b796 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.42.36" +"1.0.42.37"