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:exit :code 104))
  21
  22 \f
  23 ;;;; Check that we get debug arglists right.
  24
  25 (defvar *p* (namestring *load-truename*))
  26
  27 ;;; FIXME: This should use some get-argslist like functionality that
  28 ;;; we actually export.
  29 ;;;
  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
  42     ;;
  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)
  48     (t
  49      #+sb-eval
  50      (if (typep fun 'sb-eval::interpreted-function)
  51          (sb-eval::interpreted-function-lambda-list fun)
  52          :unknown)
  53      #-sb-eval
  54      :unknown)))
  55
  56 (defun zoop (zeep &key beep)
  57   blurp)
  58 (assert (equal (get-arglist #'zoop) '(zeep &key beep)))
  59
  60 ;;; Check some predefined functions too.
  61 ;;;
  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))))
  78
  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))
  87                     t)
  88                    ((endp want)
  89                     (endp real))
  90                    ((or (eq '? (car want)) (equal (car want) (car real)))
  91                     (args-equal (cdr want) (cdr real)))
  92                    (t
  93                     nil))))
  94     (let ((result nil))
  95       (block outer-handler
  96         (handler-bind
  97             ((error (lambda (condition)
  98                       ;; find the part of the backtrace we're interested in
  99                       (let (full-backtrace)
 100                         (sb-debug::map-backtrace
 101                          (lambda (frame)
 102                            (multiple-value-bind (name args info)
 103                                (sb-debug::frame-call frame #+nil #+nil
 104                                                            :replace-dynamic-extent-objects t)
 105                              (if details
 106                                  (push (list (cons name args) info) full-backtrace)
 107                                  (push (cons name args) full-backtrace)))))
 108
 109                         (setf full-backtrace (nreverse full-backtrace))
 110                         (let ((backtrace (if details
 111                                              (member (caaar frame-specs)
 112                                                      full-backtrace
 113                                                      :key #'caar
 114                                                      :test #'equal)
 115                                              (member (caar frame-specs)
 116                                                      full-backtrace
 117                                                      :key #'car
 118                                                      :test #'equal))))
 119
 120                           (setf result condition)
 121
 122                           (unless backtrace
 123                             (format t "~&//~S not in backtrace:~%   ~S~%"
 124                                     (caar frame-specs)
 125                                     full-backtrace)
 126                             (setf result nil))
 127                           ;; check that we have all the frames we wanted
 128                           (mapcar
 129                            (lambda (spec frame)
 130                              (unless (or (not spec)
 131                                          (if details
 132                                              (handler-case
 133                                                  (and (args-equal (car spec)
 134                                                                   (car frame))
 135                                                       (equal (cdr spec) (cdr frame)))
 136                                                (error (e)
 137                                                  (print (list :spec spec :frame frame))
 138                                                  (error e)))
 139                                              (and (equal (car spec) (car frame))
 140                                                   (args-equal (cdr spec)
 141                                                               (cdr frame)))))
 142                                (print (list :wanted spec :got frame))
 143                                (setf result nil)))
 144                            frame-specs
 145                            backtrace)
 146
 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))
 154                                         backtrace
 155                                         :test #'equal)
 156                             (print (list :backtrace-stunted backtrace))
 157                             (setf result nil))
 158                           (return-from outer-handler))))))
 159           (funcall test-function)))
 160       result)))
 161
 162 (defvar *undefined-function-frame*
 163   ;; bug 353
 164   '("undefined function"))
 165
 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.)
 170 (flet ((optimized ()
 171          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 172          (#:undefined-function 42))
 173        (not-optimized ()
 174          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 175          (#:undefined-function 42))
 176        (test (fun)
 177          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 178          (funcall fun)))
 179
 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)))))
 190
 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))))))
 199
 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
 205              (lambda ()
 206               (sb-thread:with-mutex (m)
 207                 (handler-bind ((timeout (lambda (c)
 208                                           (error "foo"))))
 209                   (with-timeout 0.1
 210                     (sb-thread:condition-wait q m)))))
 211             `((sb-thread:condition-wait ,q ,m :timeout nil))))))
 212
 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
 219 ;;; Sparc.
 220 ;;;
 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.
 225 (flet ((optimized ()
 226          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 227          (/ 42 0))
 228        (not-optimized ()
 229          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 230          (/ 42 0))
 231        (test (fun)
 232          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 233          (funcall fun)))
 234   (with-test (:name (:divide-by-zero :bug-346)
 235               :fails-on :alpha)  ; bug 346
 236     (assert (verify-backtrace (lambda () (test #'optimized))
 237                               (list '(/ 42 &rest)
 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))
 242                               (list '(/ 42 &rest)
 243                                     `((flet not-optimized :in ,*p*))
 244                                     (list `(flet test :in ,*p*) #'not-optimized))))))
 245
 246 (with-test (:name (:throw :no-such-tag)
 247             :fails-on '(or
 248                         (and :sparc :linux)
 249                         :alpha
 250                         :mips))
 251   (progn
 252     (defun throw-test ()
 253       (throw 'no-such-tag t))
 254     (assert (verify-backtrace #'throw-test '((throw-test))))))
 255
 256 (defun bug-308926 (x)
 257   (let ((v "foo"))
 258     (flet ((bar (z)
 259              (oops v z)
 260              (oops z v)))
 261       (bar x)
 262       (bar v))))
 263
 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)))))
 268
 269 ;;; Test backtrace through assembly routines
 270 ;;; :bug-800343
 271 (macrolet ((test (predicate fun
 272                     &optional (two-arg
 273                                (find-symbol (format nil "TWO-ARG-~A" fun)
 274                                             "SB-KERNEL")))
 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
 278                            (list (,fun x y))))
 279                     (with-test (:name (:bug-800343 ,fun))
 280                       (assert (verify-backtrace
 281                                (lambda ()
 282                                  (eval `(funcall ,#',test-name 42 t)))
 283                                '((,two-arg 42 t)
 284                                  #+(or x86 x86-64)
 285                                  ,@(and predicate
 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)
 290                                    (if (consp function)
 291                                        `(test t ,@function)
 292                                        `(test t ,function)))
 293                                  functions)))
 294              (test-functions (&rest functions)
 295                `(progn ,@(mapcar (lambda (function)
 296                                    (if (consp function)
 297                                        `(test nil ,@function)
 298                                        `(test nil ,function)))
 299                                  functions))))
 300     (test-predicates = < >)
 301     (test-functions + - * /
 302                     gcd lcm
 303                     (logand sb-kernel:two-arg-and)
 304                     (logior sb-kernel:two-arg-ior)
 305                     (logxor sb-kernel:two-arg-xor)))
 306
 307 ;;; test entry point handling in backtraces
 308
 309 (defun oops ()
 310   (error "oops"))
 311
 312 (with-test (:name :xep-too-many-arguments)
 313   (assert (verify-backtrace (lambda () (oops 1 2 3 4 5 6))
 314                             '((oops ? ? ? ? ? ?)))))
 315
 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.
 321   `(funcall
 322     (compile nil
 323              '(lambda ()
 324                (progn
 325                  ;; normal debug info
 326                  (defun ,(intern (format nil "BT.~A.1" n)) ,ll
 327                    ,@body)
 328                  ;; no arguments saved
 329                  (defun ,(intern (format nil "BT.~A.2" n)) ,ll
 330                    (declare (optimize (debug 1) (speed 3)))
 331                    ,@body)
 332                  ;; no lambda-list saved
 333                  (defun ,(intern (format nil "BT.~A.3" n)) ,ll
 334                    (declare (optimize (debug 0)))
 335                    ,@body))))))
 336
 337 (defbt 1 (&key key)
 338   (list key))
 339
 340 (defbt 2 (x)
 341   (list x))
 342
 343 (defbt 3 (&key (key (oops)))
 344   (list key))
 345
 346 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
 347 (defbt 4 (&optional opt)
 348   (list (error "error")))
 349
 350 (defbt 5 (&optional (opt (oops)))
 351   (list opt))
 352
 353 (defun bug-354 (x)
 354   (error "XEPs in backtraces: ~S" x))
 355
 356 (with-test (:name :bug-354)
 357   (assert (not (verify-backtrace (lambda () (bug-354 354))
 358                                  '((bug-354 354)
 359                                    (((bug-354 &rest) (:tl :external)) 354)))))
 360   (assert (verify-backtrace (lambda () (bug-354 354)) '((bug-354 354)))))
 361
 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)))
 366                             :details t))
 367   (assert (verify-backtrace #'namestring
 368                             '((namestring)))))
 369
 370 (with-test (:name (:backtrace :more-processor))
 371   (assert (verify-backtrace (lambda () (bt.1.1 :key))
 372                             '(((bt.1.1 :key) (:more :optional)))
 373                             :details t))
 374   (assert (verify-backtrace (lambda () (bt.1.2 :key))
 375                             '(((bt.1.2 ?) (:more :optional)))
 376                             :details t))
 377   (assert (verify-backtrace (lambda () (bt.1.3 :key))
 378                             '(((bt.1.3 &rest) (:more :optional)))
 379                             :details t))
 380   (assert (verify-backtrace (lambda () (bt.1.1 :key))
 381                             '((bt.1.1 :key))))
 382   (assert (verify-backtrace (lambda () (bt.1.2 :key))
 383                             '((bt.1.2 &rest))))
 384   (assert (verify-backtrace (lambda () (bt.1.3 :key))
 385                             '((bt.1.3 &rest)))))
 386
 387 (with-test (:name (:backtrace :xep))
 388   (assert (verify-backtrace #'bt.2.1
 389                             '(((bt.2.1) (:external)))
 390                             :details t))
 391   (assert (verify-backtrace #'bt.2.2
 392                             '(((bt.2.2 &rest) (:external)))
 393                             :details t))
 394   (assert (verify-backtrace #'bt.2.3
 395                             '(((bt.2.3 &rest) (:external)))
 396                             :details t))
 397   (assert (verify-backtrace #'bt.2.1
 398                             '((bt.2.1))))
 399   (assert (verify-backtrace #'bt.2.2
 400                             '((bt.2.2 &rest))))
 401   (assert (verify-backtrace #'bt.2.3
 402                             '((bt.2.3 &rest)))))
 403
 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
 406 ;;; main lambda.
 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
 411                             '((bt.3.2 :key ?))))
 412   (assert (verify-backtrace #'bt.3.3
 413                             '((bt.3.3 &rest))))
 414   (assert (verify-backtrace #'bt.3.1
 415                             '((bt.3.1 :key nil))))
 416   (assert (verify-backtrace #'bt.3.2
 417                             '((bt.3.2 :key ?))))
 418   (assert (verify-backtrace #'bt.3.3
 419                             '((bt.3.3 &rest)))))
 420
 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
 426                             '((bt.4.1 ?))))
 427   (assert (verify-backtrace #'bt.4.2
 428                             '((bt.4.2 ?))))
 429   (assert (verify-backtrace #'bt.4.3
 430                             '((bt.4.3 &rest))))
 431   (assert (verify-backtrace #'bt.4.1
 432                             '((bt.4.1 ?))))
 433   (assert (verify-backtrace #'bt.4.2
 434                             '((bt.4.2 ?))))
 435   (assert (verify-backtrace #'bt.4.3
 436                             '((bt.4.3 &rest)))))
 437
 438
 439 (with-test (:name (:backtrace :optional-processor))
 440   (assert (verify-backtrace #'bt.5.1
 441                             '(((bt.5.1) (:optional)))
 442                             :details t))
 443   (assert (verify-backtrace #'bt.5.2
 444                             '(((bt.5.2 &rest) (:optional)))
 445                             :details t))
 446   (assert (verify-backtrace #'bt.5.3
 447                             '(((bt.5.3 &rest) (:optional)))
 448                             :details t))
 449   (assert (verify-backtrace #'bt.5.1
 450                             '((bt.5.1))))
 451   (assert (verify-backtrace #'bt.5.2
 452                             '((bt.5.2 &rest))))
 453   (assert (verify-backtrace #'bt.5.3
 454                             '((bt.5.3 &rest)))))
 455
 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)))))
 463
 464 (with-test (:name :clos-slot-typecheckfun-named)
 465   (assert
 466    (verify-backtrace
 467     (lambda ()
 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)))))
 473
 474 (with-test (:name :clos-emf-named)
 475   (assert
 476    (verify-backtrace
 477     (lambda ()
 478       (eval `(progn
 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)))))
 483
 484 (with-test (:name :bug-310173)
 485   (flet ((make-fun (n)
 486            (let* ((names '(a b))
 487                   (req (loop repeat n collect (pop names))))
 488              (compile nil
 489                       `(lambda (,@req &rest rest)
 490                          (let ((* *)) ; no tail-call
 491                            (apply '/ ,@req rest)))))))
 492     (assert
 493      (verify-backtrace (lambda ()
 494                          (funcall (make-fun 0) 10 11 0))
 495                        `((sb-kernel:two-arg-/ 10/11 0)
 496                          (/ 10 11 0)
 497                          ((lambda (&rest rest) :in ,*p*) 10 11 0))))
 498     (assert
 499      (verify-backtrace (lambda ()
 500                          (funcall (make-fun 1) 10 11 0))
 501                        `((sb-kernel:two-arg-/ 10/11 0)
 502                          (/ 10 11 0)
 503                          ((lambda (a &rest rest) :in ,*p*) 10 11 0))))
 504     (assert
 505      (verify-backtrace (lambda ()
 506                          (funcall (make-fun 2) 10 11 0))
 507                        `((sb-kernel:two-arg-/ 10/11 0)
 508                          (/ 10 11 0)
 509                          ((lambda (a b &rest rest) :in ,*p*) 10 11 0))))))
 510
 511 ;;;; test TRACE
 512
 513 (defun trace-this ()
 514   'ok)
 515
 516 (defun trace-fact (n)
 517   (if (zerop n)
 518       1
 519       (* n (trace-fact (1- n)))))
 520
 521 (with-test (:name (trace :simple))
 522   (let ((out (with-output-to-string (*trace-output*)
 523                (trace trace-this)
 524                (assert (eq 'ok (trace-this)))
 525                (untrace))))
 526     (assert (search "TRACE-THIS" out))
 527     (assert (search "returned OK" out))))
 528
 529 ;;; bug 379
 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)))
 539                (untrace))))
 540     (assert (search "TRACE-THIS" out))
 541     (assert (search "returned OK" out))))
 542
 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)))
 549                (untrace))))
 550     (assert (search "TRACE-FACT" out))
 551     (assert (search "returned 1" out))
 552     (assert (search "returned 120" out))))
 553
 554 (defun trace-and-fmakunbound-this (x)
 555   x)
 556
 557 (with-test (:name :bug-667657)
 558   (trace trace-and-fmakunbound-this)
 559   (fmakunbound 'trace-and-fmakunbound-this)
 560   (untrace)
 561   (assert (not (trace))))
 562
 563 (with-test (:name :bug-414)
 564   (handler-bind ((warning #'error))
 565     (load (compile-file "bug-414.lisp"))
 566     (disassemble 'bug-414)))
 567
 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>
 573 ;; and then TRACE.
 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))
 583     (untrace)
 584     (assert (>= (count #\Newline (get-output-stream-string s)) 4))))
 585
 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)
 599                            (and (consp frame)
 600                                 (consp (car 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))))))
 604
 605 (with-test (:name :bug-795245)
 606   (assert
 607    (eq :ok
 608        (catch 'done
 609          (handler-bind
 610              ((error (lambda (e)
 611                        (declare (ignore e))
 612                        (handler-case
 613                            (sb-debug:print-backtrace :count 100
 614                                                      :stream (make-broadcast-stream))
 615                          (error ()
 616                            (throw 'done :error))
 617                          (:no-error ()
 618                            (throw 'done :ok))))))
 619            (apply '/= nil 1 2 nil))))))
 620
 621 ;;;; test infinite error protection
 622
 623 (defmacro nest-errors (n-levels error-form)
 624   (if (< 0 n-levels)
 625       `(handler-bind ((error (lambda (condition)
 626                                (declare (ignore condition))
 627                                ,error-form)))
 628         (nest-errors ,(1- n-levels) ,error-form))
 629       error-form))
 630
 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)))
 635
 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))
 642     (loop repeat 1 do
 643           (let ((error-counter 0)
 644                 (*terminal-io* (make-broadcast-stream)))
 645             (assert
 646              (not (eq
 647                    :normal-exit
 648                    (catch 'sb-impl::toplevel-catcher
 649                      (nest-errors 20 (error "infinite error ~s"
 650                                             (incf error-counter)))
 651                      :normal-exit)))))))
 652   (write-line "--END OF H-B-A-B--"))
 653
 654 (with-test (:name :infinite-error-protection)
 655   (enable-debugger)
 656   (test-infinite-error-protection))
 657
 658 (with-test (:name (:infinite-error-protection :thread)
 659                   :skipped-on '(not :sb-thread))
 660   (enable-debugger)
 661   (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
 662     (loop while (sb-thread:thread-alive-p thread))))
 663
 664 ;; unconditional, in case either previous left it enabled
 665 (disable-debugger)
 666 \f
 667 ;;;; test some limitations of MAKE-LISP-OBJ
 668
 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
 671 ;;; validate.
 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
 677                   #'identity))))))
 678
 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)
 692                                             :initial-element 0))
 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)))))
 700
 701 (defun test-debugger (control form &rest targets)
 702   (let ((out (make-string-output-stream))
 703         (oops t))
 704     (unwind-protect
 705          (progn
 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))
 714                  (eval form))))
 715            (setf oops nil))
 716       (when oops
 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)
 722             while line
 723             do (assert targets)
 724                #+nil
 725                (format *error-output* "Got: ~A~%" line)
 726                (let ((match (pop targets)))
 727                  (if (eq '* match)
 728                      ;; Whatever, till the next line matches.
 729                      (let ((text (pop targets)))
 730                        #+nil
 731                        (format *error-output* "Looking for: ~A~%" text)
 732                        (unless (search text line)
 733                          (push text targets)
 734                          (push match targets)))
 735                      (unless (search match line)
 736                        (format *error-output* "~&Wanted: ~S~%   Got: ~S~%" match line)
 737                        (setf oops t))))))
 738     ;; Check that we saw everything we wanted
 739     (when targets
 740       (error "Missed: ~S" targets))
 741     (assert (not oops))))
 742
 743 (with-test (:name (:debugger :source 1))
 744   (test-debugger
 745    "d
 746     source 0
 747     debugger-test-done!"
 748    `(progn
 749       (defun this-will-break (x)
 750                (declare (optimize debug))
 751                (let* ((y (- x x))
 752                       (z (/ x y)))
 753                  (+ x z)))
 754       (this-will-break 1))
 755    '*
 756    "debugger invoked"
 757    '*
 758    "DIVISION-BY-ZERO"
 759    "operands (1 0)"
 760    '*
 761    "INTEGER-/-INTEGER"
 762    "(THIS-WILL-BREAK 1)"
 763    "1]"
 764    "(/ X Y)"
 765    "1]"))
 766
 767 (with-test (:name (:debugger :source 2))
 768   (test-debugger
 769    "d
 770     source 0
 771     debugger-test-done!"
 772    `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
 773       (let ((f #'(lambda (x cont)
 774                    (print x (make-broadcast-stream))
 775                    (if (zerop x)
 776                        (error "~%foo")
 777                        (funcall cont (1- x) cont)))))
 778         (funcall f 10 f)))
 779    '*
 780    "debugger"
 781    '*
 782    "foo"
 783    '*
 784    "source: (ERROR \"~%foo\")"
 785    '*
 786    "(LAMBDA (X CONT)"
 787    '*
 788    "(FUNCALL CONT (1- X) CONT)"
 789    "1]"))
 790
 791 (with-test (:name (disassemble :high-debug-eval))
 792   (eval `(defun this-will-be-disassembled (x)
 793            (declare (optimize debug))
 794            (+ x x)))
 795   (let* ((oopses (make-string-output-stream))
 796          (disassembly
 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"
 802                       (read-line s))))
 803     (let ((problems (get-output-stream-string oopses)))
 804       (unless (zerop (length problems))
 805         (error problems)))))
 806
 807 (defun this-too-will-be-disasssembled (x)
 808   (declare (optimize debug))
 809   (+ x x))
 810
 811 (with-test (:name (disassemble :high-debug-load))
 812   (let* ((oopses (make-string-output-stream))
 813          (disassembly
 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"
 819                      (read-line s))))
 820     (let ((problems (get-output-stream-string oopses)))
 821       (unless (zerop (length problems))
 822         (error problems)))))
 823
 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)
 833                (length expect)))
 834     (assert (and (eq (sb-impl::set-closure-name f1 "ADD5") f1)
 835                  (string= (sb-impl::%fun-name f1) "ADD5")))))
 836
 837 (defgeneric gf-dispatch-test/gf (x y)
 838   (:method (x y)
 839     (+ x y)))
 840 (defun gf-dispatch-test/f (z)
 841   (gf-dispatch-test/gf z))
 842
 843 (with-test (:name :gf-dispatch-backtrace)
 844   ;; Fill the cache
 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)))))
 849
 850 (with-test (:name (:xep-arglist-clean-up :bug-1192929))
 851   (assert
 852    (block nil
 853      (handler-bind ((error (lambda (e)
 854                              (declare (ignore e))
 855                              (return (< (length (car (sb-debug:backtrace-as-list 1))) 10)))))
 856        (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
 857
 858 ;;; bug-1261646
 859
 860 (defun print-backtrace-to-string/debug-print-variable-alist (x)
 861   (values
 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
 867
 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)))))
 874
 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
 878                    '(((((1)))))))
 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)))))
 882
 883
 884 (defvar *x* nil)
 885 (defun foo (a) a)
 886
 887 (with-test (:name :trace-debug-arg)
 888   (trace foo :print-after (setf *x* (sb-debug:arg 0)))
 889   (foo 1)
 890   (assert (eql *x* 1))
 891
 892   (trace foo :print (setf *x* (sb-debug:arg 0)))
 893   (foo 2)
 894   (assert (eql *x* 2))
 895
 896   (trace foo :condition (eql (setf *x* (sb-debug:arg 0)) 0))
 897   (foo 3)
 898   (assert (eql *x* 3))
 899
 900   (trace foo :condition-after (setf *x* (sb-debug:arg 0)))
 901   (foo 4)
 902   (assert (eql *x* 4))
 903
 904   (trace foo :break (and (setf *x* (sb-debug:arg 0)) nil))
 905   (foo 5)
 906   (assert (eql *x* 5))
 907
 908   (trace foo :break-all (and (setf *x* (sb-debug:arg 0)) nil))
 909   (foo 6)
 910   (assert (eql *x* 6))
 911   (trace foo :break-after (and (setf *x* (sb-debug:arg 0)) nil))
 912   (foo 7))
 913
 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
 918   5)
 919 (with-test (:name :clean-fast-method-frame-lossage)
 920   (low-debug-method 42)) ; no need to assert. it either crashes or doesn't
 921
 922 (defun return-65535 ()
 923   65535)
 924
 925 (with-test (:name :indirect-closure-values)
 926   (let ((count 0))
 927     (block nil
 928       (handler-bind ((error (lambda (c)
 929                               (declare (ignore c))
 930                               (sb-debug::map-backtrace
 931                                (lambda (frame)
 932                                  (let ((sb-debug::*current-frame* frame)
 933                                        (name (sb-debug::frame-call frame)))
 934                                    (when (or (eq name 'test)
 935                                              (and (consp name)
 936                                                   (or (eql (search '(labels f1) name) 0)
 937                                                       (eql (search '(labels f2) name) 0))))
 938                                      (incf count)
 939                                      (assert (eql (var 'a) 2))))))
 940                               (return))))
 941         (funcall
 942          (compile nil
 943                   `(sb-int:named-lambda test ()
 944                      (declare (optimize debug))
 945                      (let ((a 1))
 946                        (labels
 947                            ((f1 ()
 948                               (incf a)
 949                               (signal 'error))
 950                             (f2 ()
 951                               (f1)))
 952                          (f2))))))))
 953     (assert (= count 3))))
 954
 955 (with-test (:name :indirect-closure-values.2)
 956   (let ((count 0))
 957     (block nil
 958       (handler-bind ((error (lambda (c)
 959                               (declare (ignore c))
 960                               (sb-debug::map-backtrace
 961                                (lambda (frame)
 962                                  (let ((sb-debug::*current-frame* frame)
 963                                        (name (sb-debug::frame-call frame)))
 964                                    (when (or (eq name 'test)
 965                                              (and (consp name)
 966                                                   (or (eql (search '(labels f1) name) 0)
 967                                                       (eql (search '(labels f2) name) 0))))
 968                                      (incf count)
 969                                      (assert (eql (var 'a) 65535))))))
 970                               (return))))
 971         (funcall
 972          (compile nil
 973                   `(sb-int:named-lambda test ()
 974                      (declare (optimize debug))
 975                      (let ((a (return-65535)))
 976                        (declare ((unsigned-byte 16) a))
 977                        (labels
 978                            ((f1 ()
 979                               (incf a)
 980                               (signal 'error))
 981                             (f2 ()
 982                               (f1)))
 983                          (f2))))))))
 984     (assert (= count 3))))
 985
 986 (with-test (:name :non-tail-self-call-bad-variables)
 987   (let ((count 0))
 988     (block nil
 989       (handler-bind ((error (lambda (c)
 990                               (declare (ignore c))
 991                               (sb-debug::map-backtrace
 992                                (lambda (frame)
 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))))
 999                                        (incf count))))))
1000                               (return))))
1001         (funcall
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))
1005                          (test 1)
1006                          1)))))
1007     (assert (= count 1))))
1008
1009 (with-test (:name :local-tail-call)
1010   (assert (verify-backtrace
1011            (lambda () (funcall (compile nil `(sb-int:named-lambda test ()
1012                                                (signal 'error)
1013                                                (flet ((tail ()))
1014                                                  (declare (notinline tail))
1015                                                  (tail))))))
1016            '((test)))))
1017
1018 (with-test (:name :local-tail-call-variables)
1019   (let ((count 0))
1020     (block nil
1021       (handler-bind ((error (lambda (c)
1022                               (declare (ignore c))
1023                               (sb-debug::map-backtrace
1024                                (lambda (frame)
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)))
1030                                        (incf count))))))
1031                               (return))))
1032         (funcall
1033          (compile nil `(sb-int:named-lambda test (x)
1034                          (signal 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.
1039                          (flet ((tail ()))
1040                            (declare (notinline tail))
1041                            (tail))))
1042          'error)))
1043     (assert (= count 1))))
1044
1045 (with-test (:name :variables-surrounding-inlined-code)
1046   (let ((count 0))
1047     (block nil
1048       (handler-bind ((error (lambda (c)
1049                               (declare (ignore c))
1050                               (sb-debug::map-backtrace
1051                                (lambda (frame)
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)))
1057                                        (incf count))))))
1058                               (return))))
1059         (funcall
1060          (compile nil `(sb-int:named-lambda test (a i)
1061                          (declare (optimize (debug 3)))
1062                          (let ((l (list 1 2 3)))
1063                            (aref a i)
1064                            l)))
1065          #(1) 2)))
1066     (assert (= count 1))))
1067
1068 (with-test (:name :variables-surrounding-inlined-code.2)
1069   (let ((count 0))
1070     (block nil
1071       (handler-bind ((error (lambda (c)
1072                               (declare (ignore c))
1073                               (sb-debug::map-backtrace
1074                                (lambda (frame)
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)))
1080                                        (incf count))))))
1081                               (return))))
1082         (funcall
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)
1087                            l)))
1088          '(error))))
1089     (assert (= count 1))))