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 \f
  18 ;;;; Check that we get debug arglists right.
  19
  20 ;;; Return the debug arglist of the function object FUN as a list, or
  21 ;;; punt with :UNKNOWN.
  22 (defun get-arglist (fun)
  23   (declare (type function fun))
  24   ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
  25   (case (sb-kernel:widetag-of fun)
  26     (#.sb-vm:simple-fun-header-widetag
  27       (sb-kernel:%simple-fun-arglist fun))
  28     (#.sb-vm:closure-header-widetag (get-arglist
  29                                      (sb-kernel:%closure-fun fun)))
  30     ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
  31     ;; like above, and it seems to work. -- MNA 2001-06-12
  32     ;;
  33     ;; (There might be other cases with arglist info also.
  34     ;; SIMPLE-FUN-HEADER-WIDETAG and CLOSURE-HEADER-WIDETAG just
  35     ;; happen to be the two case that I had my nose rubbed in when
  36     ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
  37     ;; a closure. -- WHN 2001-06-05)
  38     (t :unknown)))
  39
  40 (defun zoop (zeep &key beep)
  41   blurp)
  42 (assert (equal (get-arglist #'zoop) '(zeep &key beep)))
  43
  44 ;;; Check some predefined functions too.
  45 ;;;
  46 ;;; (We don't know exactly what the arguments are, e.g. the first
  47 ;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
  48 ;;; whatever. But we do know the general structure that a correct
  49 ;;; answer should have, so we can safely do a lot of checks.)
  50 (destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
  51   (assert (symbolp object-sym))
  52   (assert (eql &optional-sym '&optional))
  53   (assert (symbolp stream-sym)))
  54 (destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
  55     (get-arglist #'format)
  56   (assert (symbolp dest-sym))
  57   (assert (symbolp control-sym))
  58   (assert (eql &rest-sym '&rest))
  59   (assert (symbolp format-args-sym)))
  60
  61 ;;; Check for backtraces generally being correct.  Ensure that the
  62 ;;; actual backtrace finishes (doesn't signal any errors on its own),
  63 ;;; and that it contains the frames we expect, doesn't contain any
  64 ;;; "bogus stack frame"s, and contains the appropriate toplevel call
  65 ;;; and hasn't been cut off anywhere.
  66 (defun verify-backtrace (test-function frame-name
  67                          &key (key #'first) (test #'eql)
  68                          (allow-bogus-frames nil))
  69   (let ((result nil)
  70         (return-value nil))
  71     (block outer-handler
  72       (handler-bind
  73           ((error #'(lambda (condition)
  74                       (let ((backtrace (ignore-errors
  75                                          (sb-debug:backtrace-as-list))))
  76                         ;; Make sure we find what we're looking for.
  77                         (if (member frame-name backtrace :key key :test test)
  78                             (setf result (list :error condition))
  79                             (print (list :failed :frame frame-name :backtrace backtrace)))
  80                         ;; Make sure there's no bogus stack frames
  81                         ;; unless they're explicitly allowed.
  82                         (when (and (not allow-bogus-frames)
  83                                    (member "bogus stack frame" backtrace
  84                                            :key #'first :test #'equal))
  85                           (print 'verify-backtrace-bogus)
  86                           (setf result nil))
  87                         ;; Make sure the backtrace isn't stunted in
  88                         ;; any way.  (Depends on running in the main
  89                         ;; thread.)
  90                         (unless (member 'sb-impl::toplevel-init backtrace
  91                                         :key #'first :test #'equal)
  92                           (print 'verify-backtrace-stunted)
  93                           (setf result nil)))
  94                       (return-from outer-handler))))
  95         (funcall test-function)))
  96     (values result return-value)))
  97
  98 ;;; Test for "undefined function" (undefined_tramp) working properly.
  99 ;;; Try it with and without tail call elimination, since they can have
 100 ;;; different effects.  (Specifically, if undefined_tramp is incorrect
 101 ;;; a stunted stack can result from the tail call variant.)
 102 #-(or alpha) ; bug 346
 103 (flet ((optimized ()
 104          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 105          (#:undefined-function 42))
 106        (not-optimized ()
 107          (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
 108          (#:undefined-function 42))
 109        (test (fun)
 110          (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
 111          (funcall fun)))
 112   #-x86 ; <- known bug (?): fails for me on 0.8.17.31/Linux/x86 -- WHN 2004-12-27
 113   (dolist (frame '(#-x86 "undefined function" ; bug 353
 114                    "FLET COMMON-LISP-USER::TEST"))
 115     (assert (verify-backtrace (lambda () (test #'optimized)) frame
 116                               :test #'equal
 117                               :allow-bogus-frames (or #+x86 t))))
 118   (dolist (frame '(#-x86 "undefined function" ; bug 353
 119                    "FLET COMMON-LISP-USER::NOT-OPTIMIZED"
 120                    "FLET COMMON-LISP-USER::TEST"))
 121     (assert (verify-backtrace (lambda () (test #'not-optimized)) frame
 122                               :test #'equal
 123                               :allow-bogus-frames (or #+x86 t)))))
 124
 125 ;;; Division by zero was a common error on PPC.  It depended on the
 126 ;;; return function either being before INTEGER-/-INTEGER in memory,
 127 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead.  It also depends on
 128 ;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE.  I believe Raymond Toy
 129 ;;; says that the Sparc backend (at least for CMUCL) inlines this, so
 130 ;;; if SBCL does the same this test is probably not good for the
 131 ;;; Sparc.
 132 ;;;
 133 ;;; Disabling tail call elimination on this will probably ensure that
 134 ;;; the return value (to the flet or the enclosing top level form) is
 135 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
 136 ;;; Enabling it might catch other problems, so do it anyway.
 137 #-alpha ; bug 346
 138 (progn
 139   (flet ((test-function ()
 140            (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 141            (/ 42 0)))
 142     (assert (verify-backtrace #'test-function '/)))
 143
 144   (flet ((test-function ()
 145            (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
 146            (/ 42 0)))
 147     (assert (verify-backtrace #'test-function '/))))
 148
 149 #-(or alpha) ; bug 61
 150 (progn
 151   (defun throw-test ()
 152     (throw 'no-such-tag t))
 153   (assert (verify-backtrace #'throw-test
 154                             #-(or x86 sparc) 'throw-test
 155                             #+(or x86 sparc) "XEP for COMMON-LISP-USER::THROW-TEST" ; bug 354
 156                             :test #'equal)))
 157
 158 ;;; success
 159 (quit :unix-status 104)