From 2050b7c3644ab235aaf1959795bb33e89bd571a3 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 9 Aug 2011 19:05:42 +0300 Subject: [PATCH] better inner and anonymous function names * New concept: "name context". It is either name of the outermost non-NIL block in the current lexenv (FIXME: would be better to have the outermost global function name instead) or the source-namestring of the file in which the function resides. * Name anonymous functions as (LAMBDA :IN ) * Name FLET and LABELS functions as (FLET :IN ) and (LABELS :IN ) Adjust tests to suit. * Remove BLOCK-GENSYM as this fulfills the same goals, and together they make backtraces overly noisy. --- NEWS | 2 ++ src/code/pprint.lisp | 4 +++- src/code/primordial-extensions.lisp | 24 +++++--------------- src/code/print.lisp | 18 +++++++-------- src/compiler/early-c.lisp | 4 ++-- src/compiler/ir1-translators.lisp | 27 +++++++++++++++++------ src/compiler/x86-64/macros.lisp | 2 +- src/compiler/x86/macros.lisp | 2 +- tests/debug.impure.lisp | 33 +++++++++++++++------------- tests/unwind-to-frame-and-call.impure.lisp | 23 +++++++++---------- 10 files changed, 74 insertions(+), 65 deletions(-) diff --git a/NEWS b/NEWS index f86d780..c37e890 100644 --- a/NEWS +++ b/NEWS @@ -24,6 +24,8 @@ changes relative to sbcl-1.0.53: STANDARD-INSTANCE-ACCESS, and FUNCALLABLE-STANDARD-INSTANCE-ACCESS. ** Users can now defined new places usable with SB-EXT:COMPARE-AND-SWAP using an API anologous to defining new SETFable places. + * enhancement: debug-names of anonymous and local function are more + descriptive. Affects backtraces and SB-SPROF results. (lp#805100) * enhancement: on GENCGC systems nursery and generation sizes now default to 5% of dynamic-space size. * enhancement: on CHENEYGC targets, SB-KERNEL:MAKE-LISP-OBJ now does diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 07f8725..08e25e9 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -1145,7 +1145,9 @@ line break." (declare (ignore noise)) (if (and (consp list) (consp (cdr list)) - (cddr list)) + (cddr list) + ;; Filter out (FLET FOO :IN BAR) names. + (not (eq :in (third list)))) (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>") stream diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 8f9789c..0ca98ac 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -124,16 +124,6 @@ ;;;; GENSYM tricks -;;; GENSYM variant for easier debugging and better backtraces: append -;;; the closest enclosing non-nil block name to the provided stem. -(defun block-gensym (&optional (name "G") (env (when (boundp 'sb!c::*lexenv*) - (symbol-value 'sb!c::*lexenv*)))) - (let ((block-name (when env - (car (find-if #'car (sb!c::lexenv-blocks env)))))) - (if block-name - (sb!xc:gensym (format nil "~A[~A]" name block-name)) - (sb!xc:gensym name)))) - ;;; Compile a version of BODY for all TYPES, and dispatch to the ;;; correct one based on the value of VAR. This was originally used ;;; only for strings, hence the name. Renaming it to something more @@ -164,7 +154,7 @@ (stem (if (every #'alpha-char-p symbol-name) symbol-name (concatenate 'string symbol-name "-")))) - `(,symbol (block-gensym ,stem)))) + `(,symbol (gensym ,stem)))) symbols) ,@body)) @@ -173,13 +163,11 @@ (declaim (ftype (function (index &optional t) (values list &optional)) make-gensym-list)) (defun make-gensym-list (n &optional name) - (case name - ((t) - (loop repeat n collect (gensym))) - ((nil) - (loop repeat n collect (block-gensym))) - (otherwise - (loop repeat n collect (gensym name))))) + (when (eq t name) + (break)) + (if name + (loop repeat n collect (gensym (string name))) + (loop repeat n collect (gensym)))) ;;;; miscellany diff --git a/src/code/print.lisp b/src/code/print.lisp index b0a4e72..924000b 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1734,15 +1734,15 @@ nil) (defun output-fun (object stream) - (let* ((*print-length* 3) ; in case we have to.. - (*print-level* 3) ; ..print an interpreted function definition - (name (%fun-name object)) - (proper-name-p (and (legal-fun-name-p name) (fboundp name) - (eq (fdefinition name) object)))) - (print-unreadable-object (object stream :identity (not proper-name-p)) - (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" - (closurep object) - name)))) + (let* ((*print-length* 4) ; in case we have to.. + (*print-level* 3) ; ..print an interpreted function definition + (name (%fun-name object)) + (proper-name-p (and (legal-fun-name-p name) (fboundp name) + (eq (fdefinition name) object)))) + (print-unreadable-object (object stream :identity (not proper-name-p)) + (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" + (closurep object) + name)))) ;;;; catch-all for unknown things diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 9d19a78..b313fcc 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -230,7 +230,7 @@ the stack without triggering overflow protection.") (setf *debug-name-sharp* (make-debug-name-marker) *debug-name-ellipsis* (make-debug-name-marker)) -(defun debug-name (type thing) +(defun debug-name (type thing &optional context) (let ((*debug-name-punt* nil)) (labels ((walk (x) (typecase x @@ -257,7 +257,7 @@ the stack without triggering overflow protection.") x) (t (type-of x))))) - (let ((name (list type (walk thing)))) + (let ((name (list* type (walk thing) (when context (name-context))))) (when (legal-fun-name-p name) (bug "~S is a legal function name, and cannot be used as a ~ debug name." name)) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index f79a734..a5e4cfb 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -476,15 +476,27 @@ body, references to a NAME will effectively be replaced with the EXPANSION." Return VALUE without evaluating it." (reference-constant start next result thing)) +(defun name-context () + ;; Name of the outermost non-NIL BLOCK, or the source namestring + ;; of the source file. + (let ((context + (or (car (find-if #'car (lexenv-blocks *lexenv*) :from-end t)) + *source-namestring* + (let ((p (or *compile-file-truename* *load-truename*))) + (when p (namestring p)))))) + (when context + (list :in context)))) + ;;;; FUNCTION and NAMED-LAMBDA (defun name-lambdalike (thing) (case (car thing) ((named-lambda) (or (second thing) - `(lambda ,(third thing)))) + `(lambda ,(third thing) ,(name-context)))) ((lambda) - `(lambda ,(second thing))) + `(lambda ,(second thing) ,@(name-context))) ((lambda-with-lexenv) + ;; FIXME: Get the original DEFUN name here. `(lambda ,(fifth thing))) (otherwise (compiler-error "Not a valid lambda expression:~% ~S" @@ -814,10 +826,11 @@ lexically apparent function definition in the enclosing environment." (multiple-value-bind (names defs) (extract-flet-vars definitions 'flet) (let ((fvars (mapcar (lambda (n d) - (ir1-convert-lambda d - :source-name n - :maybe-add-debug-catch t - :debug-name (debug-name 'flet n))) + (ir1-convert-lambda + d :source-name n + :maybe-add-debug-catch t + :debug-name + (debug-name 'flet n t))) names defs))) (processing-decls (decls nil fvars next result) (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) @@ -852,7 +865,7 @@ other." (ir1-convert-lambda def :source-name name :maybe-add-debug-catch t - :debug-name (debug-name 'labels name))) + :debug-name (debug-name 'labels name t))) names defs)))) ;; Modify all the references to the dummy function leaves so diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index b7d0ef4..92f83f1 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/src/compiler/x86-64/macros.lisp @@ -529,7 +529,7 @@ Useful for e.g. foreign calls where another thread may trigger collection." (if objects (let ((pins (make-gensym-list (length objects))) - (wpo (block-gensym "WPO"))) + (wpo (gensym "WITH-PINNED-OBJECTS-THUNK"))) ;; BODY is stuffed in a function to preserve the lexical ;; environment. `(flet ((,wpo () (progn ,@body))) diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 18251b5..7386f77 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -546,7 +546,7 @@ Useful for e.g. foreign calls where another thread may trigger collection." (if objects (let ((pins (make-gensym-list (length objects))) - (wpo (block-gensym "WPO"))) + (wpo (gensym "WITH-PINNED-OBJECTS-THUNK"))) ;; BODY is stuffed in a function to preserve the lexical ;; environment. `(flet ((,wpo () (progn ,@body))) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 94241be..4d8ae6b 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -22,6 +22,8 @@ ;;;; Check that we get debug arglists right. +(defvar *p* (namestring *load-truename*)) + ;;; FIXME: This should use some get-argslist like functionality that ;;; we actually export. ;;; @@ -155,7 +157,7 @@ (assert (verify-backtrace (lambda () (test #'optimized)) (list *undefined-function-frame* - (list '(flet test) #'optimized))))) + (list `(flet test :in ,*p*) #'optimized))))) ;; bug 353: This test fails at least most of the time for x86/linux ;; ca. 0.8.20.16. -- WHN @@ -169,8 +171,8 @@ (assert (verify-backtrace (lambda () (test #'not-optimized)) (list *undefined-function-frame* - (list '(flet not-optimized)) - (list '(flet test) #'not-optimized)))))) + (list `(flet not-optimized :in ,*p*)) + (list `(flet test :in ,*p*) #'not-optimized)))))) (with-test (:name :backtrace-interrupted-condition-wait :skipped-on '(not :sb-thread) @@ -216,13 +218,13 @@ :fails-on :alpha) ; bug 346 (assert (verify-backtrace (lambda () (test #'optimized)) (list '(/ 42 &rest) - (list '(flet test) #'optimized))))) + (list `(flet test :in ,*p*) #'optimized))))) (with-test (:name (:divide-by-zero :bug-356) :fails-on :alpha) ; bug 356 (assert (verify-backtrace (lambda () (test #'not-optimized)) (list '(/ 42 &rest) - '((flet not-optimized)) - (list '(flet test) #'not-optimized)))))) + `((flet not-optimized :in ,*p*)) + (list `(flet test :in ,*p*) #'not-optimized)))))) (with-test (:name (:throw :no-such-tag) :fails-on '(or @@ -378,8 +380,8 @@ (defvar *compile-nil-non-tc* (compile nil '(lambda (y) (cons (funcall *compile-nil-error* y) nil)))) (with-test (:name (:compile nil)) (assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc* 13)) - '(((lambda (x)) 13) - ((lambda (y)) 13))))) + `(((lambda (x) :in ,*p*) 13) + ((lambda (y) :in ,*p*) 13))))) (with-test (:name :clos-slot-typecheckfun-named) (assert @@ -412,21 +414,21 @@ (assert (verify-backtrace (lambda () (funcall (make-fun 0) 10 11 0)) - '((sb-kernel:two-arg-/ 10/11 0) + `((sb-kernel:two-arg-/ 10/11 0) (/ 10 11 0) - ((lambda (&rest rest)) 10 11 0)))) + ((lambda (&rest rest) :in ,*p*) 10 11 0)))) (assert (verify-backtrace (lambda () (funcall (make-fun 1) 10 11 0)) - '((sb-kernel:two-arg-/ 10/11 0) + `((sb-kernel:two-arg-/ 10/11 0) (/ 10 11 0) - ((lambda (a &rest rest)) 10 11 0)))) + ((lambda (a &rest rest) :in ,*p*) 10 11 0)))) (assert (verify-backtrace (lambda () (funcall (make-fun 2) 10 11 0)) - '((sb-kernel:two-arg-/ 10/11 0) + `((sb-kernel:two-arg-/ 10/11 0) (/ 10 11 0) - ((lambda (a b &rest rest)) 10 11 0)))))) + ((lambda (a b &rest rest) :in ,*p*) 10 11 0)))))) ;;;; test TRACE @@ -499,7 +501,8 @@ (declare (notinline dx-arg-backtrace)) (assert (member-if (lambda (frame) (and (consp frame) - (equal '(flet dx-arg-backtrace) (car frame)) + (consp (car frame)) + (equal '(flet dx-arg-backtrace :in) (butlast (car frame))) (notany #'sb-debug::stack-allocated-p (cdr frame)))) (dx-arg-backtrace dx-arg)))))) diff --git a/tests/unwind-to-frame-and-call.impure.lisp b/tests/unwind-to-frame-and-call.impure.lisp index 9da24b6..c746e5b 100644 --- a/tests/unwind-to-frame-and-call.impure.lisp +++ b/tests/unwind-to-frame-and-call.impure.lisp @@ -20,8 +20,8 @@ (defun return-from-frame (frame-name &rest values) (let ((frame (sb-di::top-frame))) - (loop until (equal (sb-debug::frame-call frame) - frame-name) + (loop until (equal frame-name + (sb-debug::frame-call frame)) do (setf frame (sb-di::frame-down frame))) (assert frame) (assert (sb-debug::frame-has-debug-tag-p frame)) @@ -194,10 +194,10 @@ (defun test-locals (name) (handler-bind ((in-a (lambda (c) (declare (ignore c)) - (return-from-frame '(flet a) 'x 'y))) + (return-from-frame `(flet a :in ,name) 'x 'y))) (in-b (lambda (c) (declare (ignore c)) - (return-from-frame '(flet b) 'z)))) + (return-from-frame `(flet b :in ,name) 'z)))) (funcall name)) ;; We're intentionally not testing for returning a different amount ;; of values than the local functions are normally returning. It's @@ -249,11 +249,12 @@ (defparameter *anon-3* (make-anon-3)) (defparameter *anon-4* (make-anon-4)) -(defun test-anon (fun var-name) +(defun test-anon (fun var-name &optional in) (handler-bind ((anon-condition (lambda (c) (declare (ignore c)) - (return-from-frame `(lambda (,var-name)) - 'x 'y)))) + (return-from-frame + `(lambda (,var-name) ,@(when in `(:in ,in))) + 'x 'y)))) (let ((*foo* 'x)) (let ((*foo* 'y)) (assert (equal (multiple-value-list (funcall fun 1)) @@ -262,16 +263,16 @@ (assert (eql *foo* 'x))))) (with-test (:name (:return-from-frame :anonymous :toplevel)) - (test-anon *anon-1* 'foo)) + (test-anon *anon-1* 'foo (namestring *load-truename*))) (with-test (:name (:return-from-frame :anonymous :toplevel-special)) - (test-anon *anon-2* '*foo*)) + (test-anon *anon-2* '*foo* (namestring *load-truename*))) (with-test (:name (:return-from-frame :anonymous)) - (test-anon *anon-3* 'foo)) + (test-anon *anon-3* 'foo 'make-anon-3)) (with-test (:name (:return-from-frame :anonymous :special)) - (test-anon *anon-4* '*foo*)) + (test-anon *anon-4* '*foo* 'make-anon-4)) ;;;; Test that unwind cleanups are executed -- 1.7.10.4