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 (allow-stunted nil) 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                   ;; For some unfathomable reason the backtrace becomes
 203                   ;; stunted, ending at _sigtramp, when we add :TIMEOUT NIL to
 204                   ;; the frame we expect. If we leave it out, the backtrace is
 205                   ;; fine -- but the test fails. I can only boggle right now.
 206             :fails-on `(or (and :x86 :linux)
 207                            :win32))
 208   (let ((m (sb-thread:make-mutex))
 209         (q (sb-thread:make-waitqueue)))
 210     (assert (verify-backtrace
 211              (lambda ()
 212               (sb-thread:with-mutex (m)
 213                 (handler-bind ((timeout (lambda (c)
 214                                           (error "foo"))))
 215                   (with-timeout 0.1
 216                     (sb-thread:condition-wait q m)))))
 217             `((sb-thread:condition-wait ,q ,m :timeout nil))))))
 218
 219 ;;; Division by zero was a common error on PPC. It depended on the
 220 ;;; return function either being before INTEGER-/-INTEGER in memory,
 221 ;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
 222 ;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
 223 ;;; says that the Sparc backend (at least for CMUCL) inlines this, so
 224 ;;; if SBCL does the same this test is probably not good for the
 225 ;;; Sparc.
 226 ;;;
 227 ;;; Disabling tail call elimination on this will probably ensure that
 228 ;;; the return value (to the flet or the enclosing top level form) is
 229 ;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
 230 ;;; Enabling it might catch other problems, so do it anyway.
 231 (flet ((optimized ()
 232          (declare (optimize (speed 2) (debug 1))) ; tail call elimination
 233          (/ 42 0))
 234        (not-optimized ()
 235          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 236          (/ 42 0))
 237        (test (fun)
 238          (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
 239          (funcall fun)))
 240   (with-test (:name (:divide-by-zero :bug-346)
 241               :fails-on :alpha)  ; bug 346
 242     (assert (verify-backtrace (lambda () (test #'optimized))
 243                               (list '(/ 42 &rest)
 244                                     (list `(flet test :in ,*p*) #'optimized)))))
 245   (with-test (:name (:divide-by-zero :bug-356)
 246               :fails-on :alpha)  ; bug 356
 247     (assert (verify-backtrace (lambda () (test #'not-optimized))
 248                               (list '(/ 42 &rest)
 249                                     `((flet not-optimized :in ,*p*))
 250                                     (list `(flet test :in ,*p*) #'not-optimized))))))
 251
 252 (with-test (:name (:throw :no-such-tag)
 253             :fails-on '(or
 254                         (and :sparc :linux)
 255                         :alpha
 256                         :mips))
 257   (progn
 258     (defun throw-test ()
 259       (throw 'no-such-tag t))
 260     (assert (verify-backtrace #'throw-test '((throw-test))))))
 261
 262 (defun bug-308926 (x)
 263   (let ((v "foo"))
 264     (flet ((bar (z)
 265              (oops v z)
 266              (oops z v)))
 267       (bar x)
 268       (bar v))))
 269
 270 (with-test (:name :bug-308926)
 271   (assert (verify-backtrace (lambda () (bug-308926 13))
 272                             '(((flet bar :in bug-308926) 13)
 273                               (bug-308926 &rest t)))))
 274
 275 ;;; Test backtrace through assembly routines
 276 ;;; :bug-800343
 277 (macrolet ((test (predicate fun
 278                     &optional (two-arg
 279                                (find-symbol (format nil "TWO-ARG-~A" fun)
 280                                             "SB-KERNEL")))
 281                (let ((test-name (make-symbol (format nil "TEST-~A" fun))))
 282                  `(flet ((,test-name (x y)
 283                            ;; make sure it's not in tail position
 284                            (list (,fun x y))))
 285                     (with-test (:name (:bug-800343 ,fun))
 286                       (assert (verify-backtrace
 287                                (lambda ()
 288                                  (eval `(funcall ,#',test-name 42 t)))
 289                                '((,two-arg 42 t)
 290                                  #+(or x86 x86-64)
 291                                  ,@(and predicate
 292                                     `((,(find-symbol (format nil "GENERIC-~A" fun) "SB-VM"))))
 293                                  ((flet ,test-name :in ,*p*) 42 t))))))))
 294              (test-predicates (&rest functions)
 295                `(progn ,@(mapcar (lambda (function)
 296                                    (if (consp function)
 297                                        `(test t ,@function)
 298                                        `(test t ,function)))
 299                                  functions)))
 300              (test-functions (&rest functions)
 301                `(progn ,@(mapcar (lambda (function)
 302                                    (if (consp function)
 303                                        `(test nil ,@function)
 304                                        `(test nil ,function)))
 305                                  functions))))
 306     (test-predicates = < >)
 307     (test-functions + - * /
 308                     gcd lcm
 309                     (logand sb-kernel:two-arg-and)
 310                     (logior sb-kernel:two-arg-ior)
 311                     (logxor sb-kernel:two-arg-xor)))
 312
 313 ;;; test entry point handling in backtraces
 314
 315 (defun oops ()
 316   (error "oops"))
 317
 318 (with-test (:name :xep-too-many-arguments)
 319   (assert (verify-backtrace (lambda () (oops 1 2 3 4 5 6))
 320                             '((oops ? ? ? ? ? ?)))))
 321
 322 (defmacro defbt (n ll &body body)
 323   ;; WTF is this? This is a way to make these tests not depend so much on the
 324   ;; details of LOAD/EVAL. Around 1.0.57 we changed %SIMPLE-EVAL to be
 325   ;; slightly smarter, which meant that things which used to have xeps
 326   ;; suddently had tl-xeps, etc. This takes care of that.
 327   `(funcall
 328     (compile nil
 329              '(lambda ()
 330                (progn
 331                  ;; normal debug info
 332                  (defun ,(intern (format nil "BT.~A.1" n)) ,ll
 333                    ,@body)
 334                  ;; no arguments saved
 335                  (defun ,(intern (format nil "BT.~A.2" n)) ,ll
 336                    (declare (optimize (debug 1) (speed 3)))
 337                    ,@body)
 338                  ;; no lambda-list saved
 339                  (defun ,(intern (format nil "BT.~A.3" n)) ,ll
 340                    (declare (optimize (debug 0)))
 341                    ,@body))))))
 342
 343 (defbt 1 (&key key)
 344   (list key))
 345
 346 (defbt 2 (x)
 347   (list x))
 348
 349 (defbt 3 (&key (key (oops)))
 350   (list key))
 351
 352 ;;; ERROR instead of OOPS so that tail call elimination doesn't happen
 353 (defbt 4 (&optional opt)
 354   (list (error "error")))
 355
 356 (defbt 5 (&optional (opt (oops)))
 357   (list opt))
 358
 359 (defun bug-354 (x)
 360   (error "XEPs in backtraces: ~S" x))
 361
 362 (with-test (:name :bug-354)
 363   (assert (not (verify-backtrace (lambda () (bug-354 354))
 364                                  '((bug-354 354)
 365                                    (((bug-354 &rest) (:tl :external)) 354)))))
 366   (assert (verify-backtrace (lambda () (bug-354 354)) '((bug-354 354)))))
 367
 368 ;;; FIXME: This test really should be broken into smaller pieces
 369 (with-test (:name (:backtrace :tl-xep))
 370   (assert (verify-backtrace #'namestring
 371                             '(((namestring) (:tl :external)))
 372                             :details t))
 373   (assert (verify-backtrace #'namestring
 374                             '((namestring)))))
 375
 376 (with-test (:name (:backtrace :more-processor))
 377   (assert (verify-backtrace (lambda () (bt.1.1 :key))
 378                             '(((bt.1.1 :key) (:more :optional)))
 379                             :details t))
 380   (assert (verify-backtrace (lambda () (bt.1.2 :key))
 381                             '(((bt.1.2 ?) (:more :optional)))
 382                             :details t))
 383   (assert (verify-backtrace (lambda () (bt.1.3 :key))
 384                             '(((bt.1.3 &rest) (:more :optional)))
 385                             :details t))
 386   (assert (verify-backtrace (lambda () (bt.1.1 :key))
 387                             '((bt.1.1 :key))))
 388   (assert (verify-backtrace (lambda () (bt.1.2 :key))
 389                             '((bt.1.2 &rest))))
 390   (assert (verify-backtrace (lambda () (bt.1.3 :key))
 391                             '((bt.1.3 &rest)))))
 392
 393 (with-test (:name (:backtrace :xep))
 394   (assert (verify-backtrace #'bt.2.1
 395                             '(((bt.2.1) (:external)))
 396                             :details t))
 397   (assert (verify-backtrace #'bt.2.2
 398                             '(((bt.2.2 &rest) (:external)))
 399                             :details t))
 400   (assert (verify-backtrace #'bt.2.3
 401                             '(((bt.2.3 &rest) (:external)))
 402                             :details t))
 403   (assert (verify-backtrace #'bt.2.1
 404                             '((bt.2.1))))
 405   (assert (verify-backtrace #'bt.2.2
 406                             '((bt.2.2 &rest))))
 407   (assert (verify-backtrace #'bt.2.3
 408                             '((bt.2.3 &rest)))))
 409
 410 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
 411 ;;; these functions used to have sb-c::varargs-entry debug names for their
 412 ;;; main lambda.
 413 (with-test (:name (:backtrace :varargs-entry))
 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   (assert (verify-backtrace #'bt.3.1
 421                             '((bt.3.1 :key nil))))
 422   (assert (verify-backtrace #'bt.3.2
 423                             '((bt.3.2 :key ?))))
 424   (assert (verify-backtrace #'bt.3.3
 425                             '((bt.3.3 &rest)))))
 426
 427 ;;; This test is somewhat deceptively named. Due to confusion in debug naming
 428 ;;; these functions used to have sb-c::hairy-args-processor debug names for
 429 ;;; their main lambda.
 430 (with-test (:name (:backtrace :hairy-args-processor))
 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   (assert (verify-backtrace #'bt.4.1
 438                             '((bt.4.1 ?))))
 439   (assert (verify-backtrace #'bt.4.2
 440                             '((bt.4.2 ?))))
 441   (assert (verify-backtrace #'bt.4.3
 442                             '((bt.4.3 &rest)))))
 443
 444
 445 (with-test (:name (:backtrace :optional-processor))
 446   (assert (verify-backtrace #'bt.5.1
 447                             '(((bt.5.1) (:optional)))
 448                             :details t))
 449   (assert (verify-backtrace #'bt.5.2
 450                             '(((bt.5.2 &rest) (:optional)))
 451                             :details t))
 452   (assert (verify-backtrace #'bt.5.3
 453                             '(((bt.5.3 &rest) (:optional)))
 454                             :details t))
 455   (assert (verify-backtrace #'bt.5.1
 456                             '((bt.5.1))))
 457   (assert (verify-backtrace #'bt.5.2
 458                             '((bt.5.2 &rest))))
 459   (assert (verify-backtrace #'bt.5.3
 460                             '((bt.5.3 &rest)))))
 461
 462 (write-line "//compile nil")
 463 (defvar *compile-nil-error* (compile nil '(lambda (x) (cons (when x (error "oops")) nil))))
 464 (defvar *compile-nil-non-tc* (compile nil '(lambda (y) (cons (funcall *compile-nil-error* y) nil))))
 465 (with-test (:name (:compile nil))
 466   (assert (verify-backtrace (lambda () (funcall *compile-nil-non-tc* 13))
 467                             `(((lambda (x) :in ,*p*) 13)
 468                               ((lambda (y) :in ,*p*) 13)))))
 469
 470 (with-test (:name :clos-slot-typecheckfun-named)
 471   (assert
 472    (verify-backtrace
 473     (lambda ()
 474       (eval `(locally (declare (optimize safety))
 475                (defclass clos-typecheck-test ()
 476                  ((slot :type fixnum)))
 477                (setf (slot-value (make-instance 'clos-typecheck-test) 'slot) t))))
 478     '(((sb-pcl::slot-typecheck fixnum) t)))))
 479
 480 (with-test (:name :clos-emf-named)
 481   (assert
 482    (verify-backtrace
 483     (lambda ()
 484       (eval `(progn
 485                (defmethod clos-emf-named-test ((x symbol)) x)
 486                (defmethod clos-emf-named-test :before (x) (assert x))
 487                (clos-emf-named-test nil))))
 488     '(((sb-pcl::emf clos-emf-named-test) ? ? nil)))))
 489
 490 (with-test (:name :bug-310173)
 491   (flet ((make-fun (n)
 492            (let* ((names '(a b))
 493                   (req (loop repeat n collect (pop names))))
 494              (compile nil
 495                       `(lambda (,@req &rest rest)
 496                          (let ((* *)) ; no tail-call
 497                            (apply '/ ,@req rest)))))))
 498     (assert
 499      (verify-backtrace (lambda ()
 500                          (funcall (make-fun 0) 10 11 0))
 501                        `((sb-kernel:two-arg-/ 10/11 0)
 502                          (/ 10 11 0)
 503                          ((lambda (&rest rest) :in ,*p*) 10 11 0))))
 504     (assert
 505      (verify-backtrace (lambda ()
 506                          (funcall (make-fun 1) 10 11 0))
 507                        `((sb-kernel:two-arg-/ 10/11 0)
 508                          (/ 10 11 0)
 509                          ((lambda (a &rest rest) :in ,*p*) 10 11 0))))
 510     (assert
 511      (verify-backtrace (lambda ()
 512                          (funcall (make-fun 2) 10 11 0))
 513                        `((sb-kernel:two-arg-/ 10/11 0)
 514                          (/ 10 11 0)
 515                          ((lambda (a b &rest rest) :in ,*p*) 10 11 0))))))
 516
 517 ;;;; test TRACE
 518
 519 (defun trace-this ()
 520   'ok)
 521
 522 (defun trace-fact (n)
 523   (if (zerop n)
 524       1
 525       (* n (trace-fact (1- n)))))
 526
 527 (with-test (:name (trace :simple))
 528   (let ((out (with-output-to-string (*trace-output*)
 529                (trace trace-this)
 530                (assert (eq 'ok (trace-this)))
 531                (untrace))))
 532     (assert (search "TRACE-THIS" out))
 533     (assert (search "returned OK" out))))
 534
 535 ;;; bug 379
 536 ;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
 537 ;;; suspicions that the breakpoint trace might corrupt the whole image
 538 ;;; on that platform.
 539 (with-test (:name (trace :encapsulate nil)
 540             :fails-on '(or (and :ppc (not :linux)) :sparc :mips)
 541             :broken-on '(or :darwin :sunos))
 542   (let ((out (with-output-to-string (*trace-output*)
 543                (trace trace-this :encapsulate nil)
 544                (assert (eq 'ok (trace-this)))
 545                (untrace))))
 546     (assert (search "TRACE-THIS" out))
 547     (assert (search "returned OK" out))))
 548
 549 (with-test (:name (:trace-recursive :encapsulate nil)
 550             :fails-on '(or (and :ppc (not :linux)) :sparc :mips :sunos)
 551             :broken-on '(or :darwin (and :x86 :sunos)))
 552   (let ((out (with-output-to-string (*trace-output*)
 553                (trace trace-fact :encapsulate nil)
 554                (assert (= 120 (trace-fact 5)))
 555                (untrace))))
 556     (assert (search "TRACE-FACT" out))
 557     (assert (search "returned 1" out))
 558     (assert (search "returned 120" out))))
 559
 560 (defun trace-and-fmakunbound-this (x)
 561   x)
 562
 563 (with-test (:name :bug-667657)
 564   (trace trace-and-fmakunbound-this)
 565   (fmakunbound 'trace-and-fmakunbound-this)
 566   (untrace)
 567   (assert (not (trace))))
 568
 569 (with-test (:name :bug-414)
 570   (handler-bind ((warning #'error))
 571     (load (compile-file "bug-414.lisp"))
 572     (disassemble 'bug-414)))
 573
 574 ;; A known function can be stored as a code constant in lieu of the
 575 ;; usual mode of storing an #<fdefn> and looking up the function from it.
 576 ;; One such usage occurs with TAIL-CALL-VARIABLE (e.g. via APPLY).
 577 ;; Show that declaring the function locally notinline uses the #<fdefn>
 578 ;; by first compiling a call that would have elided the #<fdefn>
 579 ;; and then TRACE.
 580 (defun test-compile-then-load (filename junk)
 581   (declare (notinline compile-file load))
 582   (apply 'load (apply 'compile-file filename junk) junk))
 583 (compile 'test-compile-then-load)
 584 (with-test (:name :traceable-known-fun)
 585   (let ((s (make-string-output-stream)))
 586     (trace compile-file load)
 587     (let ((*trace-output* s))
 588       (test-compile-then-load "bug-414.lisp" nil))
 589     (untrace)
 590     (assert (>= (count #\Newline (get-output-stream-string s)) 4))))
 591
 592 (with-test (:name :bug-310175 :fails-on '(not :stack-allocatable-lists))
 593   ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
 594   ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS.  Therefore,
 595   ;; use two-arg-LIST, which should get through to VOP LIST, and thus
 596   ;; stack-allocate on a predictable set of machines.
 597   (let ((dx-arg (list t t)))
 598     (declare (dynamic-extent dx-arg))
 599     (flet ((dx-arg-backtrace (x)
 600              (declare (optimize (debug 2)))
 601              (prog1 (sb-debug:list-backtrace :count 10)
 602                (assert (sb-debug::stack-allocated-p x)))))
 603       (declare (notinline dx-arg-backtrace))
 604       (assert (member-if (lambda (frame)
 605                            (and (consp frame)
 606                                 (consp (car frame))
 607                                 (equal '(flet dx-arg-backtrace :in) (butlast (car frame)))
 608                                 (notany #'sb-debug::stack-allocated-p (cdr frame))))
 609                          (dx-arg-backtrace dx-arg))))))
 610
 611 (with-test (:name :bug-795245)
 612   (assert
 613    (eq :ok
 614        (catch 'done
 615          (handler-bind
 616              ((error (lambda (e)
 617                        (declare (ignore e))
 618                        (handler-case
 619                            (sb-debug:print-backtrace :count 100
 620                                                      :stream (make-broadcast-stream))
 621                          (error ()
 622                            (throw 'done :error))
 623                          (:no-error ()
 624                            (throw 'done :ok))))))
 625            (apply '/= nil 1 2 nil))))))
 626
 627 ;;;; test infinite error protection
 628
 629 (defmacro nest-errors (n-levels error-form)
 630   (if (< 0 n-levels)
 631       `(handler-bind ((error (lambda (condition)
 632                                (declare (ignore condition))
 633                                ,error-form)))
 634         (nest-errors ,(1- n-levels) ,error-form))
 635       error-form))
 636
 637 (defun erroring-debugger-hook (condition old-debugger-hook)
 638   (let ((*debugger-hook* old-debugger-hook))
 639     (format t "recursive condition: ~A~%" condition) (force-output)
 640     (error "recursive condition: ~A" condition)))
 641
 642 (defun test-infinite-error-protection ()
 643   ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
 644   ;; to halt, it produces so much garbage that's hard to suppress that
 645   ;; it is tested only once
 646   (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
 647   (let ((*debugger-hook* #'erroring-debugger-hook))
 648     (loop repeat 1 do
 649           (let ((error-counter 0)
 650                 (*terminal-io* (make-broadcast-stream)))
 651             (assert
 652              (not (eq
 653                    :normal-exit
 654                    (catch 'sb-impl::toplevel-catcher
 655                      (nest-errors 20 (error "infinite error ~s"
 656                                             (incf error-counter)))
 657                      :normal-exit)))))))
 658   (write-line "--END OF H-B-A-B--"))
 659
 660 (with-test (:name :infinite-error-protection)
 661   (enable-debugger)
 662   (test-infinite-error-protection))
 663
 664 (with-test (:name (:infinite-error-protection :thread)
 665                   :skipped-on '(not :sb-thread))
 666   (enable-debugger)
 667   (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
 668     (loop while (sb-thread:thread-alive-p thread))))
 669
 670 ;; unconditional, in case either previous left it enabled
 671 (disable-debugger)
 672 \f
 673 ;;;; test some limitations of MAKE-LISP-OBJ
 674
 675 ;;; Older GENCGC systems had a bug in the pointer validation used by
 676 ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
 677 ;;; validate.
 678 (with-test (:name (:make-lisp-obj :simple-funs))
 679   (sb-sys:without-gcing
 680     (assert (eq #'identity
 681                 (sb-kernel:make-lisp-obj
 682                  (sb-kernel:get-lisp-obj-address
 683                   #'identity))))))
 684
 685 ;;; Older CHENEYGC systems didn't perform any real pointer validity
 686 ;;; checks beyond "is this pointer to somewhere in heap space".
 687 (with-test (:name (:make-lisp-obj :pointer-validation))
 688   ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
 689   ;; address, but we also need the GC to not pitch a fit if it sees an
 690   ;; object with said bogus address.  Thus, construct our known-bogus
 691   ;; object within an area of unboxed storage (a vector) in static
 692   ;; space.  We'll make it a simple object, (CONS 0 0), which has an
 693   ;; in-memory representation of two consecutive zero words.  We
 694   ;; allocate a three-word vector so that we can guarantee a
 695   ;; double-word aligned double-word of zeros no matter what happens
 696   ;; with the vector-data-offset (currently double-word aligned).
 697   (let* ((memory (sb-int:make-static-vector 3 :element-type `(unsigned-byte ,sb-vm:n-word-bits)
 698                                             :initial-element 0))
 699          (vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
 700          (object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
 701          (object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
 702     (multiple-value-bind (object valid-p)
 703         (sb-kernel:make-lisp-obj object-tagged-address nil)
 704       (declare (ignore object))
 705       (assert (not valid-p)))))
 706
 707 (defun test-debugger (control form &rest targets)
 708   (let ((out (make-string-output-stream))
 709         (oops t))
 710     (unwind-protect
 711          (progn
 712            (with-simple-restart (debugger-test-done! "Debugger Test Done!")
 713              (let* ((*debug-io* (make-two-way-stream
 714                                  (make-string-input-stream control)
 715                                  (make-broadcast-stream out #+nil *standard-output*)))
 716                     ;; Initial announcement goes to *ERROR-OUTPUT*
 717                     (*error-output* *debug-io*)
 718                     (*invoke-debugger-hook* nil))
 719                (handler-bind ((error #'invoke-debugger))
 720                  (eval form))))
 721            (setf oops nil))
 722       (when oops
 723         (error "Uncontrolled unwind from debugger test.")))
 724     ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
 725     ;; it could swallow our asserts!
 726     (with-input-from-string (s (get-output-stream-string out))
 727       (loop for line = (read-line s nil)
 728             while line
 729             do (assert targets)
 730                #+nil
 731                (format *error-output* "Got: ~A~%" line)
 732                (let ((match (pop targets)))
 733                  (if (eq '* match)
 734                      ;; Whatever, till the next line matches.
 735                      (let ((text (pop targets)))
 736                        #+nil
 737                        (format *error-output* "Looking for: ~A~%" text)
 738                        (unless (search text line)
 739                          (push text targets)
 740                          (push match targets)))
 741                      (unless (search match line)
 742                        (format *error-output* "~&Wanted: ~S~%   Got: ~S~%" match line)
 743                        (setf oops t))))))
 744     ;; Check that we saw everything we wanted
 745     (when targets
 746       (error "Missed: ~S" targets))
 747     (assert (not oops))))
 748
 749 (with-test (:name (:debugger :source 1))
 750   (test-debugger
 751    "d
 752     source 0
 753     debugger-test-done!"
 754    `(progn
 755       (defun this-will-break (x)
 756                (declare (optimize debug))
 757                (let* ((y (- x x))
 758                       (z (/ x y)))
 759                  (+ x z)))
 760       (this-will-break 1))
 761    '*
 762    "debugger invoked"
 763    '*
 764    "DIVISION-BY-ZERO"
 765    "operands (1 0)"
 766    '*
 767    "INTEGER-/-INTEGER"
 768    "(THIS-WILL-BREAK 1)"
 769    "1]"
 770    "(/ X Y)"
 771    "1]"))
 772
 773 (with-test (:name (:debugger :source 2))
 774   (test-debugger
 775    "d
 776     source 0
 777     debugger-test-done!"
 778    `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
 779       (let ((f #'(lambda (x cont)
 780                    (print x (make-broadcast-stream))
 781                    (if (zerop x)
 782                        (error "~%foo")
 783                        (funcall cont (1- x) cont)))))
 784         (funcall f 10 f)))
 785    '*
 786    "debugger"
 787    '*
 788    "foo"
 789    '*
 790    "source: (ERROR \"~%foo\")"
 791    '*
 792    "(LAMBDA (X CONT)"
 793    '*
 794    "(FUNCALL CONT (1- X) CONT)"
 795    "1]"))
 796
 797 (with-test (:name (disassemble :high-debug-eval))
 798   (eval `(defun this-will-be-disassembled (x)
 799            (declare (optimize debug))
 800            (+ x x)))
 801   (let* ((oopses (make-string-output-stream))
 802          (disassembly
 803            (let ((*error-output* oopses))
 804              (with-output-to-string (*standard-output*)
 805                (disassemble 'this-will-be-disassembled)))))
 806     (with-input-from-string (s disassembly)
 807       (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
 808                       (read-line s))))
 809     (let ((problems (get-output-stream-string oopses)))
 810       (unless (zerop (length problems))
 811         (error problems)))))
 812
 813 (defun this-too-will-be-disasssembled (x)
 814   (declare (optimize debug))
 815   (+ x x))
 816
 817 (with-test (:name (disassemble :high-debug-load))
 818   (let* ((oopses (make-string-output-stream))
 819          (disassembly
 820            (let ((*error-output* oopses))
 821              (with-output-to-string (*standard-output*)
 822                (disassemble 'this-too-will-be-disasssembled)))))
 823     (with-input-from-string (s disassembly)
 824       (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
 825                      (read-line s))))
 826     (let ((problems (get-output-stream-string oopses)))
 827       (unless (zerop (length problems))
 828         (error problems)))))
 829
 830 ;; The test named :GF-dispatch-backtrace depends on the fact that renaming
 831 ;; a closure works, and that the debugger can extract a closure name.
 832 ;; First things first: verify that a closure can be named.
 833 (defun make-adder (x)
 834   (sb-impl::set-closure-name (lambda (y) (+ x y)) `(adder ,x)))
 835 (with-test (:name :closure-renaming-really-works)
 836   (let ((f1 (make-adder 5))
 837         (expect "#<CLOSURE (ADDER 5)"))
 838     (assert (= (mismatch (write-to-string (make-adder 5)) expect)
 839                (length expect)))
 840     (assert (and (eq (sb-impl::set-closure-name f1 "ADD5") f1)
 841                  (string= (sb-impl::%fun-name f1) "ADD5")))))
 842
 843 (defgeneric gf-dispatch-test/gf (x y)
 844   (:method (x y)
 845     (+ x y)))
 846 (defun gf-dispatch-test/f (z)
 847   (gf-dispatch-test/gf z))
 848
 849 (with-test (:name :gf-dispatch-backtrace)
 850   ;; Fill the cache
 851   (gf-dispatch-test/gf 1 1)
 852   ;; Wrong argument count
 853   (assert (verify-backtrace (lambda () (gf-dispatch-test/f 42))
 854                             '(((sb-pcl::gf-dispatch gf-dispatch-test/gf) 42)))))
 855
 856 (with-test (:name (:xep-arglist-clean-up :bug-1192929))
 857   (assert
 858    (block nil
 859      (handler-bind ((error (lambda (e)
 860                              (declare (ignore e))
 861                              (return (< (length (car (sb-debug:backtrace-as-list 1))) 10)))))
 862        (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
 863
 864 ;;; bug-1261646
 865
 866 (defun print-backtrace-to-string/debug-print-variable-alist (x)
 867   (values
 868    (with-output-to-string (stream)
 869      (let ((*debug-print-variable-alist* '((*print-length* . 5)
 870                                            (*print-level* . 3))))
 871        (sb-debug:print-backtrace :stream stream :count 5)))
 872    x)) ; Force use of X to prevent flushing
 873
 874 (with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
 875                    *print-length* :bug-1261646))
 876   (let* ((printed (print-backtrace-to-string/debug-print-variable-alist (make-array 200)))
 877          (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
 878          (position (+ (search call printed) (length call))))
 879     (assert (eql position (search "#(0 0 0 0 0 ...)" printed :start2 position)))))
 880
 881 (with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
 882                    *print-level* :bug-1261646))
 883   (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
 884                    '(((((1)))))))
 885          (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
 886          (position (+ (search call printed) (length call))))
 887     (assert (eql position (search "((#))" printed :start2 position)))))
 888
 889
 890 (defvar *x* nil)
 891 (defun foo (a) a)
 892
 893 (with-test (:name :trace-debug-arg)
 894   (trace foo :print-after (setf *x* (sb-debug:arg 0)))
 895   (foo 1)
 896   (assert (eql *x* 1))
 897
 898   (trace foo :print (setf *x* (sb-debug:arg 0)))
 899   (foo 2)
 900   (assert (eql *x* 2))
 901
 902   (trace foo :condition (eql (setf *x* (sb-debug:arg 0)) 0))
 903   (foo 3)
 904   (assert (eql *x* 3))
 905
 906   (trace foo :condition-after (setf *x* (sb-debug:arg 0)))
 907   (foo 4)
 908   (assert (eql *x* 4))
 909
 910   (trace foo :break (and (setf *x* (sb-debug:arg 0)) nil))
 911   (foo 5)
 912   (assert (eql *x* 5))
 913
 914   (trace foo :break-all (and (setf *x* (sb-debug:arg 0)) nil))
 915   (foo 6)
 916   (assert (eql *x* 6))
 917   (trace foo :break-after (and (setf *x* (sb-debug:arg 0)) nil))
 918   (foo 7))
 919
 920 (defun frobbleize (arg) (sb-debug:print-backtrace) 'win)
 921 (defmethod low-debug-method ((self t))
 922   (declare (optimize (debug 0)))
 923   (frobbleize 'me) ; make this not a tail call, so it remains on stack
 924   5)
 925 (with-test (:name :clean-fast-method-frame-lossage)
 926   (low-debug-method 42)) ; no need to assert. it either crashes or doesn't
 927
 928 (defun return-65535 ()
 929   65535)
 930
 931 (with-test (:name :indirect-closure-values)
 932   (let ((count 0))
 933     (block nil
 934       (handler-bind ((error (lambda (c)
 935                               (declare (ignore c))
 936                               (sb-debug::map-backtrace
 937                                (lambda (frame)
 938                                  (let ((sb-debug::*current-frame* frame)
 939                                        (name (sb-debug::frame-call frame)))
 940                                    (when (or (eq name 'test)
 941                                              (and (consp name)
 942                                                   (or (eql (search '(labels f1) name) 0)
 943                                                       (eql (search '(labels f2) name) 0))))
 944                                      (incf count)
 945                                      (assert (eql (var 'a) 2))))))
 946                               (return))))
 947         (funcall
 948          (compile nil
 949                   `(sb-int:named-lambda test ()
 950                      (declare (optimize debug))
 951                      (let ((a 1))
 952                        (labels
 953                            ((f1 ()
 954                               (incf a)
 955                               (signal 'error))
 956                             (f2 ()
 957                               (f1)))
 958                          (f2))))))))
 959     (assert (= count 3))))
 960
 961 (with-test (:name :indirect-closure-values.2)
 962   (let ((count 0))
 963     (block nil
 964       (handler-bind ((error (lambda (c)
 965                               (declare (ignore c))
 966                               (sb-debug::map-backtrace
 967                                (lambda (frame)
 968                                  (let ((sb-debug::*current-frame* frame)
 969                                        (name (sb-debug::frame-call frame)))
 970                                    (when (or (eq name 'test)
 971                                              (and (consp name)
 972                                                   (or (eql (search '(labels f1) name) 0)
 973                                                       (eql (search '(labels f2) name) 0))))
 974                                      (incf count)
 975                                      (assert (eql (var 'a) 65535))))))
 976                               (return))))
 977         (funcall
 978          (compile nil
 979                   `(sb-int:named-lambda test ()
 980                      (declare (optimize debug))
 981                      (let ((a (return-65535)))
 982                        (declare ((unsigned-byte 16) a))
 983                        (labels
 984                            ((f1 ()
 985                               (incf a)
 986                               (signal 'error))
 987                             (f2 ()
 988                               (f1)))
 989                          (f2))))))))
 990     (assert (= count 3))))
 991
 992 (with-test (:name :non-tail-self-call-bad-variables)
 993   (let ((count 0))
 994     (block nil
 995       (handler-bind ((error (lambda (c)
 996                               (declare (ignore c))
 997                               (sb-debug::map-backtrace
 998                                (lambda (frame)
 999                                  (let ((sb-debug::*current-frame* frame))
1000                                    (multiple-value-bind (name args)
1001                                        (sb-debug::frame-call frame)
1002                                      (when (eq name 'test)
1003                                        (assert (or (null args)
1004                                                    (equal args '(nil))))
1005                                        (incf count))))))
1006                               (return))))
1007         (funcall
1008          (compile nil `(sb-int:named-lambda test (&optional x)
1009                          (declare (optimize sb-c::recognize-self-calls))
1010                          (signal 'error :format-control "~a" :format-arguments (list x))
1011                          (test 1)
1012                          1)))))
1013     (assert (= count 1))))
1014
1015 (with-test (:name :local-tail-call)
1016   (assert (verify-backtrace
1017            (lambda () (funcall (compile nil `(sb-int:named-lambda test ()
1018                                                (signal 'error)
1019                                                (flet ((tail ()))
1020                                                  (declare (notinline tail))
1021                                                  (tail))))))
1022            '((test)))))
1023
1024 (with-test (:name :local-tail-call-variables)
1025   (let ((count 0))
1026     (block nil
1027       (handler-bind ((error (lambda (c)
1028                               (declare (ignore c))
1029                               (sb-debug::map-backtrace
1030                                (lambda (frame)
1031                                  (let ((sb-debug::*current-frame* frame))
1032                                    (multiple-value-bind (name args)
1033                                        (sb-debug::frame-call frame)
1034                                      (when (eq name 'test)
1035                                        (assert (equal args '(error)))
1036                                        (incf count))))))
1037                               (return))))
1038         (funcall
1039          (compile nil `(sb-int:named-lambda test (x)
1040                          (signal x)
1041                          ;; If :local-tail-call fails, this will fail
1042                          ;; too, because there's no jump between
1043                          ;; SIGNAL and the call to TAIL and it will
1044                          ;; show (flet tail) in the backtrace.
1045                          (flet ((tail ()))
1046                            (declare (notinline tail))
1047                            (tail))))
1048          'error)))
1049     (assert (= count 1))))
1050
1051 (with-test (:name :variables-surrounding-inlined-code)
1052   (let ((count 0))
1053     (block nil
1054       (handler-bind ((error (lambda (c)
1055                               (declare (ignore c))
1056                               (sb-debug::map-backtrace
1057                                (lambda (frame)
1058                                  (let ((sb-debug::*current-frame* frame))
1059                                    (multiple-value-bind (name)
1060                                        (sb-debug::frame-call frame)
1061                                      (when (eq name 'test)
1062                                        (assert (equal (sb-debug:var 'l) '(1 2 3)))
1063                                        (incf count))))))
1064                               (return))))
1065         (funcall
1066          (compile nil `(sb-int:named-lambda test (a i)
1067                          (declare (optimize (debug 3)))
1068                          (let ((l (list 1 2 3)))
1069                            (aref a i)
1070                            l)))
1071          #(1) 2)))
1072     (assert (= count 1))))
1073
1074 (with-test (:name :variables-surrounding-inlined-code.2)
1075   (let ((count 0))
1076     (block nil
1077       (handler-bind ((error (lambda (c)
1078                               (declare (ignore c))
1079                               (sb-debug::map-backtrace
1080                                (lambda (frame)
1081                                  (let ((sb-debug::*current-frame* frame))
1082                                    (multiple-value-bind (name)
1083                                        (sb-debug::frame-call frame)
1084                                      (when (eq name 'test)
1085                                        (assert (equal (sb-debug:var 'l) '(1 2 3)))
1086                                        (incf count))))))
1087                               (return))))
1088         (funcall
1089          (compile nil `(sb-int:named-lambda test (c)
1090                          (declare (optimize (debug 3)))
1091                          (let ((l (list 1 2 3)))
1092                            (map 'list #'signal c)
1093                            l)))
1094          '(error))))
1095     (assert (= count 1))))