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   (invoke-restart 'run-tests::skip-file))
  21
  22 #+(or x86 x86-64)
  23 (with-test (:name :legal-bpt-lra-object)
  24   (sb-int:binding* ((code (sb-kernel:fun-code-header #'read))
  25                     (sap (sb-sys:sap+ (sb-kernel:code-instructions code) 13)) ; random
  26                     ((bpt-sap bpt-code-obj) (sb-di::make-bpt-lra sap)))
  27     (declare (ignore bpt-sap))
  28     ;; This was causing heap corruption
  29     (assert (zerop (sb-kernel:code-jump-table-words bpt-code-obj)))))
  30
  31 \f
  32 ;;;; Check that we get debug arglists right.
  33
  34 (defun zoop (zeep &key beep)
  35   (declare (ignore zeep beep) (special blurp))
  36   blurp)
  37 (assert (equal (sb-kernel:%fun-lambda-list #'zoop) '(zeep &key beep)))
  38
  39 ;;; Check some predefined functions too.
  40 ;;;
  41 ;;; (We don't know exactly what the arguments are, e.g. the first
  42 ;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
  43 ;;; whatever. But we do know the general structure that a correct
  44 ;;; answer should have, so we can safely do a lot of checks.)
  45 (with-test (:name :predefined-functions-1)
  46   (destructuring-bind (object-sym andoptional-sym stream-sym)
  47       (sb-kernel:%fun-lambda-list #'print)
  48     (assert (symbolp object-sym))
  49     (assert (eql andoptional-sym '&optional))
  50     (assert (symbolp stream-sym))))
  51
  52 (with-test (:name :predefined-functions-2)
  53   (destructuring-bind (dest-sym control-sym andrest-sym format-args-sym)
  54       (sb-kernel:%fun-lambda-list #'format)
  55     (assert (symbolp dest-sym))
  56     (assert (symbolp control-sym))
  57     (assert (eql andrest-sym '&rest))
  58     (assert (symbolp format-args-sym))))
  59
  60 ;;;; test TRACE
  61
  62 (defmacro with-traced-function ((name &rest options) &body body)
  63   `(with-output-to-string (*trace-output*)
  64      (unwind-protect
  65           (progn
  66             (trace ,name ,@options)
  67             ,@body)
  68        (ignore-errors (untrace ,name)))))
  69
  70 (defun call-collecting-traces (fn trace-arguments)
  71   (let ((traces nil))
  72     (flet ((collect (depth what when frame values)
  73              (declare (ignore frame))
  74              (flet ((ensure-readable (x)
  75                       (typecase x
  76                         (function (sb-impl::%fun-name x))
  77                         (sb-debug::unprintable-object
  78                          (sb-debug::unprintable-object-string x))
  79                         (t x))))
  80                (push (list* depth
  81                             (ensure-readable what)
  82                             when
  83                             (mapcar #'ensure-readable values))
  84                      traces))))
  85       (unwind-protect
  86            (let ((sb-debug:*trace-report-default* #'collect))
  87              (eval `(trace ,@trace-arguments))
  88              (funcall fn))
  89         (ignore-errors (untrace))
  90         (assert (null (trace)))))
  91     (nreverse traces)))
  92
  93 (defmacro collecting-traces ((&rest trace-arguments) &body body)
  94   `(call-collecting-traces (lambda () ,@body) ',trace-arguments))
  95
  96 (defun trace-this (&optional arg)
  97   (declare (ignore arg))
  98   'ok)
  99
 100 (defun mv-trace-this (&optional arg)
 101   (case arg
 102     (2 (values 'ok "hi"))
 103     (3 (values 'ok "hi" :foo))
 104     (4 (values 'ok "hi" :foo :bar))))
 105
 106 (defun trace-fact (n)
 107   (if (zerop n)
 108       1
 109       (* n (trace-fact (1- n)))))
 110
 111 (with-test (:name (trace :simple))
 112   (let ((output (with-traced-function (trace-this)
 113                   (assert (eq 'ok (trace-this))))))
 114     (assert (search "TRACE-THIS" output))
 115     (assert (search "returned OK" output))))
 116
 117 (with-test (:name (trace :print-readably))
 118   (let ((output (with-traced-function (trace-this)
 119                   (let ((*print-readably* t))
 120                     (assert (eq 'ok (trace-this (sb-int:make-unprintable-object "foo"))))))))
 121     (assert (search "TRACE-THIS" output))
 122     (assert (search "foo" output))
 123     (assert (search "returned OK" output))))
 124
 125 ;;; The following should not work:
 126 ;;;  (DEFUN G () (M))
 127 ;;;  (DEFMACRO M (&REST r) (format t "M invoked: ~S~%" r))
 128 ;;;  (ENCAPSULATE 'M 'foo (lambda (f &rest r) (format t "encapsulation: ~S ~S~%" f r)))
 129 ;;;  (G)
 130 ;;; If (ENCAPSULATE) were permitted, M's guard trampoline would be replaced by the
 131 ;;; encapsulation which is not meaningful. Most uses of the macro M will NOT invoke
 132 ;;; the encapsulation since we don't store macro functions in the symbol-function location.
 133 ;;; Only a consumer of M being accidentally compiled first and resolving M to an
 134 ;;; fdefinition would see the encapulation. That should just be an error.
 135 (with-test (:name :no-macro-encapsulation)
 136   (assert-error (sb-int:encapsulate 'cond 'tryme
 137                                     (lambda (f &rest stuff)
 138                                       (declare (ignore f stuff))))))
 139
 140 (defparameter *breakpoint-tracing-expectations*
 141   '(:fails-on (or :arm :arm64)
 142     :broken-on (or :freebsd :ppc :ppc64)))
 143
 144 ;;; bug 379
 145 (with-test (:name (trace :encapsulate nil)
 146                   . #.*breakpoint-tracing-expectations*)
 147   (let ((output (with-traced-function (trace-this :encapsulate nil)
 148                   (assert (eq 'ok (trace-this))))))
 149     (assert (search "TRACE-THIS" output))
 150     (assert (search "returned OK" output))))
 151
 152 (with-test (:name :breakpoint-trace-multival . #.*breakpoint-tracing-expectations*)
 153   (let ((output (with-traced-function (mv-trace-this :encapsulate nil)
 154                   (assert (equal (multiple-value-list (mv-trace-this 2))
 155                                  '(ok "hi"))))))
 156     (assert (search "MV-TRACE-THIS" output))
 157     (assert (search "returned OK" output)))
 158   (let ((output (with-traced-function (mv-trace-this :encapsulate nil)
 159                   (assert (equal (multiple-value-list (mv-trace-this 3))
 160                                  '(ok "hi" :foo))))))
 161     (assert (search "MV-TRACE-THIS" output))
 162     (assert (search "returned OK" output)))
 163   (let ((output (with-traced-function (mv-trace-this :encapsulate nil)
 164                   (assert (equal (multiple-value-list (mv-trace-this 4))
 165                                  '(ok "hi" :foo :bar))))))
 166     (assert (search "MV-TRACE-THIS" output))
 167     (assert (search "returned OK" output))))
 168
 169 (with-test (:name (trace :encapsulate nil :recursive)
 170                   . #.*breakpoint-tracing-expectations*)
 171   (let ((output (with-traced-function (trace-fact :encapsulate nil)
 172                   (assert (= 120 (trace-fact 5))))))
 173     (assert (search "TRACE-FACT" output))
 174     (assert (search "returned 1" output))
 175     (assert (search "returned 120" output))))
 176
 177 (defun trace-and-fmakunbound-this (x)
 178   x)
 179
 180 (with-test (:name (trace fmakunbound :bug-667657))
 181   (trace trace-and-fmakunbound-this)
 182   (fmakunbound 'trace-and-fmakunbound-this)
 183   ;; FIXME: this generates a pointless warning that we can't untrace a formerly
 184   ;; traced function. Function redefinition knows to untrace/re-trace because of
 185   ;; the setf-fdefn hook. fmakunbound can do something similar - drop the trace.
 186   (untrace)
 187   (assert (not (trace))))
 188
 189 (with-test (:name (trace :report nil :smoke))
 190   (let ((output (with-traced-function (trace-this :report nil)
 191                   (assert (eq 'ok (trace-this))))))
 192     (assert (sequence:emptyp output))))
 193
 194 (with-test (:name (trace :report nil :print))
 195   (let ((output (with-traced-function
 196                     (trace-fact :report nil :print (sb-debug:arg 0))
 197                   (assert (eq '2 (trace-fact 2))))))
 198     (assert (string= output (format nil "2~@
 199                                          1~@
 200                                          0~%")))))
 201
 202 (defvar *collected-traces*)
 203 (defun custom-trace-report (depth what when frame values)
 204   (push (list* depth what when (sb-debug::frame-p frame) values)
 205         *collected-traces*))
 206
 207 (with-test (:name (trace :custom-report))
 208   (let ((*collected-traces* nil))
 209     (let ((output (with-traced-function (trace-fact :report custom-trace-report)
 210                     (trace-fact 2))))
 211       (assert (zerop (length output)))
 212       (assert (equalp (reverse *collected-traces*)
 213                       '((0 trace-fact :enter t 2)
 214                         (1 trace-fact :enter t 1)
 215                         (2 trace-fact :enter t 0)
 216                         (2 trace-fact :exit  t 1)
 217                         (1 trace-fact :exit  t 1)
 218                         (0 trace-fact :exit  t 2)))))))
 219
 220 (with-test (:name (trace :anonymous) . #.*breakpoint-tracing-expectations*)
 221   (assert (equalp (call-collecting-traces
 222                    (lambda ()
 223                      (trace-fact 1))
 224                    `(:function ,#'trace-fact :condition (plusp (sb-debug:arg 0))))
 225                   '((0 trace-fact :enter 1)
 226                     (0 trace-fact :exit 1)))))
 227
 228 (defgeneric trace-gf (x)
 229   (:method         ((x float))      (+ x (call-next-method)))
 230   (:method :before ((x float))      'bf)
 231   (:method :around ((x float))      (call-next-method))
 232   (:method :after  ((x float))      'af)
 233   (:method         ((x number))     (+ x (call-next-method)))
 234   (:method :before ((x number))     'bn)
 235   (:method :around ((x number))     (call-next-method))
 236   (:method :after  ((x number))     'an)
 237   (:method         ((x (eql 21.0))) (call-next-method))
 238   (:method         (x)              0))
 239
 240 (with-test (:name (trace :all-methods))
 241   (assert (equal (collecting-traces (trace-gf :methods t)
 242                    (trace-gf 21.0))
 243                  '((0 trace-gf :enter 21.0)
 244                    (1 (method trace-gf :around (float))  :enter 21.0)
 245                    (2 (method trace-gf :around (number)) :enter 21.0)
 246                    (3 (sb-pcl::combined-method trace-gf) :enter 21.0)
 247                    (4 (method trace-gf :before (float))  :enter 21.0)
 248                    (4 (method trace-gf :before (float))  :exit  bf)
 249                    (4 (method trace-gf :before (number)) :enter 21.0)
 250                    (4 (method trace-gf :before (number)) :exit  bn)
 251                    (4 (method trace-gf ((eql 21.0))) :enter 21.0)
 252                    (5 (method trace-gf (float))      :enter 21.0)
 253                    (6 (method trace-gf (number))     :enter 21.0)
 254                    (7 (method trace-gf (t))          :enter 21.0)
 255                    (7 (method trace-gf (t))          :exit 0)
 256                    (6 (method trace-gf (number))     :exit 21.0)
 257                    (5 (method trace-gf (float))      :exit 42.0)
 258                    (4 (method trace-gf ((eql 21.0))) :exit 42.0)
 259                    (4 (method trace-gf :after (number))  :enter 21.0)
 260                    (4 (method trace-gf :after (number))  :exit  an)
 261                    (4 (method trace-gf :after (float))   :enter 21.0)
 262                    (4 (method trace-gf :after (float))   :exit  af)
 263                    (3 (sb-pcl::combined-method trace-gf) :exit  42.0)
 264                    (2 (method trace-gf :around (number)) :exit  42.0)
 265                    (1 (method trace-gf :around (float))  :exit  42.0)
 266                    (0 trace-gf :exit 42.0)))))
 267
 268 (with-test (:name (trace :methods))
 269   (assert (equal (collecting-traces ((method trace-gf :after (float))
 270                                      (method trace-gf :around (number))
 271                                      (method trace-gf (t)))
 272                    (trace-gf 42.0))
 273                  '((0 (method trace-gf :around (number)) :enter 42.0)
 274                    (1 (method trace-gf (t)) :enter 42.0)
 275                    (1 (method trace-gf (t)) :exit 0)
 276                    (1 (method trace-gf :after (float)) :enter 42.0)
 277                    (1 (method trace-gf :after (float)) :exit af)
 278                    (0 (method trace-gf :around (number)) :exit 84.0)))))
 279
 280 (with-test (:name (trace :methods :encapsulate nil)
 281                   . #.*breakpoint-tracing-expectations*)
 282   (assert (equal (collecting-traces (:encapsulate nil
 283                                      (method trace-gf :after (float))
 284                                      (method trace-gf :around (number))
 285                                      (method trace-gf (t)))
 286                    (trace-gf 42.0))
 287                  '((0 (sb-pcl::fast-method trace-gf :around (number)) :enter 42.0)
 288                    (1 (sb-pcl::fast-method trace-gf (t)) :enter "unused argument")
 289                    (1 (sb-pcl::fast-method trace-gf (t)) :exit 0)
 290                    (1 (sb-pcl::fast-method trace-gf :after (float)) :enter "unused argument")
 291                    (1 (sb-pcl::fast-method trace-gf :after (float)) :exit af)
 292                    (0 (sb-pcl::fast-method trace-gf :around (number)) :exit 84.0)))))
 293
 294 (defparameter *expected-trace-gf-number+t-trace*
 295   '((0 (method trace-gf :around (number)) :enter 42.0)
 296     (1 (method trace-gf (t)) :enter 42.0)
 297     (1 (method trace-gf (t)) :exit 0)
 298     (0 (method trace-gf :around (number)) :exit 84.0)))
 299
 300 (with-test (:name (trace :methods :untrace-some))
 301   (assert (equal (collecting-traces ((method trace-gf :after (float))
 302                                      (method trace-gf :around (number))
 303                                      (method trace-gf (t)))
 304                    (untrace (method trace-gf :after (float)))
 305                    (trace-gf 42.0))
 306                  *expected-trace-gf-number+t-trace*)))
 307
 308 (with-test (:name (trace :methods :untrace-many))
 309   (assert (equal (collecting-traces ((method trace-gf :around (number))
 310                                      (method trace-gf (t))
 311                                      trace-gf :methods t)
 312                    (untrace trace-gf)
 313                    (trace-gf 42.0))
 314                  *expected-trace-gf-number+t-trace*)))
 315
 316 (with-test (:name (trace :methods :trace-more))
 317   (assert (equal (collecting-traces ((method trace-gf (t)))
 318                    (eval '(trace (method trace-gf :around (number))))
 319                    (trace-gf 42.0))
 320                  *expected-trace-gf-number+t-trace*)))
 321
 322 (defgeneric (setf trace-gf) (value)
 323   (:method ((x float)) (call-next-method))
 324   (:method :before ((x number)) 'before)
 325   (:method ((x number)) x))
 326
 327 (with-test (:name (trace :setf-methods))
 328   (assert (equal (collecting-traces ((method (setf trace-gf) (float))
 329                                      (method (setf trace-gf) (number))
 330                                      (method (setf trace-gf) :before (number)))
 331                                     (setf (trace-gf) 42.0))
 332                  '((0 (method (setf trace-gf) :before (number)) :enter 42.0)
 333                    (0 (method (setf trace-gf) :before (number)) :exit before)
 334                    (0 (method (setf trace-gf) (float)) :enter 42.0)
 335                    (1 (method (setf trace-gf) (number)) :enter 42.0)
 336                    (1 (method (setf trace-gf) (number)) :exit 42.0)
 337                    (0 (method (setf trace-gf) (float)) :exit 42.0)))))
 338
 339 (defun global-fact (x)
 340   (declare (optimize (debug 3))) ; suppress inlining
 341   (labels ((fact (x)
 342              (flet ((multiply (x y)
 343                       (* x y)))
 344                (if (zerop x)
 345                    1
 346                    (multiply x (fact (1- x)))))))
 347     (fact x)))
 348
 349 (with-test (:name (trace :labels) . #.*breakpoint-tracing-expectations*)
 350   (assert (equal (collecting-traces ((labels fact :in global-fact)
 351                                      (flet multiply :in global-fact))
 352                    (global-fact 1))
 353                  '((0 (labels fact :in global-fact) :enter 1)
 354                    (1 (labels fact :in global-fact) :enter 0)
 355                    (1 (labels fact :in global-fact) :exit 1)
 356                    (1 (flet multiply :in global-fact) :enter 1 1)
 357                    (1 (flet multiply :in global-fact) :exit 1)
 358                    (0 (labels fact :in global-fact) :exit 1)))))
 359
 360 (defgeneric gfact (x)
 361   (:method ((x number))
 362     (declare (optimize (debug 3))) ; suppress inlining
 363     (flet ((fact (x) (global-fact x)))
 364       (fact x))))
 365
 366 (with-test (:name (trace :labels :within-method)
 367                   . #.*breakpoint-tracing-expectations*)
 368   (assert (equal (collecting-traces ((flet fact :in (method gfact (number))))
 369                    (gfact 3))
 370                  '((0 (flet fact :in (method gfact (number))) :enter 3)
 371                    (0 (flet fact :in (method gfact (number))) :exit 6)))))
 372
 373 (with-test (:name (trace :labels :within-untraced-method)
 374                   . #.*breakpoint-tracing-expectations*)
 375   (assert (equal (collecting-traces ((method gfact (number))
 376                                      (flet fact :in (method gfact (number))))
 377                    (untrace (method gfact (number)))
 378                    (gfact 3))
 379                  '((0 (flet fact :in (method gfact (number))) :enter 3)
 380                    (0 (flet fact :in (method gfact (number))) :exit 6)))))
 381
 382 (defun trace-foo ()
 383   (declare (optimize (debug 3)))
 384   (flet ((body () 'original-foo))
 385     (body)))
 386
 387 (defun call-with-trace-foo-redefined (fn)
 388   (let ((original (fdefinition 'trace-foo)))
 389     ;; the local function will be named (FLET BODY) instead of (FLET
 390     ;; BODY :IN TRACE-FOO) unless we use EVAL here.
 391     (eval '(defun trace-foo ()
 392             (declare (optimize (debug 3)))
 393             (flet ((body () 'redefined-foo))
 394               (body))))
 395     (unwind-protect
 396          (funcall fn)
 397       (setf (fdefinition 'trace-foo) original))))
 398
 399 (with-test (:name (trace :labels :redefined)
 400                   . #.*breakpoint-tracing-expectations*)
 401   (assert (equal (collecting-traces ((flet body :in trace-foo))
 402                    (trace-foo)
 403                    (call-with-trace-foo-redefined 'trace-foo))
 404                  '((0 (flet body :in trace-foo) :enter)
 405                    (0 (flet body :in trace-foo) :exit original-foo)
 406                    (0 (flet body :in trace-foo) :enter)
 407                    (0 (flet body :in trace-foo) :exit redefined-foo)))))
 408
 409 (defmethod trace-foo-gf ()
 410   (declare (optimize (debug 3)))
 411   (flet ((body () 'original-foo))
 412     (body)))
 413
 414 (defun call-with-trace-foo-gf-redefined (fn)
 415   ;; using ADD-METHOD and REMOVE-METHOD yields outdated DEBUG-FUN
 416   ;; info, so work around that using EVAL.
 417   (eval '(defmethod trace-foo-gf ()
 418           (declare (optimize (debug 3)))
 419           (flet ((body () 'redefined-foo))
 420             (body))))
 421   (unwind-protect
 422        (funcall fn)
 423     (eval '(defmethod trace-foo-gf ()
 424             (declare (optimize (debug 3)))
 425             (flet ((body () 'original-foo))
 426               (body))))))
 427
 428 (with-test (:name (trace :labels :redefined-method)
 429                   . #.*breakpoint-tracing-expectations*)
 430   (assert (equal (collecting-traces ((flet body :in (method trace-foo-gf ())))
 431                    (trace-foo-gf)
 432                    (call-with-trace-foo-gf-redefined 'trace-foo-gf))
 433                  '((0 (flet body :in (method trace-foo-gf ())) :enter)
 434                    (0 (flet body :in (method trace-foo-gf ())) :exit original-foo)
 435                    (0 (flet body :in (method trace-foo-gf ())) :enter)
 436                    (0 (flet body :in (method trace-foo-gf ())) :exit redefined-foo)))))
 437
 438 (defun fn-with-cmac (x) x)
 439
 440 (define-compiler-macro fn-with-cmac (x)
 441   (declare (ignore x) (optimize (debug 3))) ; suppress flet inlining
 442   (flet ((body () 42))
 443     (body)))
 444
 445 (with-test (:name (trace :compiler-macro)
 446                   . #.*breakpoint-tracing-expectations*)
 447   (assert (equal (collecting-traces ((compiler-macro fn-with-cmac))
 448                    (compile nil '(lambda () (fn-with-cmac 0))))
 449                  '((0 (compiler-macro fn-with-cmac) :enter (fn-with-cmac 0) "unused argument")
 450                    (0 (compiler-macro fn-with-cmac) :exit 42)))))
 451
 452 (with-test (:name (trace :flet :within-compiler-macro)
 453                   . #.*breakpoint-tracing-expectations*)
 454   (assert (equal (collecting-traces ((flet body :in (compiler-macro fn-with-cmac)))
 455                    (compile nil '(lambda () (fn-with-cmac 0))))
 456                  '((0 (flet body :in (compiler-macro fn-with-cmac)) :enter)
 457                    (0 (flet body :in (compiler-macro fn-with-cmac)) :exit 42)))))
 458
 459 (defun call-with-compiler-macro-redefined (fn)
 460   (eval `(define-compiler-macro fn-with-cmac (x)
 461            (declare (ignore x) (optimize (debug 3)))
 462            (flet ((body () ''redefined))
 463              (body))))
 464   (unwind-protect
 465        (funcall fn)
 466     (eval `(define-compiler-macro fn-with-cmac (x)
 467              (declare (ignore x) (optimize (debug 3)))
 468              (flet ((body () 42))
 469                (body))))))
 470
 471 #-(or ppc ppc64)
 472 (with-test (:name (trace :compiler-macro :redefined)
 473                   . #.*breakpoint-tracing-expectations*)
 474   (assert (equal (collecting-traces ((compiler-macro fn-with-cmac)
 475                                      (flet body :in (compiler-macro fn-with-cmac)))
 476                    (compile nil '(lambda () (fn-with-cmac 0)))
 477                    (call-with-compiler-macro-redefined
 478                     (lambda () (compile nil '(lambda () (fn-with-cmac 0))))))
 479                  '((0 (compiler-macro fn-with-cmac) :enter (fn-with-cmac 0) "unused argument")
 480                    (1 (flet body :in (compiler-macro fn-with-cmac)) :enter)
 481                    (1 (flet body :in (compiler-macro fn-with-cmac)) :exit 42)
 482                    (0 (compiler-macro fn-with-cmac) :exit 42)
 483                    (0 (compiler-macro fn-with-cmac) :enter (fn-with-cmac 0) "unused argument")
 484                    (1 (flet body :in (compiler-macro fn-with-cmac)) :enter)
 485                    (1 (flet body :in (compiler-macro fn-with-cmac)) :exit 'redefined)
 486                    (0 (compiler-macro fn-with-cmac) :exit 'redefined)))))
 487
 488 (defun throw-foo ()
 489   (throw 'foo 42))
 490
 491 (defun catch-foo ()
 492   (catch 'foo (throw-foo)))
 493
 494 (with-test (:name (trace :non-local-exit))
 495   (assert (equal (collecting-traces (throw-foo)
 496                    (catch-foo))
 497                  '((0 throw-foo :enter)
 498                    (0 throw-foo :non-local-exit)))))
 499
 500 (with-test (:name (trace :non-local-exit :standard-report))
 501   (let ((output (with-traced-function (throw-foo)
 502                   (catch-foo))))
 503     (assert (search "exited non-locally" output))))
 504
 505 (defun trace-inner-function (x)
 506   x)
 507
 508 (defun trace-outer-function (x)
 509   (declare (optimize (debug 3))) ; avoid tail call optimization
 510   (trace-inner-function x))
 511
 512 (defun test-trace-inner-function (&key encapsulate)
 513   (assert (equal (let ((sb-debug:*trace-encapsulate-default* encapsulate))
 514                    (collecting-traces (trace-inner-function
 515                                        :wherein trace-outer-function)
 516                      (trace-outer-function 'outer-value)
 517                      (trace-inner-function 'inner-value)))
 518                  '((0 trace-inner-function :enter outer-value)
 519                    (0 trace-inner-function :exit outer-value)))))
 520
 521 (with-test (:name (trace :wherein :encapsulate t))
 522   (test-trace-inner-function :encapsulate t))
 523
 524 (with-test (:name (trace :wherein :encapsulate nil)
 525                   . #.*breakpoint-tracing-expectations*)
 526   (test-trace-inner-function :encapsulate nil))
 527
 528 (defun test-trace-fact-wherein (&key encapsulate)
 529   (assert (equal (let ((sb-debug:*trace-encapsulate-default* encapsulate))
 530                    (collecting-traces (trace-fact :wherein trace-fact)
 531                      (trace-fact 1)))
 532                  '((0 trace-fact :enter 0)
 533                    (0 trace-fact :exit 1)))))
 534
 535 (with-test (:name (trace :wherein :recursive :encapsulate t))
 536   (test-trace-fact-wherein :encapsulate t))
 537
 538 (with-test (:name (trace :wherein :recursive :encapsulate nil)
 539                   . #.*breakpoint-tracing-expectations*)
 540   (test-trace-fact-wherein :encapsulate nil))
 541
 542 (defmacro macro-fact (x)
 543   (labels ((fact (x) (if (zerop x) 1 (* x (fact (1- x))))))
 544     (fact x)))
 545
 546 (with-test (:name (trace :macro)
 547                   . #.*breakpoint-tracing-expectations*)
 548   (assert (equal (collecting-traces (macro-fact)
 549                    (macroexpand-1 '(macro-fact 3)))
 550                  '((0 macro-fact :enter (macro-fact 3) "unused argument")
 551                    (0 macro-fact :exit 6)))))
 552
 553 (with-test (:name (trace :labels :within-macro)
 554                   . #.*breakpoint-tracing-expectations*)
 555   (assert (equal (collecting-traces ((labels fact :in macro-fact))
 556                    (macroexpand-1 '(macro-fact 0)))
 557                  '((0 (labels fact :in macro-fact) :enter 0)
 558                    (0 (labels fact :in macro-fact) :exit 1)))))
 559
 560 (defun call-with-macro-fact-redefined (fn)
 561   (handler-bind ((sb-kernel:redefinition-with-defmacro #'muffle-warning))
 562     (eval `(defmacro macro-fact (x)
 563              (declare (ignore x) (optimize (debug 3)))
 564              (labels ((fact () 'redefined)) (fact))))
 565     (unwind-protect
 566          (funcall fn)
 567       (eval `(defmacro macro-fact (x)
 568                (labels ((fact (x) (if (zerop x) 1 (* x (fact (1- x))))))
 569                  (fact x)))))))
 570
 571 #-(or ppc ppc64)
 572 (with-test (:name (trace :macro :redefined)
 573                   . #.*breakpoint-tracing-expectations*)
 574   (assert (equal (collecting-traces (macro-fact
 575                                      (labels fact :in macro-fact))
 576                    (macroexpand-1 '(macro-fact 0))
 577                    (call-with-macro-fact-redefined
 578                     (lambda () (macroexpand-1 '(macro-fact 0)))))
 579                  '((0 macro-fact :enter (macro-fact 0) "unused argument")
 580                    (1 (labels fact :in macro-fact) :enter 0)
 581                    (1 (labels fact :in macro-fact) :exit 1) (0 macro-fact :exit 1)
 582                    (0 macro-fact :enter (macro-fact 0) "unused argument")
 583                    (1 (labels fact :in macro-fact) :enter)
 584                    (1 (labels fact :in macro-fact) :exit redefined)
 585                    (0 macro-fact :exit redefined)))))
 586
 587 (defun (cas trace-cas) (old new x)
 588   (declare (optimize (debug 3)))
 589   (flet (((cas body) (o n)
 590            (+ o n x)))
 591     (cas (body) old new)))
 592
 593 (with-test (:name (trace :cas)
 594                   . #.*breakpoint-tracing-expectations*)
 595   (assert (equal (collecting-traces ((cas trace-cas)
 596                                      (flet (cas body) :in (cas trace-cas)))
 597                    (cas (trace-cas 1) 21 20))
 598                  '((0 (cas trace-cas) :enter 21 20 1)
 599                    (1 (flet (cas body) :in (cas trace-cas)) :enter 21 20)
 600                    (1 (flet (cas body) :in (cas trace-cas)) :exit 42)
 601                    (0 (cas trace-cas) :exit 42)))))
 602
 603 (defmethod (cas trace-cas-gf) (old new x)
 604   (declare (optimize (debug 3)))
 605   (flet (((cas body) (o n)
 606            (+ o n x)))
 607     (cas (body) old new)))
 608
 609 (with-test (:name (trace :cas :generic)
 610                   . #.*breakpoint-tracing-expectations*)
 611   (assert (equal (collecting-traces ((method (cas trace-cas-gf) (t t t))
 612                                      (flet (cas body) :in (method (cas trace-cas-gf) (t t t))))
 613                    (cas (trace-cas-gf 1) 21 20))
 614                  '((0 (method (cas trace-cas-gf) (t t t)) :enter 21 20 1)
 615                    (1 (flet (cas body) :in (method (cas trace-cas-gf) (t t t))) :enter 21 20)
 616                    (1 (flet (cas body) :in (method (cas trace-cas-gf) (t t t))) :exit 42)
 617                    (0 (method (cas trace-cas-gf) (t t t)) :exit 42)))))
 618
 619 (defun (setf trace-setf) (value x)
 620   (declare (optimize (debug 3)))
 621   (flet (((setf body) (value)
 622            (+ value x)))
 623     (setf (body) value)))
 624
 625 (with-test (:name (trace :setf)
 626                   . #.*breakpoint-tracing-expectations*)
 627   (assert (equal (collecting-traces ((setf trace-setf)
 628                                      (flet (setf body) :in (setf trace-setf)))
 629                    (setf (trace-setf 11) 31))
 630                  '((0 (setf trace-setf) :enter 31 11)
 631                    (1 (flet (setf body) :in (setf trace-setf)) :enter 31)
 632                    (1 (flet (setf body) :in (setf trace-setf)) :exit 42)
 633                    (0 (setf trace-setf) :exit 42)))))
 634
 635 (with-test (:name :bug-414)
 636   (handler-bind ((warning #'error))
 637     (with-scratch-file (output "fasl")
 638       (load (compile-file "bug-414.lisp" :output-file output
 639                                          :verbose nil :print nil)))
 640     (with-output-to-string (s)
 641       (disassemble 'bug-414 :stream s))))
 642
 643 ;; A known function can be stored as a code constant in lieu of the
 644 ;; usual mode of storing an #<fdefn> and looking up the function from it.
 645 ;; One such usage occurs with TAIL-CALL-VARIABLE (e.g. via APPLY).
 646 ;; Show that declaring the function locally notinline uses the #<fdefn>
 647 ;; by first compiling a call that would have elided the #<fdefn>
 648 ;; and then TRACE.
 649 ;; XXX: what purpose has the JUNK argument?
 650 (defun test-compile-then-load (filename junk)
 651   (declare (notinline compile-file load))
 652   (with-scratch-file (output "fasl")
 653     (apply 'load (apply 'compile-file filename :output-file output junk)
 654            junk)))
 655 (compile 'test-compile-then-load)
 656 (with-test (:name :traceable-known-fun)
 657   (let ((s (make-string-output-stream)))
 658     (trace compile-file load)
 659     (let ((*trace-output* s))
 660       (test-compile-then-load "bug-414.lisp" nil))
 661     (untrace)
 662     (assert (>= (count #\Newline (get-output-stream-string s)) 4))))
 663
 664 (with-test (:name :bug-310175)
 665   ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
 666   ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS.  Therefore,
 667   ;; use two-arg-LIST, which should get through to VOP LIST, and thus
 668   ;; stack-allocate on a predictable set of machines.
 669   (let ((dx-arg (list t t)))
 670     (declare (dynamic-extent dx-arg))
 671     (flet ((dx-arg-backtrace (x)
 672              (declare (optimize (debug 2)))
 673              (prog1 (sb-debug:list-backtrace :count 10)
 674                (assert (sb-debug::stack-allocated-p x)))))
 675       (declare (notinline dx-arg-backtrace))
 676       (assert (member-if (lambda (frame)
 677                            (and (consp frame)
 678                                 (consp (car frame))
 679                                 (equal '(flet dx-arg-backtrace :in) (butlast (car frame)))
 680                                 (notany #'sb-debug::stack-allocated-p (cdr frame))))
 681                          (dx-arg-backtrace dx-arg))))))
 682
 683 (with-test (:name :bug-795245)
 684   (assert
 685    (eq :ok
 686        (catch 'done
 687          (handler-bind
 688              ((error (lambda (e)
 689                        (declare (ignore e))
 690                        (handler-case
 691                            (sb-debug:print-backtrace :count 100
 692                                                      :stream (make-broadcast-stream))
 693                          (error ()
 694                            (throw 'done :error))
 695                          (:no-error ()
 696                            (throw 'done :ok))))))
 697            (apply '/= nil 1 2 nil))))))
 698
 699 ;;;; test infinite error protection
 700
 701 (defmacro nest-errors (n-levels error-form)
 702   (if (< 0 n-levels)
 703       `(handler-bind ((error (lambda (condition)
 704                                (declare (ignore condition))
 705                                ,error-form)))
 706         (nest-errors ,(1- n-levels) ,error-form))
 707       error-form))
 708
 709 (defun erroring-debugger-hook (condition old-debugger-hook)
 710   (let ((*debugger-hook* old-debugger-hook))
 711     (format t "recursive condition: ~A~%" condition) (force-output)
 712     (error "recursive condition: ~A" condition)))
 713
 714 (defun test-infinite-error-protection ()
 715   ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
 716   ;; to halt, it produces so much garbage that's hard to suppress that
 717   ;; it is tested only once
 718   (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
 719   (let ((*debugger-hook* #'erroring-debugger-hook))
 720     (loop repeat 1 do
 721           (let ((error-counter 0)
 722                 (*terminal-io* (make-broadcast-stream)))
 723             (assert
 724              (not (eq
 725                    :normal-exit
 726                    (catch 'sb-impl::toplevel-catcher
 727                      (nest-errors 20 (error "infinite error ~s"
 728                                             (incf error-counter)))
 729                      :normal-exit)))))))
 730   (write-line "--END OF H-B-A-B--"))
 731
 732 ;;; *debugger-hook* is now cleared after trying to enter the debugger
 733 ;;; *once in ERROR-ERROR, breaking these tests.
 734 (with-test (:name :infinite-error-protection
 735             :skipped-on :sbcl)
 736   (enable-debugger)
 737   (test-infinite-error-protection))
 738
 739 (with-test (:name (:infinite-error-protection :thread)
 740             :skipped-on (or :sbcl (not :sb-thread)))
 741   (enable-debugger)
 742   (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
 743     (loop while (sb-thread:thread-alive-p thread))))
 744
 745 ;; unconditional, in case either previous left it enabled
 746 (disable-debugger)
 747 \f
 748 ;;;; test some limitations of MAKE-LISP-OBJ
 749
 750 ;;; Older GENCGC systems had a bug in the pointer validation used by
 751 ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
 752 ;;; validate.
 753 (with-test (:name (:make-lisp-obj :simple-funs))
 754   (sb-sys:without-gcing
 755     (assert (eq #'identity
 756                 (sb-kernel:make-lisp-obj
 757                  (sb-kernel:get-lisp-obj-address
 758                   #'identity))))))
 759
 760 ;;; Older CHENEYGC systems didn't perform any real pointer validity
 761 ;;; checks beyond "is this pointer to somewhere in heap space".
 762 (with-test (:name (:make-lisp-obj :pointer-validation))
 763   ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
 764   ;; address, but we also need the GC to not pitch a fit if it sees an
 765   ;; object with said bogus address.  Thus, construct our known-bogus
 766   ;; object within an area of unboxed storage (a vector) in static
 767   ;; space.  We'll make it a simple object, (CONS 0 0), which has an
 768   ;; in-memory representation of two consecutive zero words.  We
 769   ;; allocate a three-word vector so that we can guarantee a
 770   ;; double-word aligned double-word of zeros no matter what happens
 771   ;; with the vector-data-offset (currently double-word aligned).
 772   (let* ((memory (sb-int:make-static-vector 3 :element-type `(unsigned-byte ,sb-vm:n-word-bits)
 773                                             :initial-element 0))
 774          (vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
 775          (object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
 776          (object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
 777     (multiple-value-bind (object valid-p)
 778         (sb-kernel:make-lisp-obj object-tagged-address nil)
 779       (declare (ignore object))
 780       (assert (not valid-p)))))
 781
 782 (defun test-debugger (control form &rest targets)
 783   (let ((out (make-string-output-stream))
 784         (oops t))
 785     (unwind-protect
 786          (progn
 787            (with-simple-restart (debugger-test-done! "Debugger Test Done!")
 788              (let* ((*debug-io* (make-two-way-stream
 789                                  (make-string-input-stream control)
 790                                  (make-broadcast-stream out #+nil *standard-output*)))
 791                     ;; Initial announcement goes to *ERROR-OUTPUT*
 792                     (*error-output* *debug-io*)
 793                     (*invoke-debugger-hook* nil))
 794                (handler-bind ((error #'invoke-debugger))
 795                  (eval form))))
 796            (setf oops nil))
 797       (when oops
 798         (error "Uncontrolled unwind from debugger test.")))
 799     ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
 800     ;; it could swallow our asserts!
 801     (with-input-from-string (s (get-output-stream-string out))
 802       (loop for line = (read-line s nil)
 803             while line
 804             do (assert targets nil "Line = ~a" line)
 805                #+nil
 806                (format *error-output* "Got: ~A~%" line)
 807                (let ((match (pop targets)))
 808                  (if (eq '* match)
 809                      ;; Whatever, till the next line matches.
 810                      (let ((text (pop targets)))
 811                        #+nil
 812                        (format *error-output* "Looking for: ~A~%" text)
 813                        (unless (search text line)
 814                          (push text targets)
 815                          (push match targets)))
 816                      (unless (search match line)
 817                        (format *error-output* "~&Wanted: ~S~%   Got: ~S~%" match line)
 818                        (setf oops t))))))
 819     ;; Check that we saw everything we wanted
 820     (when targets
 821       (error "Missed: ~S" targets))
 822     (assert (not oops))))
 823
 824 (with-test (:name (:debugger :source 1))
 825   (test-debugger
 826    "d
 827     source 0
 828     debugger-test-done!"
 829    `(progn
 830       (defun this-will-break (x)
 831                (declare (optimize debug))
 832                (let* ((y (- x x))
 833                       (z (/ x y)))
 834                  (+ x z)))
 835       (this-will-break 1))
 836    '*
 837    "debugger invoked"
 838    '*
 839    "DIVISION-BY-ZERO"
 840    "Operation was (/ 1 0)"
 841    '*
 842    "INTEGER-/-INTEGER"
 843    "(THIS-WILL-BREAK 1)"
 844    "1]"
 845    "(/ X Y)"
 846    "1]"))
 847
 848 (with-test (:name (:debugger :source 2))
 849   (test-debugger
 850    "d
 851     source 0
 852     debugger-test-done!"
 853    `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
 854       (let ((f #'(lambda (x cont)
 855                    (print x (make-broadcast-stream))
 856                    (if (zerop x)
 857                        (error "~%foo")
 858                        (funcall cont (1- x) cont)))))
 859         (funcall f 10 f)))
 860    '*
 861    "debugger"
 862    '*
 863    "foo"
 864    '*
 865    "source: (ERROR \"~%foo\")"
 866    '*
 867    "(LAMBDA (X CONT)"
 868    '*
 869    "(FUNCALL CONT (1- X) CONT)"
 870    "1]"))
 871
 872 (with-test (:name (:debugger :bogus-debug-fun :source) :skipped-on :ppc)
 873   (test-debugger
 874    "d
 875     debugger-test-done!"
 876    `(let ()
 877       (#.(gensym)))
 878    '*
 879    "undefined function"
 880    '*
 881    "1]"))
 882
 883 (with-test (:name (disassemble :high-debug-eval))
 884   (eval `(defun this-will-be-disassembled (x)
 885            (declare (optimize debug))
 886            (+ x x)))
 887   (let* ((oopses (make-string-output-stream))
 888          (disassembly
 889            (let ((*error-output* oopses))
 890              (with-output-to-string (*standard-output*)
 891                (disassemble 'this-will-be-disassembled)))))
 892     (with-input-from-string (s disassembly)
 893       (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
 894                       (read-line s))))
 895     (let ((problems (get-output-stream-string oopses)))
 896       (unless (zerop (length problems))
 897         (error problems)))))
 898
 899 (defun this-too-will-be-disasssembled (x)
 900   (declare (optimize debug))
 901   (+ x x))
 902
 903 (with-test (:name (disassemble :high-debug-load))
 904   (let* ((oopses (make-string-output-stream))
 905          (disassembly
 906            (let ((*error-output* oopses))
 907              (with-output-to-string (*standard-output*)
 908                (disassemble 'this-too-will-be-disasssembled)))))
 909     (with-input-from-string (s disassembly)
 910       (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
 911                      (read-line s))))
 912     (let ((problems (get-output-stream-string oopses)))
 913       (unless (zerop (length problems))
 914         (error problems)))))
 915
 916 (with-test (:name (:xep-arglist-clean-up :bug-1192929))
 917   (assert
 918    (block nil
 919      (handler-bind ((error (lambda (e)
 920                              (declare (ignore e))
 921                              (return (< (length (car (sb-debug:list-backtrace :count 1)))
 922                                         10)))))
 923        (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
 924
 925 ;;; bug-1261646
 926
 927 (defun print-backtrace-to-string/debug-print-variable-alist (x)
 928   (values
 929    (with-output-to-string (stream)
 930      (let ((*debug-print-variable-alist* '((*print-length* . 5)
 931                                            (*print-level* . 3))))
 932        (sb-debug:print-backtrace :stream stream :count 5)))
 933    x)) ; Force use of X to prevent flushing
 934
 935 (with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
 936                    *print-length* :bug-1261646))
 937   (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
 938                    (make-array 200 :initial-element 0)))
 939          (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
 940          (position (+ (search call printed) (length call))))
 941     (assert (eql position (search "#(0 0 0 0 0 ...)" printed :start2 position)))))
 942
 943 (with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
 944                    *print-level* :bug-1261646))
 945   (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
 946                    '(((((1)))))))
 947          (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
 948          (position (+ (search call printed) (length call))))
 949     (assert (eql position (search "((#))" printed :start2 position)))))
 950
 951
 952 (defvar *x* nil)
 953 (defun foo (a) a)
 954
 955 (with-test (:name :trace-debug-arg)
 956   (trace foo :print-after (setf *x* (sb-debug:arg 0)))
 957   (foo 1)
 958   (assert (eql *x* 1))
 959
 960   (trace foo :print (setf *x* (sb-debug:arg 0)))
 961   (foo 2)
 962   (assert (eql *x* 2))
 963
 964   (trace foo :condition (eql (setf *x* (sb-debug:arg 0)) 0))
 965   (foo 3)
 966   (assert (eql *x* 3))
 967
 968   (trace foo :condition-after (setf *x* (sb-debug:arg 0)))
 969   (foo 4)
 970   (assert (eql *x* 4))
 971
 972   (trace foo :break (and (setf *x* (sb-debug:arg 0)) nil))
 973   (foo 5)
 974   (assert (eql *x* 5))
 975
 976   (trace foo :break-all (and (setf *x* (sb-debug:arg 0)) nil))
 977   (foo 6)
 978   (assert (eql *x* 6))
 979   (trace foo :break-after (and (setf *x* (sb-debug:arg 0)) nil))
 980   (foo 7))
 981
 982 (defun frobbleize (arg) (declare (ignore arg)) (sb-debug:list-backtrace) 'win)
 983 (defmethod low-debug-method ((self t))
 984   (declare (optimize (debug 0)))
 985   (frobbleize 'me) ; make this not a tail call, so it remains on stack
 986   5)
 987 (with-test (:name :clean-fast-method-frame-lossage)
 988   (low-debug-method 42)) ; no need to assert. it either crashes or doesn't
 989
 990 (defun return-65535 ()
 991   65535)
 992
 993 (with-test (:name :indirect-closure-values)
 994   (let ((count 0))
 995     (block nil
 996       (handler-bind ((error (lambda (c)
 997                               (declare (ignore c))
 998                               (sb-debug:map-backtrace
 999                                (lambda (frame)
1000                                  (let ((sb-debug::*current-frame* frame)
1001                                        (name (sb-debug::frame-call frame)))
1002                                    (when (or (eq name 'test)
1003                                              (and (consp name)
1004                                                   (or (eql (search '(labels f1) name) 0)
1005                                                       (eql (search '(labels f2) name) 0))))
1006                                      (incf count)
1007                                      (assert (eql (var 'a) 2))))))
1008                               (return))))
1009         (funcall
1010          (compile nil
1011                   `(sb-int:named-lambda test ()
1012                      (declare (optimize debug))
1013                      (let ((a 1))
1014                        (labels
1015                            ((f1 ()
1016                               (incf a)
1017                               (signal 'error))
1018                             (f2 ()
1019                               (f1)))
1020                          (f2))))))))
1021     (assert (= count 3))))
1022
1023 (with-test (:name :indirect-closure-values.2)
1024   (let ((count 0))
1025     (block nil
1026       (handler-bind ((error (lambda (c)
1027                               (declare (ignore c))
1028                               (sb-debug:map-backtrace
1029                                (lambda (frame)
1030                                  (let ((sb-debug::*current-frame* frame)
1031                                        (name (sb-debug::frame-call frame)))
1032                                    (when (or (eq name 'test)
1033                                              (and (consp name)
1034                                                   (or (eql (search '(labels f1) name) 0)
1035                                                       (eql (search '(labels f2) name) 0))))
1036                                      (incf count)
1037                                      (assert (eql (var 'a) 65535))))))
1038                               (return))))
1039         (funcall
1040          (compile nil
1041                   `(sb-int:named-lambda test ()
1042                      (declare (optimize debug))
1043                      (let ((a (return-65535)))
1044                        (declare ((unsigned-byte 16) a))
1045                        (labels
1046                            ((f1 ()
1047                               (incf a)
1048                               (signal 'error))
1049                             (f2 ()
1050                               (f1)))
1051                          (f2))))))))
1052     (assert (= count 3))))
1053
1054 (with-test (:name :indirect-closure-values.crash)
1055   (block nil
1056     (handler-bind ((error (lambda (c)
1057                             (declare (ignore c))
1058                             (sb-debug:map-backtrace
1059                              (lambda (frame)
1060                                (let ((name (sb-debug::frame-call frame))
1061                                      (location (sb-debug::frame-code-location frame))
1062                                      (d-fun (sb-debug::frame-debug-fun frame)))
1063                                  (when (eq name 'test)
1064                                    (assert (sb-debug::debug-var-info-available d-fun))
1065                                    (dolist (v (sb-debug::ambiguous-debug-vars d-fun ""))
1066                                      (assert (not (sb-debug::var-valid-in-frame-p v location frame))))
1067                                    (return))))))))
1068       (funcall
1069        (compile nil
1070                 `(sb-int:named-lambda test ()
1071                    (declare (optimize debug safety))
1072                    (signal 'error)
1073                    (let ((protos '()))
1074                      (mapcar (lambda (x)
1075                                (print x))
1076                              protos))))))))
1077
1078 (with-test (:name :non-tail-self-call-bad-variables)
1079   (let ((count 0))
1080     (block nil
1081       (handler-bind ((error (lambda (c)
1082                               (declare (ignore c))
1083                               (sb-debug:map-backtrace
1084                                (lambda (frame)
1085                                  (let ((sb-debug::*current-frame* frame))
1086                                    (multiple-value-bind (name args)
1087                                        (sb-debug::frame-call frame)
1088                                      (when (eq name 'test)
1089                                        (assert (or (null args)
1090                                                    (equal args '(nil))))
1091                                        (incf count))))))
1092                               (return))))
1093         (funcall
1094          (compile nil `(sb-int:named-lambda test (&optional x)
1095                          (declare (optimize sb-c::recognize-self-calls))
1096                          (signal 'error :format-control "~a" :format-arguments (list x))
1097                          (test 1)
1098                          1)))))
1099     (assert (= count 1))))
1100
1101 (with-test (:name :local-tail-call-variables)
1102   (let ((count 0))
1103     (block nil
1104       (handler-bind ((error (lambda (c)
1105                               (declare (ignore c))
1106                               (sb-debug:map-backtrace
1107                                (lambda (frame)
1108                                  (let ((sb-debug::*current-frame* frame))
1109                                    (multiple-value-bind (name args)
1110                                        (sb-debug::frame-call frame)
1111                                      (when (eq name 'test)
1112                                        (assert (equal args '(error)))
1113                                        (incf count))))))
1114                               (return))))
1115         (funcall
1116          (compile nil `(sb-int:named-lambda test (x)
1117                          (signal x)
1118                          ;; If :local-tail-call fails, this will fail
1119                          ;; too, because there's no jump between
1120                          ;; SIGNAL and the call to TAIL and it will
1121                          ;; show (flet tail) in the backtrace.
1122                          (flet ((tail ()))
1123                            (declare (notinline tail))
1124                            (tail))))
1125          'error)))
1126     (assert (= count 1))))
1127
1128 (with-test (:name :variables-surrounding-inlined-code)
1129   (let ((count 0))
1130     (block nil
1131       (handler-bind ((error (lambda (c)
1132                               (declare (ignore c))
1133                               (sb-debug:map-backtrace
1134                                (lambda (frame)
1135                                  (let ((sb-debug::*current-frame* frame))
1136                                    (multiple-value-bind (name)
1137                                        (sb-debug::frame-call frame)
1138                                      (when (eq name 'test)
1139                                        (assert (equal (sb-debug:var 'l) '(1 2 3)))
1140                                        (incf count))))))
1141                               (return))))
1142         (funcall
1143          (compile nil `(sb-int:named-lambda test (a i)
1144                          (declare (optimize (debug 3)))
1145                          (let ((l (list 1 2 3)))
1146                            (aref a i)
1147                            l)))
1148          #(1) 2)))
1149     (assert (= count 1))))
1150
1151 (with-test (:name :variables-surrounding-inlined-code.2)
1152   (let ((count 0))
1153     (block nil
1154       (handler-bind ((error (lambda (c)
1155                               (declare (ignore c))
1156                               (sb-debug:map-backtrace
1157                                (lambda (frame)
1158                                  (let ((sb-debug::*current-frame* frame))
1159                                    (multiple-value-bind (name)
1160                                        (sb-debug::frame-call frame)
1161                                      (when (eq name 'test)
1162                                        (assert (equal (sb-debug:var 'l) '(1 2 3)))
1163                                        (incf count))))))
1164                               (return))))
1165         (funcall
1166          (compile nil `(sb-int:named-lambda test (c)
1167                          (declare (optimize (debug 3)))
1168                          (let ((l (list 1 2 3)))
1169                            (map 'list #'signal c)
1170                            l)))
1171          '(error))))
1172     (assert (= count 1))))
1173
1174 (with-test (:name :properly-tagged-p-internal)
1175   ;; Pick a code component that has a ton of restarts.
1176   (let* ((code (sb-kernel:fun-code-header #'sb-impl::update-package-with-variance))
1177          (n (sb-kernel:code-n-entries code)))
1178     (sb-sys:with-pinned-objects (code)
1179       (let* ((base (logandc2 (sb-kernel:get-lisp-obj-address code)
1180                              sb-vm:lowtag-mask))
1181              (limit (+ base (sb-ext:primitive-object-size code))))
1182         (flet ((properly-tagged-p (ptr)
1183                  (eql (alien-funcall (extern-alien "properly_tagged_p_internal"
1184                                                    (function int unsigned unsigned))
1185                                      ptr base)
1186                       1)))
1187           ;; For architectures that don't use LRAs, there are exactly 'n-entries'
1188           ;; properly tagged interior pointers. For those which do use LRAs,
1189           ;; there are at least that many, because we allow pointing to LRAs,
1190           ;; but they aren't enumerable so we don't know the actual count.
1191           (assert (#+(or x86 x86-64 arm64) =
1192                    #-(or x86 x86-64 arm64) >
1193                      (loop for ptr from (+ base (* 2 sb-vm:n-word-bytes))
1194                            below limit count (properly-tagged-p ptr))
1195                      n))
1196           ;; Verify that the binary search algorithm for simple-fun-index works.
1197           (let ((count 0))
1198             (loop for ptr from base below limit
1199                   do
1200                (let ((index (alien-funcall
1201                              (extern-alien "simple_fun_index"
1202                                            (function int unsigned unsigned))
1203                              base ptr)))
1204                  (unless (eql index -1)
1205                    (let ((tagged-fun (logior ptr sb-vm:fun-pointer-lowtag)))
1206                      (assert (properly-tagged-p tagged-fun))
1207                      (incf count)
1208                      #+nil
1209                      (format t "~x -> ~d (~a)~%"
1210                              ptr index (sb-kernel:make-lisp-obj tagged-fun))))))
1211             (assert (= count n))))))))
1212
1213 (with-test (:name :repeatable-fasl)
1214   (with-scratch-file (output1 "fasl")
1215     (compile-file "bug-414.lisp" ; compile this file, why not
1216                   ::output-file output1 :verbose nil :print nil)
1217     (with-scratch-file (output2 "fasl")
1218       (compile-file "bug-414.lisp" ; compile this file, why not
1219                     ::output-file output2 :verbose nil :print nil)
1220       (with-open-file (fasl1 output1 :element-type '(unsigned-byte 8))
1221         (with-open-file (fasl2 output2 :element-type '(unsigned-byte 8))
1222           (assert (= (file-length fasl1) (file-length fasl2)))
1223           (loop repeat (file-length fasl1)
1224                 do (assert (= (read-byte fasl1) (read-byte fasl2)))))))))
1225
1226 ;; lp#1901781
1227 (defun ll-unknown (x y) (declare (optimize (debug 0))) (+ x y))
1228 (compile 'll-unknown)
1229 (with-test (:name :unknown-lambda-list)
1230   (assert (eq (sb-kernel:%fun-lambda-list #'ll-unknown) :unknown)))
1231
1232 ;;;; SB-DEBUG:*STACK-TOP-HINT* management
1233
1234 (defun buggy-handler (c)
1235   (declare (ignore c))
1236   ;; signal a nondescript condition to avoid triggering WITH-TEST's error
1237   ;; handling.
1238   (error 'simple-condition :format-control "buggy handler"))
1239
1240 (defun signal-and-handle-with-buggy-handler ()
1241   (handler-bind ((program-error #'buggy-handler))
1242     (signal 'program-error)))
1243
1244 (defun call-getting-stack-top-on-invoke-debugger (fn)
1245   (block nil
1246     (let ((*invoke-debugger-hook*
1247             (lambda (condition hook)
1248               (declare (ignore condition hook))
1249               (let ((top (sb-debug::resolve-stack-top-hint)))
1250                 (return (caar (sb-debug:list-backtrace :from top)))))))
1251       (funcall fn))))
1252
1253 (defun ds-bind-when (x)
1254   (when x
1255     (sb-c::ds-bind-error '(foo) 2 3 '((:macro baz . deftype))))
1256   (print "something to prevent tco"))
1257
1258 (with-test (:name (:stack-top-hint :arg-count-error))
1259   (assert (eq 'ds-bind-when
1260               (block nil
1261                 (handler-bind ((error
1262                                  (lambda (c)
1263                                    (declare (ignore c))
1264                                    (let ((top (sb-debug::resolve-stack-top-hint)))
1265                                      (return (caar (sb-debug:list-backtrace :from top)))))))
1266                   (ds-bind-when t))))))
1267
1268 ;; If an error occurs within a signal handler, we want to see the handling
1269 ;; frames in the backtrace.
1270 (with-test (:name (:stack-top-hint :signal))
1271   (assert (eq 'buggy-handler
1272               (call-getting-stack-top-on-invoke-debugger
1273                #'signal-and-handle-with-buggy-handler))))
1274
1275 ;; When breaking on signals, we don't need to see the SIGNAL frame or other
1276 ;; frames above that.
1277 (with-test (:name (:stack-top-hint :signal :break-on-signals))
1278   (assert (eq 'signal-and-handle-with-buggy-handler
1279               (let ((*break-on-signals* t))
1280                 (call-getting-stack-top-on-invoke-debugger
1281                  #'signal-and-handle-with-buggy-handler)))))