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
(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
\f
;;;; 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
(stem (if (every #'alpha-char-p symbol-name)
symbol-name
(concatenate 'string symbol-name "-"))))
- `(,symbol (block-gensym ,stem))))
+ `(,symbol (gensym ,stem))))
symbols)
,@body))
(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))))
\f
;;;; miscellany
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))))
\f
;;;; catch-all for unknown things
(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
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))
Return VALUE without evaluating it."
(reference-constant start next result thing))
\f
+(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"
(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))))
(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
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)))
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)))
\f
;;;; 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.
;;;
(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
(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)
: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
(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
(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
(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))))))
(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))
(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
(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))
(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))
\f
;;;; Test that unwind cleanups are executed
projects / sbcl.git / commitdiff