1 ;;;; This file is for testing backtraces, using test machinery which
2 ;;;; might have side effects (e.g. executing DEFUN).
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
15 (cl:in-package
:cl-user
)
17 ;;; The following objects should be EQUALP to the respective markers
18 ;;; produced by the backtrace machinery.
20 (defvar *unused-argument
*
21 (sb-debug::make-unprintable-object
"unused argument"))
23 (defvar *unavailable-argument
*
24 (sb-debug::make-unprintable-object
"unavailable argument"))
26 (defvar *unavailable-lambda-list
*
27 (sb-debug::make-unprintable-object
"unavailable lambda list"))
29 ;;; TEST-FUNCTION is called and has to signal an error at which point
30 ;;; the backtrace will be captured.
32 ;;; If DETAILS is true, the returned backtrace description is of the
35 ;;; (((NAME1 . ARGS1) INFO1)
36 ;;; ((NAME2 . ARGS2) INFO2)
39 ;;; Otherwise it is of the form
45 (defun call-with-backtrace (cont test-function
&key details
)
46 (flet ((capture-it (condition)
48 (sb-debug::map-backtrace
50 (multiple-value-bind (name args info
)
51 (sb-debug::frame-call frame
)
53 (list (cons name args
) info
)
56 (funcall cont
(nreverse backtrace
) condition
))))
57 (handler-bind ((error #'capture-it
))
58 (funcall test-function
))))
60 ;;; Check the backtrace FRAMES against the list of frame
61 ;;; specifications EXPECTED signaling an error if they do not match.
63 ;;; If DETAILS is true, EXPECTED is a list with elements of the form
65 ;;; ((FUNCTION ARGS) INFO)
67 ;;; Otherwise elements are of the form
71 ;;; ARGS is a list of expected argument values, but can also contain
72 ;;; the following symbols
74 ;;; &REST The corresponding frame in FRAMES can contain an arbitrary
75 ;;; number of arguments starting at the corresponding
78 ;;; ? The corresponding frame in FRAMES can have an arbitrary
79 ;;; argument at the corresponding position.
80 (defun check-backtrace (frames expected
&key details
)
81 (labels ((args-equal (want actual
)
82 (cond ((eq want
*unavailable-lambda-list
*)
84 ((eq '&rest
(car want
))
88 ((or (eq '?
(car want
)) (equal (car want
) (car actual
)))
89 (args-equal (cdr want
) (cdr actual
)))
90 ((typep (car want
) 'sb-impl
::unprintable-object
)
91 (equalp (car want
) (car actual
)))
94 (fail (datum &rest arguments
)
95 (return-from check-backtrace
96 (values nil
(sb-kernel:coerce-to-condition
97 datum arguments
'simple-error
'error
)))))
98 (mapc (lambda (frame spec
)
103 (and (args-equal (car spec
)
105 (equal (cdr spec
) (cdr frame
))))
107 (and (equal (car spec
) (car frame
))
108 (args-equal (cdr spec
) (cdr frame
)))))
109 (fail "~@<Unexpected frame during ~
110 ~:[non-detailed~:;detailed~] check: wanted ~S, got ~
112 details spec frame
)))
116 ;;; Check for backtraces generally being correct. Ensure that the
117 ;;; actual backtrace finishes (doesn't signal any errors on its own),
118 ;;; and that it contains the frames we expect, doesn't contain any
119 ;;; "bogus stack frame"s, and contains the appropriate toplevel call
120 ;;; and hasn't been cut off anywhere.
122 ;;; See CHECK-BACKTRACE for an explanation of the structure
124 (defun verify-backtrace (test-function expected-frames
&key details
)
125 (labels ((find-frame (function-name frames
)
126 (member function-name frames
127 :key
(if details
#'caar
#'car
)
129 (fail (datum &rest arguments
)
130 (return-from verify-backtrace
131 (values nil
(sb-kernel:coerce-to-condition
132 datum arguments
'simple-error
'error
)))))
134 (lambda (backtrace condition
)
135 (declare (ignore condition
))
136 (let* ((test-function-name (if details
137 (caaar expected-frames
)
138 (caar expected-frames
)))
139 (frames (or (find-frame test-function-name backtrace
)
140 (fail "~@<~S (expected name ~S) not found in ~
141 backtrace:~@:_~S~@:>"
142 test-function test-function-name backtrace
))))
143 ;; Check that we have all the frames we wanted.
144 (multiple-value-bind (successp condition
)
145 (check-backtrace frames expected-frames
:details details
)
146 (unless successp
(fail condition
)))
147 ;; Make sure the backtrace isn't stunted in any way.
148 ;; (Depends on running in the main thread.) FIXME: On Windows
149 ;; we get two extra foreign frames below regular frames.
150 (unless (find-frame 'sb-impl
::toplevel-init frames
)
151 (fail "~@<Backtrace stunted:~@:_~S~@:>" backtrace
)))
152 (return-from verify-backtrace t
))
153 test-function
:details details
)))
155 (defun assert-backtrace (test-function expected-frames
&key details
)
156 (multiple-value-bind (successp condition
)
157 (verify-backtrace test-function expected-frames
:details details
)
158 (or successp
(error condition
))))
160 (defvar *p
* (namestring *load-truename
*))
162 (defvar *undefined-function-frame
*
163 '("undefined function"))
168 ;;; Test for "undefined function" (undefined_tramp) working properly.
169 ;;; Try it with and without tail call elimination, since they can have
170 ;;; different effects. (Specifically, if undefined_tramp is incorrect
171 ;;; a stunted stack can result from the tail call variant.)
173 (declare (optimize (speed 2) (debug 1))) ; tail call elimination
174 (#:undefined-function
42))
176 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
177 (#:undefined-function
42))
179 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
182 (with-test (:name
(:backtrace
:undefined-function
:bug-346
)
183 :skipped-on
:interpreter
184 ;; Failures on SPARC, and probably HPPA are due to
185 ;; not having a full and valid stack frame for the
186 ;; undefined function frame. See PPC
187 ;; undefined_tramp for details.
188 :fails-on
'(or :sparc
))
190 (lambda () (test #'optimized
))
191 (list *undefined-function-frame
*
192 (list `(flet test
:in
,*p
*) #'optimized
))))
194 ;; bug 353: This test fails at least most of the time for x86/linux
195 ;; ca. 0.8.20.16. -- WHN
196 (with-test (:name
(:backtrace
:undefined-function
:bug-353
)
197 :skipped-on
:interpreter
)
199 (lambda () (test #'not-optimized
))
200 (list *undefined-function-frame
*
201 (list `(flet not-optimized
:in
,*p
*))
202 (list `(flet test
:in
,*p
*) #'not-optimized
)))))
204 (with-test (:name
(:backtrace
:interrupted-condition-wait
)
205 :skipped-on
'(not :sb-thread
))
206 (let ((m (sb-thread:make-mutex
))
207 (q (sb-thread:make-waitqueue
)))
210 (sb-thread:with-mutex
(m)
211 (handler-bind ((timeout (lambda (condition)
212 (declare (ignore condition
))
215 (sb-thread:condition-wait q m
)))))
216 `((sb-thread:condition-wait
,q
,m
:timeout nil
)))))
218 ;;; Division by zero was a common error on PPC. It depended on the
219 ;;; return function either being before INTEGER-/-INTEGER in memory,
220 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
221 ;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
222 ;;; says that the Sparc backend (at least for CMUCL) inlines this, so
223 ;;; if SBCL does the same this test is probably not good for the
226 ;;; Disabling tail call elimination on this will probably ensure that
227 ;;; the return value (to the flet or the enclosing top level form) is
228 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
229 ;;; Enabling it might catch other problems, so do it anyway.
231 (declare (optimize (speed 2) (debug 1))) ; tail call elimination
234 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
237 (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
240 (with-test (:name
(:backtrace
:divide-by-zero
:bug-346
)
241 :skipped-on
:interpreter
)
242 (assert-backtrace (lambda () (test #'optimized
))
244 ((flet test
:in
,*p
*) ,#'optimized
))))
246 (with-test (:name
(:backtrace
:divide-by-zero
:bug-356
)
247 :skipped-on
:interpreter
)
248 (assert-backtrace (lambda () (test #'not-optimized
))
250 ((flet not-optimized
:in
,*p
*))
251 ((flet test
:in
,*p
*) ,#'not-optimized
)))))
254 (throw 'no-such-tag t
))
255 (with-test (:name
(:backtrace
:throw
:no-such-tag
)
256 :fails-on
'(and :sparc
:linux
))
257 (assert-backtrace #'throw-test
'((throw-test))))
259 (funcall (checked-compile
261 (defun bug-308926 (x)
268 :allow-style-warnings t
))
269 (with-test (:name
(:backtrace
:bug-308926
) :skipped-on
:interpreter
)
270 (assert-backtrace (lambda () (bug-308926 13))
271 '(((flet bar
:in bug-308926
) 13)
272 (bug-308926 &rest t
))))
274 ;;; Test backtrace through assembly routines
276 (macrolet ((test (predicate fun
278 (find-symbol (format nil
"TWO-ARG-~A" fun
)
280 (let ((test-name (make-symbol (format nil
"TEST-~A" fun
))))
281 `(flet ((,test-name
(x y
)
282 ;; make sure it's not in tail position
284 (with-test (:name
(:backtrace
:bug-800343
,fun
)
285 :skipped-on
:interpreter
)
288 (eval `(funcall ,#',test-name
42 t
)))
292 `((,(find-symbol (format nil
"GENERIC-~A" fun
) "SB-VM"))))
293 ((flet ,test-name
:in
,*p
*) 42 t
)))))))
294 (test-predicates (&rest functions
)
295 `(progn ,@(mapcar (lambda (function)
296 `(test t
,@(sb-int:ensure-list function
)))
298 (test-functions (&rest functions
)
299 `(progn ,@(mapcar (lambda (function)
300 `(test nil
,@(sb-int:ensure-list function
)))
302 (test-predicates = < >)
303 (test-functions + -
* /
305 (logand sb-kernel
:two-arg-and
)
306 (logior sb-kernel
:two-arg-ior
)
307 (logxor sb-kernel
:two-arg-xor
)))
309 ;;; test entry point handling in backtraces
311 (with-test (:name
(:backtrace
:xep-too-many-arguments
)
312 :skipped-on
:interpreter
)
313 ;; CHECKED-COMPILE avoids STYLE-WARNING noise.
314 (assert-backtrace (checked-compile '(lambda () (oops 1 2 3 4 5 6))
315 :allow-style-warnings t
)
316 '((oops ? ? ? ? ? ?
))))
318 (defmacro defbt
(n ll
&body body
)
319 ;; WTF is this? This is a way to make these tests not depend so much on the
320 ;; details of LOAD/EVAL. Around 1.0.57 we changed %SIMPLE-EVAL to be
321 ;; slightly smarter, which meant that things which used to have xeps
322 ;; suddently had tl-xeps, etc. This takes care of that.
328 (defun ,(intern (format nil
"BT.~A.1" n
)) ,ll
330 ;; no arguments saved
331 (defun ,(intern (format nil
"BT.~A.2" n
)) ,ll
332 (declare (optimize (debug 1) (speed 3)))
334 ;; no lambda-list saved
335 (defun ,(intern (format nil
"BT.~A.3" n
)) ,ll
336 (declare (optimize (debug 0)))
338 :allow-style-warnings t
)))
346 (defbt 3 (&key
(key (oops)))
349 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
350 (defbt 4 (&optional opt
)
351 (list (error "error")))
353 (defbt 5 (&optional
(opt (oops)))
356 (defbt 6 (&optional
(opt nil opt-p
))
357 (declare (ignore opt
))
358 (list (error "error ~A" opt-p
))) ; use OPT-P
360 (defbt 7 (&key
(key nil key-p
))
361 (declare (ignore key
))
362 (list (error "error ~A" key-p
))) ; use KEY-P
365 (error "XEPs in backtraces: ~S" x
))
367 (with-test (:name
(:backtrace
:bug-354
))
368 (assert (not (verify-backtrace (lambda () (bug-354 354))
370 (((bug-354 &rest
) (:tl
:external
)) 354)))))
371 (assert-backtrace (lambda () (bug-354 354)) '((bug-354 354))))
373 ;;; FIXME: This test really should be broken into smaller pieces
374 (with-test (:name
(:backtrace
:tl-xep
))
375 (assert-backtrace #'namestring
'(((namestring) (:tl
:external
))) :details t
)
376 (assert-backtrace #'namestring
'((namestring))))
378 (with-test (:name
(:backtrace
:more-processor
))
379 ;; CHECKED-COMPILE avoids STYLE-WARNING noise.
380 (assert-backtrace (checked-compile '(lambda () (bt.1.1 :key
))
381 :allow-style-warnings t
)
382 '(((bt.1.1 :key
) (:more
:optional
)))
384 (assert-backtrace (checked-compile '(lambda () (bt.1.2 :key
))
385 :allow-style-warnings t
)
386 '(((bt.1.2 ?
) (:more
:optional
)))
388 (assert-backtrace (lambda () (bt.1.3 :key
))
389 `(((bt.1.3 .
,*unavailable-lambda-list
*) (:more
:optional
)))
391 (assert-backtrace (checked-compile '(lambda () (bt.1.1 :key
))
392 :allow-style-warnings t
)
394 (assert-backtrace (checked-compile '(lambda () (bt.1.2 :key
))
395 :allow-style-warnings t
)
397 (assert-backtrace (lambda () (bt.1.3 :key
))
400 (with-test (:name
(:backtrace
:xep
))
401 (assert-backtrace #'bt
.2.1 '(((bt.2.1) (:external
))) :details t
)
402 (assert-backtrace #'bt
.2.2 '(((bt.2.2) (:external
))) :details t
)
403 (assert-backtrace #'bt
.2.3 `(((bt.2.3) (:external
))) :details t
)
404 (assert-backtrace #'bt
.2.1 '((bt.2.1)))
405 (assert-backtrace #'bt
.2.2 '((bt.2.2)))
406 (assert-backtrace #'bt
.2.3 `((bt.2.3))))
408 ;;; This test is somewhat deceptively named. Due to confusion in debug
409 ;;; naming these functions used to have sb-c::varargs-entry debug
410 ;;; names for their main lambda.
411 (with-test (:name
(:backtrace
:varargs-entry
))
412 (assert-backtrace #'bt
.3.1 '((bt.3.1 :key nil
)))
413 (assert-backtrace #'bt
.3.2 '((bt.3.2 :key ?
)))
414 (assert-backtrace #'bt
.3.3 `((bt.3.3 .
,*unavailable-lambda-list
*)))
415 (assert-backtrace #'bt
.3.1 '((bt.3.1 :key nil
)))
416 (assert-backtrace #'bt
.3.2 '((bt.3.2 :key ?
)))
417 (assert-backtrace #'bt
.3.3 `((bt.3.3 .
,*unavailable-lambda-list
*))))
419 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
420 ;;; these functions used to have sb-c::hairy-args-processor debug names for
421 ;;; their main lambda.
422 (with-test (:name
(:backtrace
:hairy-args-processor
))
423 (assert-backtrace #'bt
.4.1 '((bt.4.1 ?
)))
424 (assert-backtrace #'bt
.4.2 '((bt.4.2 ?
)))
425 (assert-backtrace #'bt
.4.3 `((bt.4.3 .
,*unavailable-lambda-list
*)))
426 (assert-backtrace #'bt
.4.1 '((bt.4.1 ?
)))
427 (assert-backtrace #'bt
.4.2 '((bt.4.2 ?
)))
428 (assert-backtrace #'bt
.4.3 `((bt.4.3 .
,*unavailable-lambda-list
*))))
430 (with-test (:name
(:backtrace
:optional-processor
))
431 (assert-backtrace #'bt
.5.1 '(((bt.5.1) (:optional
))) :details t
)
432 (assert-backtrace #'bt
.5.2 '(((bt.5.2) (:optional
))) :details t
)
433 (assert-backtrace #'bt
.5.3 `(((bt.5.3 .
,*unavailable-lambda-list
*) (:optional
)))
435 (assert-backtrace #'bt
.5.1 '((bt.5.1)))
436 (assert-backtrace #'bt
.5.2 '((bt.5.2)))
437 (assert-backtrace #'bt
.5.3 `((bt.5.3 .
,*unavailable-lambda-list
*))))
439 (with-test (:name
(:backtrace
:unused-optinoal-with-supplied-p
:bug-1498644
))
440 (assert-backtrace (lambda () (bt.6.1 :opt
))
441 `(((bt.6.1 ,*unused-argument
*) ()))
443 (assert-backtrace (lambda () (bt.6.2 :opt
))
444 `(((bt.6.2 ,*unused-argument
*) ()))
446 (assert-backtrace (lambda () (bt.6.3 :opt
))
447 `(((bt.6.3 .
,*unavailable-lambda-list
*) ()))
449 (assert-backtrace (lambda () (bt.6.1 :opt
))
450 `((bt.6.1 ,*unused-argument
*)))
451 (assert-backtrace (lambda () (bt.6.2 :opt
))
452 `((bt.6.2 ,*unused-argument
*)))
453 (assert-backtrace (lambda () (bt.6.3 :opt
))
454 `((bt.6.3 .
,*unavailable-lambda-list
*))))
456 (with-test (:name
(:backtrace
:unused-key-with-supplied-p
))
457 (assert-backtrace (lambda () (bt.7.1 :key
:value
))
458 `(((bt.7.1 :key
,*unused-argument
*) ()))
460 (assert-backtrace (lambda () (bt.7.2 :key
:value
))
461 `(((bt.7.2 :key
,*unused-argument
*) ()))
463 (assert-backtrace (lambda () (bt.7.3 :key
:value
))
464 `(((bt.7.3 .
,*unavailable-lambda-list
*) ()))
466 (assert-backtrace (lambda () (bt.7.1 :key
:value
))
467 `((bt.7.1 :key
,*unused-argument
*)))
468 (assert-backtrace (lambda () (bt.7.2 :key
:value
))
469 `((bt.7.2 :key
,*unused-argument
*)))
470 (assert-backtrace (lambda () (bt.7.3 :key
:value
))
471 `((bt.7.3 .
,*unavailable-lambda-list
*))))
473 (defvar *compile-nil-error
*
474 (checked-compile '(lambda (x)
475 (cons (when x
(error "oops")) nil
))))
476 (defvar *compile-nil-non-tc
*
477 (checked-compile '(lambda (y)
478 (cons (funcall *compile-nil-error
* y
) nil
))))
479 (with-test (:name
(:backtrace compile nil
))
480 (assert-backtrace (lambda () (funcall *compile-nil-non-tc
* 13))
481 `(((lambda (x) :in
,*p
*) 13)
482 ((lambda (y) :in
,*p
*) 13))))
484 (with-test (:name
(:backtrace
:clos-slot-typecheckfun-named
))
488 (locally (declare (optimize safety
))
489 (defclass clos-typecheck-test
()
490 ((slot :type fixnum
)))
491 (setf (slot-value (make-instance 'clos-typecheck-test
) 'slot
) t
))))
492 '(((sb-pcl::slot-typecheck fixnum
) t
))))
494 (with-test (:name
(:backtrace
:clos-emf-named
))
499 (defgeneric clos-emf-named-test
(x)
500 (:method
((x symbol
)) x
)
501 (:method
:before
(x) (assert x
)))
502 (clos-emf-named-test nil
)))
503 :allow-style-warnings t
)
504 '(((sb-pcl::emf clos-emf-named-test
) ? ? nil
))))
506 (with-test (:name
(:backtrace
:bug-310173
))
508 (let* ((names '(a b
))
509 (req (loop repeat n collect
(pop names
))))
511 `(lambda (,@req
&rest rest
)
512 (let ((* *)) ; no tail-call
513 (apply '/ ,@req rest
)))))))
514 (assert-backtrace (lambda ()
515 (funcall (make-fun 0) 10 11 0))
516 `((sb-kernel:two-arg-
/ 10/11 0)
518 ((lambda (&rest rest
) :in
,*p
*) 10 11 0)))
519 (assert-backtrace (lambda ()
520 (funcall (make-fun 1) 10 11 0))
521 `((sb-kernel:two-arg-
/ 10/11 0)
523 ((lambda (a &rest rest
) :in
,*p
*) 10 11 0)))
524 (assert-backtrace (lambda ()
525 (funcall (make-fun 2) 10 11 0))
526 `((sb-kernel:two-arg-
/ 10/11 0)
528 ((lambda (a b
&rest rest
) :in
,*p
*) 10 11 0)))))
530 (defgeneric gf-dispatch-test
/gf
(x y
)
533 (defun gf-dispatch-test/f
(z)
534 (gf-dispatch-test/gf z
))
535 (with-test (:name
(:backtrace
:gf-dispatch
))
537 (gf-dispatch-test/gf
1 1)
538 ;; Wrong argument count
539 (assert-backtrace (lambda () (gf-dispatch-test/f
42))
540 '(((sb-pcl::gf-dispatch gf-dispatch-test
/gf
) 42))))
542 (with-test (:name
(:backtrace
:local-tail-call
))
544 (lambda () (funcall (compile nil
`(sb-int:named-lambda test
()
547 (declare (notinline tail
))
551 (defun fact (n) (if (zerop n
) (error "nope") (* n
(fact (1- n
)))))
554 (with-test (:name
(:backtrace
:interpreted-factorial
)
555 :skipped-on
'(not :interpreter
))
559 (sb-interpreter::2-arg-
* &rest
)
561 (sb-interpreter::2-arg-
* &rest
)
563 (sb-interpreter::2-arg-
* &rest
)
565 (sb-interpreter::2-arg-
* &rest
)
567 (sb-interpreter::2-arg-
* &rest
)