1 ;;;; This file is for testing debugging functionality, using
2 ;;;; test machinery which might have side effects (e.g.
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; While most of SBCL is derived from the CMU CL system, the test
9 ;;;; files (like this one) were written from scratch after the fork
12 ;;;; This software is in the public domain and is provided with
13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
14 ;;;; more information.
16 (cl:in-package
:cl-user
)
18 ;;; The debugger doesn't have any native knowledge of the interpreter
19 (when (eq sb-ext
:*evaluator-mode
* :interpret
)
20 (sb-ext:exit
:code
104))
23 ;;;; Check that we get debug arglists right.
25 (defvar *p
* (namestring *load-truename
*))
27 ;;; FIXME: This should use some get-argslist like functionality that
28 ;;; we actually export.
30 ;;; Return the debug arglist of the function object FUN as a list, or
31 ;;; punt with :UNKNOWN.
32 (defun get-arglist (fun)
33 (declare (type function fun
))
34 ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
35 (case (sb-kernel:widetag-of fun
)
36 (#.sb-vm
:simple-fun-header-widetag
37 (sb-kernel:%simple-fun-arglist fun
))
38 (#.sb-vm
:closure-header-widetag
(get-arglist
39 (sb-kernel:%closure-fun fun
)))
40 ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
41 ;; like above, and it seems to work. -- MNA 2001-06-12
43 ;; (There might be other cases with arglist info also.
44 ;; SIMPLE-FUN-HEADER-WIDETAG and CLOSURE-HEADER-WIDETAG just
45 ;; happen to be the two case that I had my nose rubbed in when
46 ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
47 ;; a closure. -- WHN 2001-06-05)
50 (if (typep fun
'sb-eval
::interpreted-function
)
51 (sb-eval::interpreted-function-lambda-list fun
)
56 (defun zoop (zeep &key beep
)
58 (assert (equal (get-arglist #'zoop
) '(zeep &key beep
)))
60 ;;; Check some predefined functions too.
62 ;;; (We don't know exactly what the arguments are, e.g. the first
63 ;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
64 ;;; whatever. But we do know the general structure that a correct
65 ;;; answer should have, so we can safely do a lot of checks.)
66 (with-test (:name
:predefined-functions-1
)
67 (destructuring-bind (object-sym &optional-sym stream-sym
) (get-arglist #'print
)
68 (assert (symbolp object-sym
))
69 (assert (eql &optional-sym
'&optional
))
70 (assert (symbolp stream-sym
))))
71 (with-test (:name
:predefined-functions-2
)
72 (destructuring-bind (dest-sym control-sym
&rest-sym format-args-sym
)
73 (get-arglist #'format
)
74 (assert (symbolp dest-sym
))
75 (assert (symbolp control-sym
))
76 (assert (eql &rest-sym
'&rest
))
77 (assert (symbolp format-args-sym
))))
79 ;;; Check for backtraces generally being correct. Ensure that the
80 ;;; actual backtrace finishes (doesn't signal any errors on its own),
81 ;;; and that it contains the frames we expect, doesn't contain any
82 ;;; "bogus stack frame"s, and contains the appropriate toplevel call
83 ;;; and hasn't been cut off anywhere.
84 (defun verify-backtrace (test-function frame-specs
&key details
)
85 (labels ((args-equal (want real
)
86 (cond ((eq '&rest
(car want
))
90 ((or (eq '?
(car want
)) (equal (car want
) (car real
)))
91 (args-equal (cdr want
) (cdr real
)))
97 ((error (lambda (condition)
98 ;; find the part of the backtrace we're interested in
100 (sb-debug::map-backtrace
102 (multiple-value-bind (name args info
)
103 (sb-debug::frame-call frame
#+nil
#+nil
104 :replace-dynamic-extent-objects t
)
106 (push (list (cons name args
) info
) full-backtrace
)
107 (push (cons name args
) full-backtrace
)))))
109 (setf full-backtrace
(nreverse full-backtrace
))
110 (let ((backtrace (if details
111 (member (caaar frame-specs
)
115 (member (caar frame-specs
)
120 (setf result condition
)
123 (format t
"~&//~S not in backtrace:~% ~S~%"
127 ;; check that we have all the frames we wanted
130 (unless (or (not spec
)
133 (and (args-equal (car spec
)
135 (equal (cdr spec
) (cdr frame
)))
137 (print (list :spec spec
:frame frame
))
139 (and (equal (car spec
) (car frame
))
140 (args-equal (cdr spec
)
142 (print (list :wanted spec
:got frame
))
147 ;; Make sure the backtrace isn't stunted in
148 ;; any way. (Depends on running in the main
149 ;; thread.) FIXME: On Windows we get two
150 ;; extra foreign frames below regular frames.
151 (unless (find (if details
152 '((sb-impl::toplevel-init
) ())
153 '(sb-impl::toplevel-init
))
156 (print (list :backtrace-stunted backtrace
))
158 (return-from outer-handler
))))))
159 (funcall test-function
)))
162 (defvar *undefined-function-frame
*
164 '("undefined function"))
166 ;;; Test for "undefined function" (undefined_tramp) working properly.
167 ;;; Try it with and without tail call elimination, since they can have
168 ;;; different effects. (Specifically, if undefined_tramp is incorrect
169 ;;; a stunted stack can result from the tail call variant.)
171 (declare (optimize (speed 2) (debug 1))) ; tail call elimination
172 (#:undefined-function
42))
174 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
175 (#:undefined-function
42))
177 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
180 (with-test (:name
(:undefined-function
:bug-346
)
181 ;; Failures on ALPHA, SPARC, MIPS, and probably
182 ;; HPPA are due to not having a full and valid
183 ;; stack frame for the undefined function frame.
184 ;; See PPC undefined_tramp for details.
185 :fails-on
'(or :alpha
:sparc
:mips
))
186 (assert (verify-backtrace
187 (lambda () (test #'optimized
))
188 (list *undefined-function-frame
*
189 (list `(flet test
:in
,*p
*) #'optimized
)))))
191 ;; bug 353: This test fails at least most of the time for x86/linux
192 ;; ca. 0.8.20.16. -- WHN
193 (with-test (:name
(:undefined-function
:bug-353
))
194 (assert (verify-backtrace
195 (lambda () (test #'not-optimized
))
196 (list *undefined-function-frame
*
197 (list `(flet not-optimized
:in
,*p
*))
198 (list `(flet test
:in
,*p
*) #'not-optimized
))))))
200 (with-test (:name
:backtrace-interrupted-condition-wait
201 :skipped-on
'(not :sb-thread
))
202 (let ((m (sb-thread:make-mutex
))
203 (q (sb-thread:make-waitqueue
)))
204 (assert (verify-backtrace
206 (sb-thread:with-mutex
(m)
207 (handler-bind ((timeout (lambda (c)
210 (sb-thread:condition-wait q m
)))))
211 `((sb-thread:condition-wait
,q
,m
:timeout nil
))))))
213 ;;; Division by zero was a common error on PPC. It depended on the
214 ;;; return function either being before INTEGER-/-INTEGER in memory,
215 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
216 ;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
217 ;;; says that the Sparc backend (at least for CMUCL) inlines this, so
218 ;;; if SBCL does the same this test is probably not good for the
221 ;;; Disabling tail call elimination on this will probably ensure that
222 ;;; the return value (to the flet or the enclosing top level form) is
223 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
224 ;;; Enabling it might catch other problems, so do it anyway.
226 (declare (optimize (speed 2) (debug 1))) ; tail call elimination
229 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
232 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
234 (with-test (:name
(:divide-by-zero
:bug-346
)
235 :fails-on
:alpha
) ; bug 346
236 (assert (verify-backtrace (lambda () (test #'optimized
))
238 (list `(flet test
:in
,*p
*) #'optimized
)))))
239 (with-test (:name
(:divide-by-zero
:bug-356
)
240 :fails-on
:alpha
) ; bug 356
241 (assert (verify-backtrace (lambda () (test #'not-optimized
))
243 `((flet not-optimized
:in
,*p
*))
244 (list `(flet test
:in
,*p
*) #'not-optimized
))))))
246 (with-test (:name
(:throw
:no-such-tag
)
253 (throw 'no-such-tag t
))
254 (assert (verify-backtrace #'throw-test
'((throw-test))))))
256 (defun bug-308926 (x)
264 (with-test (:name
:bug-308926
)
265 (assert (verify-backtrace (lambda () (bug-308926 13))
266 '(((flet bar
:in bug-308926
) 13)
267 (bug-308926 &rest t
)))))
269 ;;; Test backtrace through assembly routines
271 (macrolet ((test (predicate fun
273 (find-symbol (format nil
"TWO-ARG-~A" fun
)
275 (let ((test-name (make-symbol (format nil
"TEST-~A" fun
))))
276 `(flet ((,test-name
(x y
)
277 ;; make sure it's not in tail position
279 (with-test (:name
(:bug-800343
,fun
))
280 (assert (verify-backtrace
282 (eval `(funcall ,#',test-name
42 t
)))
286 `((,(find-symbol (format nil
"GENERIC-~A" fun
) "SB-VM"))))
287 ((flet ,test-name
:in
,*p
*) 42 t
))))))))
288 (test-predicates (&rest functions
)
289 `(progn ,@(mapcar (lambda (function)
292 `(test t
,function
)))
294 (test-functions (&rest functions
)
295 `(progn ,@(mapcar (lambda (function)
297 `(test nil
,@function
)
298 `(test nil
,function
)))
300 (test-predicates = < >)
301 (test-functions + -
* /
303 (logand sb-kernel
:two-arg-and
)
304 (logior sb-kernel
:two-arg-ior
)
305 (logxor sb-kernel
:two-arg-xor
)))
307 ;;; test entry point handling in backtraces
312 (with-test (:name
:xep-too-many-arguments
)
313 (assert (verify-backtrace (lambda () (oops 1 2 3 4 5 6))
314 '((oops ? ? ? ? ? ?
)))))
316 (defmacro defbt
(n ll
&body body
)
317 ;; WTF is this? This is a way to make these tests not depend so much on the
318 ;; details of LOAD/EVAL. Around 1.0.57 we changed %SIMPLE-EVAL to be
319 ;; slightly smarter, which meant that things which used to have xeps
320 ;; suddently had tl-xeps, etc. This takes care of that.
326 (defun ,(intern (format nil
"BT.~A.1" n
)) ,ll
328 ;; no arguments saved
329 (defun ,(intern (format nil
"BT.~A.2" n
)) ,ll
330 (declare (optimize (debug 1) (speed 3)))
332 ;; no lambda-list saved
333 (defun ,(intern (format nil
"BT.~A.3" n
)) ,ll
334 (declare (optimize (debug 0)))
343 (defbt 3 (&key
(key (oops)))
346 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
347 (defbt 4 (&optional opt
)
348 (list (error "error")))
350 (defbt 5 (&optional
(opt (oops)))
354 (error "XEPs in backtraces: ~S" x
))
356 (with-test (:name
:bug-354
)
357 (assert (not (verify-backtrace (lambda () (bug-354 354))
359 (((bug-354 &rest
) (:tl
:external
)) 354)))))
360 (assert (verify-backtrace (lambda () (bug-354 354)) '((bug-354 354)))))
362 ;;; FIXME: This test really should be broken into smaller pieces
363 (with-test (:name
(:backtrace
:tl-xep
))
364 (assert (verify-backtrace #'namestring
365 '(((namestring) (:tl
:external
)))
367 (assert (verify-backtrace #'namestring
370 (with-test (:name
(:backtrace
:more-processor
))
371 (assert (verify-backtrace (lambda () (bt.1.1 :key
))
372 '(((bt.1.1 :key
) (:more
:optional
)))
374 (assert (verify-backtrace (lambda () (bt.1.2 :key
))
375 '(((bt.1.2 ?
) (:more
:optional
)))
377 (assert (verify-backtrace (lambda () (bt.1.3 :key
))
378 '(((bt.1.3 &rest
) (:more
:optional
)))
380 (assert (verify-backtrace (lambda () (bt.1.1 :key
))
382 (assert (verify-backtrace (lambda () (bt.1.2 :key
))
384 (assert (verify-backtrace (lambda () (bt.1.3 :key
))
387 (with-test (:name
(:backtrace
:xep
))
388 (assert (verify-backtrace #'bt
.2.1
389 '(((bt.2.1) (:external
)))
391 (assert (verify-backtrace #'bt
.2.2
392 '(((bt.2.2 &rest
) (:external
)))
394 (assert (verify-backtrace #'bt
.2.3
395 '(((bt.2.3 &rest
) (:external
)))
397 (assert (verify-backtrace #'bt
.2.1
399 (assert (verify-backtrace #'bt
.2.2
401 (assert (verify-backtrace #'bt
.2.3
404 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
405 ;;; these functions used to have sb-c::varargs-entry debug names for their
407 (with-test (:name
(:backtrace
:varargs-entry
))
408 (assert (verify-backtrace #'bt
.3.1
409 '((bt.3.1 :key nil
))))
410 (assert (verify-backtrace #'bt
.3.2
412 (assert (verify-backtrace #'bt
.3.3
414 (assert (verify-backtrace #'bt
.3.1
415 '((bt.3.1 :key nil
))))
416 (assert (verify-backtrace #'bt
.3.2
418 (assert (verify-backtrace #'bt
.3.3
421 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
422 ;;; these functions used to have sb-c::hairy-args-processor debug names for
423 ;;; their main lambda.
424 (with-test (:name
(:backtrace
:hairy-args-processor
))
425 (assert (verify-backtrace #'bt
.4.1
427 (assert (verify-backtrace #'bt
.4.2
429 (assert (verify-backtrace #'bt
.4.3
431 (assert (verify-backtrace #'bt
.4.1
433 (assert (verify-backtrace #'bt
.4.2
435 (assert (verify-backtrace #'bt
.4.3
439 (with-test (:name
(:backtrace
:optional-processor
))
440 (assert (verify-backtrace #'bt
.5.1
441 '(((bt.5.1) (:optional
)))
443 (assert (verify-backtrace #'bt
.5.2
444 '(((bt.5.2 &rest
) (:optional
)))
446 (assert (verify-backtrace #'bt
.5.3
447 '(((bt.5.3 &rest
) (:optional
)))
449 (assert (verify-backtrace #'bt
.5.1
451 (assert (verify-backtrace #'bt
.5.2
453 (assert (verify-backtrace #'bt
.5.3
456 (write-line "//compile nil")
457 (defvar *compile-nil-error
* (compile nil
'(lambda (x) (cons (when x
(error "oops")) nil
))))
458 (defvar *compile-nil-non-tc
* (compile nil
'(lambda (y) (cons (funcall *compile-nil-error
* y
) nil
))))
459 (with-test (:name
(:compile nil
))
460 (assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc
* 13))
461 `(((lambda (x) :in
,*p
*) 13)
462 ((lambda (y) :in
,*p
*) 13)))))
464 (with-test (:name
:clos-slot-typecheckfun-named
)
468 (eval `(locally (declare (optimize safety
))
469 (defclass clos-typecheck-test
()
470 ((slot :type fixnum
)))
471 (setf (slot-value (make-instance 'clos-typecheck-test
) 'slot
) t
))))
472 '(((sb-pcl::slot-typecheck fixnum
) t
)))))
474 (with-test (:name
:clos-emf-named
)
479 (defmethod clos-emf-named-test ((x symbol
)) x
)
480 (defmethod clos-emf-named-test :before
(x) (assert x
))
481 (clos-emf-named-test nil
))))
482 '(((sb-pcl::emf clos-emf-named-test
) ? ? nil
)))))
484 (with-test (:name
:bug-310173
)
486 (let* ((names '(a b
))
487 (req (loop repeat n collect
(pop names
))))
489 `(lambda (,@req
&rest rest
)
490 (let ((* *)) ; no tail-call
491 (apply '/ ,@req rest
)))))))
493 (verify-backtrace (lambda ()
494 (funcall (make-fun 0) 10 11 0))
495 `((sb-kernel:two-arg-
/ 10/11 0)
497 ((lambda (&rest rest
) :in
,*p
*) 10 11 0))))
499 (verify-backtrace (lambda ()
500 (funcall (make-fun 1) 10 11 0))
501 `((sb-kernel:two-arg-
/ 10/11 0)
503 ((lambda (a &rest rest
) :in
,*p
*) 10 11 0))))
505 (verify-backtrace (lambda ()
506 (funcall (make-fun 2) 10 11 0))
507 `((sb-kernel:two-arg-
/ 10/11 0)
509 ((lambda (a b
&rest rest
) :in
,*p
*) 10 11 0))))))
516 (defun trace-fact (n)
519 (* n
(trace-fact (1- n
)))))
521 (with-test (:name
(trace :simple
))
522 (let ((out (with-output-to-string (*trace-output
*)
524 (assert (eq 'ok
(trace-this)))
526 (assert (search "TRACE-THIS" out
))
527 (assert (search "returned OK" out
))))
530 ;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
531 ;;; suspicions that the breakpoint trace might corrupt the whole image
532 ;;; on that platform.
533 (with-test (:name
(trace :encapsulate nil
)
534 :fails-on
'(or (and :ppc
(not :linux
)) :sparc
:mips
)
535 :broken-on
'(or :darwin
:sunos
))
536 (let ((out (with-output-to-string (*trace-output
*)
537 (trace trace-this
:encapsulate nil
)
538 (assert (eq 'ok
(trace-this)))
540 (assert (search "TRACE-THIS" out
))
541 (assert (search "returned OK" out
))))
543 (with-test (:name
(:trace-recursive
:encapsulate nil
)
544 :fails-on
'(or (and :ppc
(not :linux
)) :sparc
:mips
:sunos
)
545 :broken-on
'(or :darwin
(and :x86
:sunos
)))
546 (let ((out (with-output-to-string (*trace-output
*)
547 (trace trace-fact
:encapsulate nil
)
548 (assert (= 120 (trace-fact 5)))
550 (assert (search "TRACE-FACT" out
))
551 (assert (search "returned 1" out
))
552 (assert (search "returned 120" out
))))
554 (defun trace-and-fmakunbound-this (x)
557 (with-test (:name
:bug-667657
)
558 (trace trace-and-fmakunbound-this
)
559 (fmakunbound 'trace-and-fmakunbound-this
)
561 (assert (not (trace))))
563 (with-test (:name
:bug-414
)
564 (handler-bind ((warning #'error
))
565 (load (compile-file "bug-414.lisp"))
566 (disassemble 'bug-414
)))
568 ;; A known function can be stored as a code constant in lieu of the
569 ;; usual mode of storing an #<fdefn> and looking up the function from it.
570 ;; One such usage occurs with TAIL-CALL-VARIABLE (e.g. via APPLY).
571 ;; Show that declaring the function locally notinline uses the #<fdefn>
572 ;; by first compiling a call that would have elided the #<fdefn>
574 (defun test-compile-then-load (filename junk
)
575 (declare (notinline compile-file load
))
576 (apply 'load
(apply 'compile-file filename junk
) junk
))
577 (compile 'test-compile-then-load
)
578 (with-test (:name
:traceable-known-fun
)
579 (let ((s (make-string-output-stream)))
580 (trace compile-file load
)
581 (let ((*trace-output
* s
))
582 (test-compile-then-load "bug-414.lisp" nil
))
584 (assert (>= (count #\Newline
(get-output-stream-string s
)) 4))))
586 (with-test (:name
:bug-310175
:fails-on
'(not :stack-allocatable-lists
))
587 ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
588 ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS. Therefore,
589 ;; use two-arg-LIST, which should get through to VOP LIST, and thus
590 ;; stack-allocate on a predictable set of machines.
591 (let ((dx-arg (list t t
)))
592 (declare (dynamic-extent dx-arg
))
593 (flet ((dx-arg-backtrace (x)
594 (declare (optimize (debug 2)))
595 (prog1 (sb-debug:list-backtrace
:count
10)
596 (assert (sb-debug::stack-allocated-p x
)))))
597 (declare (notinline dx-arg-backtrace
))
598 (assert (member-if (lambda (frame)
601 (equal '(flet dx-arg-backtrace
:in
) (butlast (car frame
)))
602 (notany #'sb-debug
::stack-allocated-p
(cdr frame
))))
603 (dx-arg-backtrace dx-arg
))))))
605 (with-test (:name
:bug-795245
)
613 (sb-debug:print-backtrace
:count
100
614 :stream
(make-broadcast-stream))
616 (throw 'done
:error
))
618 (throw 'done
:ok
))))))
619 (apply '/= nil
1 2 nil
))))))
621 ;;;; test infinite error protection
623 (defmacro nest-errors
(n-levels error-form
)
625 `(handler-bind ((error (lambda (condition)
626 (declare (ignore condition
))
628 (nest-errors ,(1- n-levels
) ,error-form
))
631 (defun erroring-debugger-hook (condition old-debugger-hook
)
632 (let ((*debugger-hook
* old-debugger-hook
))
633 (format t
"recursive condition: ~A~%" condition
) (force-output)
634 (error "recursive condition: ~A" condition
)))
636 (defun test-infinite-error-protection ()
637 ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
638 ;; to halt, it produces so much garbage that's hard to suppress that
639 ;; it is tested only once
640 (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
641 (let ((*debugger-hook
* #'erroring-debugger-hook
))
643 (let ((error-counter 0)
644 (*terminal-io
* (make-broadcast-stream)))
648 (catch 'sb-impl
::toplevel-catcher
649 (nest-errors 20 (error "infinite error ~s"
650 (incf error-counter
)))
652 (write-line "--END OF H-B-A-B--"))
654 (with-test (:name
:infinite-error-protection
)
656 (test-infinite-error-protection))
658 (with-test (:name
(:infinite-error-protection
:thread
)
659 :skipped-on
'(not :sb-thread
))
661 (let ((thread (sb-thread:make-thread
#'test-infinite-error-protection
)))
662 (loop while
(sb-thread:thread-alive-p thread
))))
664 ;; unconditional, in case either previous left it enabled
667 ;;;; test some limitations of MAKE-LISP-OBJ
669 ;;; Older GENCGC systems had a bug in the pointer validation used by
670 ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
672 (with-test (:name
(:make-lisp-obj
:simple-funs
))
673 (sb-sys:without-gcing
674 (assert (eq #'identity
675 (sb-kernel:make-lisp-obj
676 (sb-kernel:get-lisp-obj-address
679 ;;; Older CHENEYGC systems didn't perform any real pointer validity
680 ;;; checks beyond "is this pointer to somewhere in heap space".
681 (with-test (:name
(:make-lisp-obj
:pointer-validation
))
682 ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
683 ;; address, but we also need the GC to not pitch a fit if it sees an
684 ;; object with said bogus address. Thus, construct our known-bogus
685 ;; object within an area of unboxed storage (a vector) in static
686 ;; space. We'll make it a simple object, (CONS 0 0), which has an
687 ;; in-memory representation of two consecutive zero words. We
688 ;; allocate a three-word vector so that we can guarantee a
689 ;; double-word aligned double-word of zeros no matter what happens
690 ;; with the vector-data-offset (currently double-word aligned).
691 (let* ((memory (sb-int:make-static-vector
3 :element-type
`(unsigned-byte ,sb-vm
:n-word-bits
)
693 (vector-data-address (sb-sys:sap-int
(sb-kernel::vector-sap memory
)))
694 (object-base-address (logandc2 (+ vector-data-address sb-vm
:lowtag-mask
) sb-vm
:lowtag-mask
))
695 (object-tagged-address (+ object-base-address sb-vm
:list-pointer-lowtag
)))
696 (multiple-value-bind (object valid-p
)
697 (sb-kernel:make-lisp-obj object-tagged-address nil
)
698 (declare (ignore object
))
699 (assert (not valid-p
)))))
701 (defun test-debugger (control form
&rest targets
)
702 (let ((out (make-string-output-stream))
706 (with-simple-restart (debugger-test-done! "Debugger Test Done!")
707 (let* ((*debug-io
* (make-two-way-stream
708 (make-string-input-stream control
)
709 (make-broadcast-stream out
#+nil
*standard-output
*)))
710 ;; Initial announcement goes to *ERROR-OUTPUT*
711 (*error-output
* *debug-io
*)
712 (*invoke-debugger-hook
* nil
))
713 (handler-bind ((error #'invoke-debugger
))
717 (error "Uncontrolled unwind from debugger test.")))
718 ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
719 ;; it could swallow our asserts!
720 (with-input-from-string (s (get-output-stream-string out
))
721 (loop for line
= (read-line s nil
)
725 (format *error-output
* "Got: ~A~%" line
)
726 (let ((match (pop targets
)))
728 ;; Whatever, till the next line matches.
729 (let ((text (pop targets
)))
731 (format *error-output
* "Looking for: ~A~%" text
)
732 (unless (search text line
)
734 (push match targets
)))
735 (unless (search match line
)
736 (format *error-output
* "~&Wanted: ~S~% Got: ~S~%" match line
)
738 ;; Check that we saw everything we wanted
740 (error "Missed: ~S" targets
))
741 (assert (not oops
))))
743 (with-test (:name
(:debugger
:source
1))
749 (defun this-will-break (x)
750 (declare (optimize debug
))
762 "(THIS-WILL-BREAK 1)"
767 (with-test (:name
(:debugger
:source
2))
772 `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
773 (let ((f #'(lambda (x cont
)
774 (print x
(make-broadcast-stream))
777 (funcall cont
(1- x
) cont
)))))
784 "source: (ERROR \"~%foo\")"
788 "(FUNCALL CONT (1- X) CONT)"
791 (with-test (:name
(disassemble :high-debug-eval
))
792 (eval `(defun this-will-be-disassembled (x)
793 (declare (optimize debug
))
795 (let* ((oopses (make-string-output-stream))
797 (let ((*error-output
* oopses
))
798 (with-output-to-string (*standard-output
*)
799 (disassemble 'this-will-be-disassembled
)))))
800 (with-input-from-string (s disassembly
)
801 (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
803 (let ((problems (get-output-stream-string oopses
)))
804 (unless (zerop (length problems
))
807 (defun this-too-will-be-disasssembled (x)
808 (declare (optimize debug
))
811 (with-test (:name
(disassemble :high-debug-load
))
812 (let* ((oopses (make-string-output-stream))
814 (let ((*error-output
* oopses
))
815 (with-output-to-string (*standard-output
*)
816 (disassemble 'this-too-will-be-disasssembled
)))))
817 (with-input-from-string (s disassembly
)
818 (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
820 (let ((problems (get-output-stream-string oopses
)))
821 (unless (zerop (length problems
))
824 ;; The test named :GF-dispatch-backtrace depends on the fact that renaming
825 ;; a closure works, and that the debugger can extract a closure name.
826 ;; First things first: verify that a closure can be named.
827 (defun make-adder (x)
828 (sb-impl::set-closure-name
(lambda (y) (+ x y
)) `(adder ,x
)))
829 (with-test (:name
:closure-renaming-really-works
)
830 (let ((f1 (make-adder 5))
831 (expect "#<CLOSURE (ADDER 5)"))
832 (assert (= (mismatch (write-to-string (make-adder 5)) expect
)
834 (assert (and (eq (sb-impl::set-closure-name f1
"ADD5") f1
)
835 (string= (sb-impl::%fun-name f1
) "ADD5")))))
837 (defgeneric gf-dispatch-test
/gf
(x y
)
840 (defun gf-dispatch-test/f
(z)
841 (gf-dispatch-test/gf z
))
843 (with-test (:name
:gf-dispatch-backtrace
)
845 (gf-dispatch-test/gf
1 1)
846 ;; Wrong argument count
847 (assert (verify-backtrace (lambda () (gf-dispatch-test/f
42))
848 '(((sb-pcl::gf-dispatch gf-dispatch-test
/gf
) 42)))))
850 (with-test (:name
(:xep-arglist-clean-up
:bug-1192929
))
853 (handler-bind ((error (lambda (e)
855 (return (< (length (car (sb-debug:backtrace-as-list
1))) 10)))))
856 (funcall (compile nil
`(lambda (i) (declare ((mod 65536) i
)) i
)) nil
)))))
860 (defun print-backtrace-to-string/debug-print-variable-alist
(x)
862 (with-output-to-string (stream)
863 (let ((*debug-print-variable-alist
* '((*print-length
* .
5)
864 (*print-level
* .
3))))
865 (sb-debug:print-backtrace
:stream stream
:count
5)))
866 x
)) ; Force use of X to prevent flushing
868 (with-test (:name
(:print-frame-call
:respect
*debug-print-variable-alist
*
869 *print-length
* :bug-1261646
))
870 (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
(make-array 200)))
871 (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
872 (position (+ (search call printed
) (length call
))))
873 (assert (eql position
(search "#(0 0 0 0 0 ...)" printed
:start2 position
)))))
875 (with-test (:name
(:print-frame-call
:respect
*debug-print-variable-alist
*
876 *print-level
* :bug-1261646
))
877 (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
879 (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
880 (position (+ (search call printed
) (length call
))))
881 (assert (eql position
(search "((#))" printed
:start2 position
)))))
887 (with-test (:name
:trace-debug-arg
)
888 (trace foo
:print-after
(setf *x
* (sb-debug:arg
0)))
892 (trace foo
:print
(setf *x
* (sb-debug:arg
0)))
896 (trace foo
:condition
(eql (setf *x
* (sb-debug:arg
0)) 0))
900 (trace foo
:condition-after
(setf *x
* (sb-debug:arg
0)))
904 (trace foo
:break
(and (setf *x
* (sb-debug:arg
0)) nil
))
908 (trace foo
:break-all
(and (setf *x
* (sb-debug:arg
0)) nil
))
911 (trace foo
:break-after
(and (setf *x
* (sb-debug:arg
0)) nil
))
914 (defun frobbleize (arg) (sb-debug:print-backtrace
) 'win
)
915 (defmethod low-debug-method ((self t
))
916 (declare (optimize (debug 0)))
917 (frobbleize 'me
) ; make this not a tail call, so it remains on stack
919 (with-test (:name
:clean-fast-method-frame-lossage
)
920 (low-debug-method 42)) ; no need to assert. it either crashes or doesn't
922 (defun return-65535 ()
925 (with-test (:name
:indirect-closure-values
)
928 (handler-bind ((error (lambda (c)
930 (sb-debug::map-backtrace
932 (let ((sb-debug::*current-frame
* frame
)
933 (name (sb-debug::frame-call frame
)))
934 (when (or (eq name
'test
)
936 (or (eql (search '(labels f1
) name
) 0)
937 (eql (search '(labels f2
) name
) 0))))
939 (assert (eql (var 'a
) 2))))))
943 `(sb-int:named-lambda test
()
944 (declare (optimize debug
))
953 (assert (= count
3))))
955 (with-test (:name
:indirect-closure-values
.2)
958 (handler-bind ((error (lambda (c)
960 (sb-debug::map-backtrace
962 (let ((sb-debug::*current-frame
* frame
)
963 (name (sb-debug::frame-call frame
)))
964 (when (or (eq name
'test
)
966 (or (eql (search '(labels f1
) name
) 0)
967 (eql (search '(labels f2
) name
) 0))))
969 (assert (eql (var 'a
) 65535))))))
973 `(sb-int:named-lambda test
()
974 (declare (optimize debug
))
975 (let ((a (return-65535)))
976 (declare ((unsigned-byte 16) a
))
984 (assert (= count
3))))
986 (with-test (:name
:non-tail-self-call-bad-variables
)
989 (handler-bind ((error (lambda (c)
991 (sb-debug::map-backtrace
993 (let ((sb-debug::*current-frame
* frame
))
994 (multiple-value-bind (name args
)
995 (sb-debug::frame-call frame
)
996 (when (eq name
'test
)
997 (assert (or (null args
)
998 (equal args
'(nil))))
1002 (compile nil
`(sb-int:named-lambda test
(&optional x
)
1003 (declare (optimize sb-c
::recognize-self-calls
))
1004 (signal 'error
:format-control
"~a" :format-arguments
(list x
))
1007 (assert (= count
1))))
1009 (with-test (:name
:local-tail-call
)
1010 (assert (verify-backtrace
1011 (lambda () (funcall (compile nil
`(sb-int:named-lambda test
()
1014 (declare (notinline tail
))
1018 (with-test (:name
:local-tail-call-variables
)
1021 (handler-bind ((error (lambda (c)
1022 (declare (ignore c
))
1023 (sb-debug::map-backtrace
1025 (let ((sb-debug::*current-frame
* frame
))
1026 (multiple-value-bind (name args
)
1027 (sb-debug::frame-call frame
)
1028 (when (eq name
'test
)
1029 (assert (equal args
'(error)))
1033 (compile nil
`(sb-int:named-lambda test
(x)
1035 ;; If :local-tail-call fails, this will fail
1036 ;; too, because there's no jump between
1037 ;; SIGNAL and the call to TAIL and it will
1038 ;; show (flet tail) in the backtrace.
1040 (declare (notinline tail
))
1043 (assert (= count
1))))
1045 (with-test (:name
:variables-surrounding-inlined-code
)
1048 (handler-bind ((error (lambda (c)
1049 (declare (ignore c
))
1050 (sb-debug::map-backtrace
1052 (let ((sb-debug::*current-frame
* frame
))
1053 (multiple-value-bind (name)
1054 (sb-debug::frame-call frame
)
1055 (when (eq name
'test
)
1056 (assert (equal (sb-debug:var
'l
) '(1 2 3)))
1060 (compile nil
`(sb-int:named-lambda test
(a i
)
1061 (declare (optimize (debug 3)))
1062 (let ((l (list 1 2 3)))
1066 (assert (= count
1))))
1068 (with-test (:name
:variables-surrounding-inlined-code
.2)
1071 (handler-bind ((error (lambda (c)
1072 (declare (ignore c
))
1073 (sb-debug::map-backtrace
1075 (let ((sb-debug::*current-frame
* frame
))
1076 (multiple-value-bind (name)
1077 (sb-debug::frame-call frame
)
1078 (when (eq name
'test
)
1079 (assert (equal (sb-debug:var
'l
) '(1 2 3)))
1083 (compile nil
`(sb-int:named-lambda test
(c)
1084 (declare (optimize (debug 3)))
1085 (let ((l (list 1 2 3)))
1086 (map 'list
#'signal c
)
1089 (assert (= count
1))))