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