forked from dmitryvk/sbcl-win32-threads
/
debug.impure.lisp
440 lines (390 loc) · 17 KB
/
debug.impure.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
;;;; This file is for testing debugging functionality, using
;;;; test machinery which might have side effects (e.g.
;;;; executing DEFUN).
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
(cl:in-package :cl-user)
;;; The debugger doesn't have any native knowledge of the interpreter
(when (eq sb-ext:*evaluator-mode* :interpret)
(sb-ext:quit :unix-status 104))
;;;; Check that we get debug arglists right.
;;; FIXME: This should use some get-argslist like functionality that
;;; we actually export.
;;;
;;; Return the debug arglist of the function object FUN as a list, or
;;; punt with :UNKNOWN.
(defun get-arglist (fun)
(declare (type function fun))
;; The Lisp-level type FUNCTION can conceal a multitude of sins..
(case (sb-kernel:widetag-of fun)
(#.sb-vm:simple-fun-header-widetag
(sb-kernel:%simple-fun-arglist fun))
(#.sb-vm:closure-header-widetag (get-arglist
(sb-kernel:%closure-fun fun)))
;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
;; like above, and it seems to work. -- MNA 2001-06-12
;;
;; (There might be other cases with arglist info also.
;; SIMPLE-FUN-HEADER-WIDETAG and CLOSURE-HEADER-WIDETAG just
;; happen to be the two case that I had my nose rubbed in when
;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
;; a closure. -- WHN 2001-06-05)
(t
#+sb-eval
(if (typep fun 'sb-eval::interpreted-function)
(sb-eval::interpreted-function-lambda-list fun)
:unknown)
#-sb-eval
:unknown)))
(defun zoop (zeep &key beep)
blurp)
(assert (equal (get-arglist #'zoop) '(zeep &key beep)))
;;; Check some predefined functions too.
;;;
;;; (We don't know exactly what the arguments are, e.g. the first
;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
;;; whatever. But we do know the general structure that a correct
;;; answer should have, so we can safely do a lot of checks.)
(destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
(assert (symbolp object-sym))
(assert (eql &optional-sym '&optional))
(assert (symbolp stream-sym)))
(destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
(get-arglist #'format)
(assert (symbolp dest-sym))
(assert (symbolp control-sym))
(assert (eql &rest-sym '&rest))
(assert (symbolp format-args-sym)))
;;; Check for backtraces generally being correct. Ensure that the
;;; actual backtrace finishes (doesn't signal any errors on its own),
;;; and that it contains the frames we expect, doesn't contain any
;;; "bogus stack frame"s, and contains the appropriate toplevel call
;;; and hasn't been cut off anywhere.
(defun verify-backtrace (test-function frame-specs &key (allow-stunted nil))
(labels ((args-equal (want real)
(cond ((eq '&rest (car want))
t)
((endp want)
(endp real))
((or (eq '? (car want)) (equal (car want) (car real)))
(args-equal (cdr want) (cdr real)))
(t
nil))))
(let ((result nil))
(block outer-handler
(handler-bind
((error (lambda (condition)
;; find the part of the backtrace we're interested in
(let ((backtrace (progn
;; (backtrace 13)
(member (caar frame-specs)
(sb-debug:backtrace-as-list)
:key #'car
:test #'equal))))
(setf result condition)
(unless backtrace
(print :missing-backtrace)
(setf result nil))
;; check that we have all the frames we wanted
(mapcar
(lambda (spec frame)
(unless (or (not spec)
(and (equal (car spec) (car frame))
(args-equal (cdr spec)
(cdr frame))))
(print (list :mismatch spec frame))
(setf result nil)))
frame-specs
backtrace)
;; Make sure the backtrace isn't stunted in
;; any way. (Depends on running in the main
;; thread.) FIXME: On Windows we get two
;; extra foreign frames below regular frames.
(let ((end (last backtrace #-win32 2 #+win32 4)))
(unless (equal (caar end)
'sb-impl::toplevel-init)
(print (list :backtrace-stunted (caar end)))
(setf result nil)))
(return-from outer-handler)))))
(funcall test-function)))
result)))
(defvar *undefined-function-frame*
;; bug 353
'(#+(or x86 x86-64) "bogus stack frame"
#-(or x86 x86-64) "undefined function"))
;;; Test for "undefined function" (undefined_tramp) working properly.
;;; Try it with and without tail call elimination, since they can have
;;; different effects. (Specifically, if undefined_tramp is incorrect
;;; a stunted stack can result from the tail call variant.)
(flet ((optimized ()
(declare (optimize (speed 2) (debug 1))) ; tail call elimination
(#:undefined-function 42))
(not-optimized ()
(declare (optimize (speed 1) (debug 2))) ; no tail call elimination
(#:undefined-function 42))
(test (fun)
(declare (optimize (speed 1) (debug 2))) ; no tail call elimination
(funcall fun)))
(with-test (:name (:undefined-function :bug-346)
:fails-on '(or :alpha :ppc :sparc
(and :x86-64 (or :freebsd :darwin))))
(assert (verify-backtrace
(lambda () (test #'optimized))
(list *undefined-function-frame*
(list '(flet test) #'optimized)))))
;; bug 353: This test fails at least most of the time for x86/linux
;; ca. 0.8.20.16. -- WHN
(with-test (:name (:undefined-function :bug-353)
;; This used to have fewer :fails-on features pre-0.9.16.38,
;; but it turns out that the bug was just being masked by
;; the presence of the IR1 stepper instrumentation (and
;; is thus again failing now that the instrumentation is
;; no more).
:fails-on '(or :x86 :x86-64 :alpha))
(assert (verify-backtrace
(lambda () (test #'not-optimized))
(list *undefined-function-frame*
(list '(flet not-optimized))
(list '(flet test) #'not-optimized))))))
;;; Division by zero was a common error on PPC. It depended on the
;;; return function either being before INTEGER-/-INTEGER in memory,
;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
;;; says that the Sparc backend (at least for CMUCL) inlines this, so
;;; if SBCL does the same this test is probably not good for the
;;; Sparc.
;;;
;;; Disabling tail call elimination on this will probably ensure that
;;; the return value (to the flet or the enclosing top level form) is
;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
;;; Enabling it might catch other problems, so do it anyway.
(flet ((optimized ()
(declare (optimize (speed 2) (debug 1))) ; tail call elimination
(/ 42 0))
(not-optimized ()
(declare (optimize (speed 1) (debug 2))) ; no tail call elimination
(/ 42 0))
(test (fun)
(declare (optimize (speed 1) (debug 2))) ; no tail call elimination
(funcall fun)))
(with-test (:name (:divide-by-zero :bug-346)
:fails-on '(or :alpha (and :x86-64 :darwin))) ; bug 346
(assert (verify-backtrace (lambda () (test #'optimized))
(list '(/ 42 &rest)
(list '(flet test) #'optimized)))))
(with-test (:name (:divide-by-zero :bug-356)
:fails-on '(or :alpha (and :x86-64 :darwin))) ; bug 356
(assert (verify-backtrace (lambda () (test #'not-optimized))
(list '(/ 42 &rest)
'((flet not-optimized))
(list '(flet test) #'not-optimized))))))
(with-test (:name (:throw :no-such-tag)
:fails-on '(or
(and :x86 :sunos)
(and :x86-64 :darwin)
(and :sparc :linux)
:alpha
:mips))
(progn
(defun throw-test ()
(throw 'no-such-tag t))
(assert (verify-backtrace #'throw-test '((throw-test))))))
;;; test entry point handling in backtraces
(defun oops ()
(error "oops"))
(defmacro defbt (n ll &body body)
`(progn
;; normal debug info
(defun ,(intern (format nil "BT.~A.1" n)) ,ll
,@body)
;; no arguments saved
(defun ,(intern (format nil "BT.~A.2" n)) ,ll
(declare (optimize (debug 1) (speed 3)))
,@body)
;; no lambda-list saved
(defun ,(intern (format nil "BT.~A.3" n)) ,ll
(declare (optimize (debug 0)))
,@body)))
(defbt 1 (&key key)
(list key))
(defbt 2 (x)
(list x))
(defbt 3 (&key (key (oops)))
(list key))
;;; ERROR instead of OOPS so that tail call elimination doesn't happen
(defbt 4 (&optional opt)
(list (error "error")))
(defbt 5 (&optional (opt (oops)))
(list opt))
;;; FIXME: This test really should be broken into smaller pieces
(with-test (:name (:backtrace :misc)
:fails-on '(or (and :x86 (or :sunos))
(and :x86-64 :darwin)))
(macrolet ((with-details (bool &body body)
`(let ((sb-debug:*show-entry-point-details* ,bool))
,@body)))
;; TL-XEP
(print :tl-xep)
(with-details t
(assert (verify-backtrace #'namestring
'(((sb-c::tl-xep namestring) 0 ?)))))
(with-details nil
(assert (verify-backtrace #'namestring
'((namestring)))))
;; &MORE-PROCESSOR
(with-details t
(assert (verify-backtrace (lambda () (bt.1.1 :key))
'(((sb-c::&more-processor bt.1.1) &rest))))
(assert (verify-backtrace (lambda () (bt.1.2 :key))
'(((sb-c::&more-processor bt.1.2) &rest))))
(assert (verify-backtrace (lambda () (bt.1.3 :key))
'(((sb-c::&more-processor bt.1.3) &rest)))))
(with-details nil
(assert (verify-backtrace (lambda () (bt.1.1 :key))
'((bt.1.1 :key))))
(assert (verify-backtrace (lambda () (bt.1.2 :key))
'((bt.1.2 &rest))))
(assert (verify-backtrace (lambda () (bt.1.3 :key))
'((bt.1.3 &rest)))))
;; XEP
(print :xep)
(with-details t
(assert (verify-backtrace #'bt.2.1
'(((sb-c::xep bt.2.1) 0 ?))))
(assert (verify-backtrace #'bt.2.2
'(((sb-c::xep bt.2.2) &rest))))
(assert (verify-backtrace #'bt.2.3
'(((sb-c::xep bt.2.3) &rest)))))
(with-details nil
(assert (verify-backtrace #'bt.2.1
'((bt.2.1))))
(assert (verify-backtrace #'bt.2.2
'((bt.2.2 &rest))))
(assert (verify-backtrace #'bt.2.3
'((bt.2.3 &rest)))))
;; VARARGS-ENTRY
(print :varargs-entry)
(with-details t
(assert (verify-backtrace #'bt.3.1
'(((sb-c::varargs-entry bt.3.1) :key nil))))
(assert (verify-backtrace #'bt.3.2
'(((sb-c::varargs-entry bt.3.2) :key ?))))
(assert (verify-backtrace #'bt.3.3
'(((sb-c::varargs-entry bt.3.3) &rest)))))
(with-details nil
(assert (verify-backtrace #'bt.3.1
'((bt.3.1 :key nil))))
(assert (verify-backtrace #'bt.3.2
'((bt.3.2 :key ?))))
(assert (verify-backtrace #'bt.3.3
'((bt.3.3 &rest)))))
;; HAIRY-ARG-PROCESSOR
(print :hairy-args-processor)
(with-details t
(assert (verify-backtrace #'bt.4.1
'(((sb-c::hairy-arg-processor bt.4.1) ?))))
(assert (verify-backtrace #'bt.4.2
'(((sb-c::hairy-arg-processor bt.4.2) ?))))
(assert (verify-backtrace #'bt.4.3
'(((sb-c::hairy-arg-processor bt.4.3) &rest)))))
(with-details nil
(assert (verify-backtrace #'bt.4.1
'((bt.4.1 ?))))
(assert (verify-backtrace #'bt.4.2
'((bt.4.2 ?))))
(assert (verify-backtrace #'bt.4.3
'((bt.4.3 &rest)))))
;; &OPTIONAL-PROCESSOR
(print :optional-processor)
(with-details t
(assert (verify-backtrace #'bt.5.1
'(((sb-c::&optional-processor bt.5.1)))))
(assert (verify-backtrace #'bt.5.2
'(((sb-c::&optional-processor bt.5.2) &rest))))
(assert (verify-backtrace #'bt.5.3
'(((sb-c::&optional-processor bt.5.3) &rest)))))
(with-details nil
(assert (verify-backtrace #'bt.5.1
'((bt.5.1))))
(assert (verify-backtrace #'bt.5.2
'((bt.5.2 &rest))))
(assert (verify-backtrace #'bt.5.3
'((bt.5.3 &rest)))))))
;;;; test TRACE
(defun trace-this ()
'ok)
(defun trace-fact (n)
(if (zerop n)
1
(* n (trace-fact (1- n)))))
(let ((out (with-output-to-string (*trace-output*)
(trace trace-this)
(assert (eq 'ok (trace-this)))
(untrace))))
(assert (search "TRACE-THIS" out))
(assert (search "returned OK" out)))
;;; bug 379
;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
;;; suspicions that the breakpoint trace might corrupt the whole image
;;; on that platform.
#-(and (or ppc x86 x86-64) darwin)
(with-test (:name (trace :encapsulate nil)
:fails-on '(or :ppc :sparc :mips))
(let ((out (with-output-to-string (*trace-output*)
(trace trace-this :encapsulate nil)
(assert (eq 'ok (trace-this)))
(untrace))))
(assert (search "TRACE-THIS" out))
(assert (search "returned OK" out))))
#-(and (or ppc x86 x86-64) darwin)
(with-test (:name (trace-recursive :encapsulate nil)
:fails-on '(or :ppc :sparc :mips))
(let ((out (with-output-to-string (*trace-output*)
(trace trace-fact :encapsulate nil)
(assert (= 120 (trace-fact 5)))
(untrace))))
(assert (search "TRACE-FACT" out))
(assert (search "returned 1" out))
(assert (search "returned 120" out))))
;;;; test infinite error protection
(defmacro nest-errors (n-levels error-form)
(if (< 0 n-levels)
`(handler-bind ((error (lambda (condition)
(declare (ignore condition))
,error-form)))
(nest-errors ,(1- n-levels) ,error-form))
error-form))
(defun erroring-debugger-hook (condition old-debugger-hook)
(let ((*debugger-hook* old-debugger-hook))
(format t "recursive condition: ~A~%" condition) (force-output)
(error "recursive condition: ~A" condition)))
(defun test-inifinite-error-protection ()
;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
;; to halt, it produces so much garbage that's hard to suppress that
;; it is tested only once
(let ((*debugger-hook* #'erroring-debugger-hook))
(loop repeat 1 do
(let ((error-counter 0)
(*terminal-io* (make-broadcast-stream)))
(assert
(not (eq
:normal-exit
(catch 'sb-impl::toplevel-catcher
(nest-errors 20 (error "infinite error ~s"
(incf error-counter)))
:normal-exit))))))))
(enable-debugger)
(test-inifinite-error-protection)
#+sb-thread
(let ((thread (sb-thread:make-thread #'test-inifinite-error-protection)))
(loop while (sb-thread:thread-alive-p thread)))
(disable-debugger)
(write-line "/debug.impure.lisp done")