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 ;;; FIXME: This should use some get-argslist like functionality that
  26 ;;; we actually export.
  27 ;;;
  28 ;;; Return the debug arglist of the function object FUN as a list, or
  29 ;;; punt with :UNKNOWN.
  30 (defun get-arglist (fun)
  31   (declare (type function fun))
  32   ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
  33   (case (sb-kernel:widetag-of fun)
  34     (#.sb-vm:simple-fun-header-widetag
  35       (sb-kernel:%simple-fun-arglist fun))
  36     (#.sb-vm:closure-header-widetag
  37      (get-arglist (sb-kernel:%closure-fun fun)))
  38     ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
  39     ;; like above, and it seems to work. -- MNA 2001-06-12
  40     ;;
  41     ;; (There might be other cases with arglist info also.
  42     ;; SIMPLE-FUN-HEADER-WIDETAG and CLOSURE-HEADER-WIDETAG just
  43     ;; happen to be the two case that I had my nose rubbed in when
  44     ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
  45     ;; a closure. -- WHN 2001-06-05)
  46     (t
  47      #+sb-eval
  48      (if (typep fun 'sb-eval::interpreted-function)
  49          (sb-eval::interpreted-function-lambda-list fun)
  50          :unknown)
  51      #-sb-eval
  52      :unknown)))
  53
  54 (defun zoop (zeep &key beep)
  55   blurp)
  56 (assert (equal (get-arglist #'zoop) '(zeep &key beep)))
  57
  58 ;;; Check some predefined functions too.
  59 ;;;
  60 ;;; (We don't know exactly what the arguments are, e.g. the first
  61 ;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
  62 ;;; whatever. But we do know the general structure that a correct
  63 ;;; answer should have, so we can safely do a lot of checks.)
  64 (with-test (:name :predefined-functions-1)
  65   (destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
  66     (assert (symbolp object-sym))
  67     (assert (eql &optional-sym '&optional))
  68     (assert (symbolp stream-sym))))
  69
  70 (with-test (:name :predefined-functions-2)
  71   (destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
  72       (get-arglist #'format)
  73     (assert (symbolp dest-sym))
  74     (assert (symbolp control-sym))
  75     (assert (eql &rest-sym '&rest))
  76     (assert (symbolp format-args-sym))))
  77
  78 ;;;; test TRACE
  79
  80 (defmacro with-traced-function ((name &rest options) &body body)
  81   `(with-output-to-string (*trace-output*)
  82      (unwind-protect
  83           (progn
  84             (trace ,name ,@options)
  85             ,@body)
  86        (ignore-errors (untrace ,name)))))
  87
  88 (defun trace-this ()
  89   'ok)
  90
  91 (defun trace-fact (n)
  92   (if (zerop n)
  93       1
  94       (* n (trace-fact (1- n)))))
  95
  96 (with-test (:name (trace :simple))
  97   (let ((output (with-traced-function (trace-this)
  98                   (assert (eq 'ok (trace-this))))))
  99     (assert (search "TRACE-THIS" output))
 100     (assert (search "returned OK" output))))
 101
 102 ;;; bug 379
 103 ;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
 104 ;;; suspicions that the breakpoint trace might corrupt the whole image
 105 ;;; on that platform.
 106 (with-test (:name (trace :encapsulate nil)
 107             :fails-on '(or (and :ppc (not :linux)) :sparc :arm64)
 108             :broken-on '(or :darwin :sunos :hppa))
 109   (let ((output (with-traced-function (trace-this :encapsulate nil)
 110                   (assert (eq 'ok (trace-this))))))
 111     (assert (search "TRACE-THIS" output))
 112     (assert (search "returned OK" output))))
 113
 114 (with-test (:name (:trace :encapsulate nil :recursive)
 115             :fails-on '(or (and :ppc (not :linux)) :sparc :sunos :arm64)
 116             :broken-on '(or :darwin (and :x86 :sunos) :hppa))
 117   (let ((output (with-traced-function (trace-fact :encapsulate nil)
 118                   (assert (= 120 (trace-fact 5))))))
 119     (assert (search "TRACE-FACT" output))
 120     (assert (search "returned 1" output))
 121     (assert (search "returned 120" output))))
 122
 123 (defun trace-and-fmakunbound-this (x)
 124   x)
 125
 126 (with-test (:name (trace fmakunbound :bug-667657))
 127   (trace trace-and-fmakunbound-this)
 128   (fmakunbound 'trace-and-fmakunbound-this)
 129   (untrace)
 130   (assert (not (trace))))
 131
 132 (with-test (:name (trace :report nil :smoke))
 133   (let ((output (with-traced-function (trace-this :report nil)
 134                   (assert (eq 'ok (trace-this))))))
 135     (assert (sequence:emptyp output))))
 136
 137 (with-test (:name (trace :report nil :print))
 138   (let ((output (with-traced-function
 139                     (trace-fact :report nil :print (sb-debug:arg 0))
 140                   (assert (eq '2 (trace-fact 2))))))
 141     (assert (string= output (format nil "2~@
 142                                          1~@
 143                                          0~%")))))
 144
 145 (with-test (:name :bug-414)
 146   (handler-bind ((warning #'error))
 147     (load (compile-file "bug-414.lisp"))
 148     (disassemble 'bug-414)))
 149
 150 ;; A known function can be stored as a code constant in lieu of the
 151 ;; usual mode of storing an #<fdefn> and looking up the function from it.
 152 ;; One such usage occurs with TAIL-CALL-VARIABLE (e.g. via APPLY).
 153 ;; Show that declaring the function locally notinline uses the #<fdefn>
 154 ;; by first compiling a call that would have elided the #<fdefn>
 155 ;; and then TRACE.
 156 (defun test-compile-then-load (filename junk)
 157   (declare (notinline compile-file load))
 158   (apply 'load (apply 'compile-file filename junk) junk))
 159 (compile 'test-compile-then-load)
 160 (with-test (:name :traceable-known-fun)
 161   (let ((s (make-string-output-stream)))
 162     (trace compile-file load)
 163     (let ((*trace-output* s))
 164       (test-compile-then-load "bug-414.lisp" nil))
 165     (untrace)
 166     (assert (>= (count #\Newline (get-output-stream-string s)) 4))))
 167
 168 (with-test (:name :bug-310175 :fails-on '(not :stack-allocatable-lists))
 169   ;; KLUDGE: Not all DX-enabled platforms DX CONS, and the compiler
 170   ;; transforms two-arg-LIST* (and one-arg-LIST) to CONS.  Therefore,
 171   ;; use two-arg-LIST, which should get through to VOP LIST, and thus
 172   ;; stack-allocate on a predictable set of machines.
 173   (let ((dx-arg (list t t)))
 174     (declare (dynamic-extent dx-arg))
 175     (flet ((dx-arg-backtrace (x)
 176              (declare (optimize (debug 2)))
 177              (prog1 (sb-debug:list-backtrace :count 10)
 178                (assert (sb-debug::stack-allocated-p x)))))
 179       (declare (notinline dx-arg-backtrace))
 180       (assert (member-if (lambda (frame)
 181                            (and (consp frame)
 182                                 (consp (car frame))
 183                                 (equal '(flet dx-arg-backtrace :in) (butlast (car frame)))
 184                                 (notany #'sb-debug::stack-allocated-p (cdr frame))))
 185                          (dx-arg-backtrace dx-arg))))))
 186
 187 (with-test (:name :bug-795245)
 188   (assert
 189    (eq :ok
 190        (catch 'done
 191          (handler-bind
 192              ((error (lambda (e)
 193                        (declare (ignore e))
 194                        (handler-case
 195                            (sb-debug:print-backtrace :count 100
 196                                                      :stream (make-broadcast-stream))
 197                          (error ()
 198                            (throw 'done :error))
 199                          (:no-error ()
 200                            (throw 'done :ok))))))
 201            (apply '/= nil 1 2 nil))))))
 202
 203 ;;;; test infinite error protection
 204
 205 (defmacro nest-errors (n-levels error-form)
 206   (if (< 0 n-levels)
 207       `(handler-bind ((error (lambda (condition)
 208                                (declare (ignore condition))
 209                                ,error-form)))
 210         (nest-errors ,(1- n-levels) ,error-form))
 211       error-form))
 212
 213 (defun erroring-debugger-hook (condition old-debugger-hook)
 214   (let ((*debugger-hook* old-debugger-hook))
 215     (format t "recursive condition: ~A~%" condition) (force-output)
 216     (error "recursive condition: ~A" condition)))
 217
 218 (defun test-infinite-error-protection ()
 219   ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
 220   ;; to halt, it produces so much garbage that's hard to suppress that
 221   ;; it is tested only once
 222   (write-line "--HARMLESS BUT ALARMING BACKTRACE COMING UP--")
 223   (let ((*debugger-hook* #'erroring-debugger-hook))
 224     (loop repeat 1 do
 225           (let ((error-counter 0)
 226                 (*terminal-io* (make-broadcast-stream)))
 227             (assert
 228              (not (eq
 229                    :normal-exit
 230                    (catch 'sb-impl::toplevel-catcher
 231                      (nest-errors 20 (error "infinite error ~s"
 232                                             (incf error-counter)))
 233                      :normal-exit)))))))
 234   (write-line "--END OF H-B-A-B--"))
 235
 236 (with-test (:name :infinite-error-protection)
 237   (enable-debugger)
 238   (test-infinite-error-protection))
 239
 240 (with-test (:name (:infinite-error-protection :thread)
 241                   :skipped-on '(not :sb-thread))
 242   (enable-debugger)
 243   (let ((thread (sb-thread:make-thread #'test-infinite-error-protection)))
 244     (loop while (sb-thread:thread-alive-p thread))))
 245
 246 ;; unconditional, in case either previous left it enabled
 247 (disable-debugger)
 248 \f
 249 ;;;; test some limitations of MAKE-LISP-OBJ
 250
 251 ;;; Older GENCGC systems had a bug in the pointer validation used by
 252 ;;; MAKE-LISP-OBJ that made SIMPLE-FUN objects always fail to
 253 ;;; validate.
 254 (with-test (:name (:make-lisp-obj :simple-funs))
 255   (sb-sys:without-gcing
 256     (assert (eq #'identity
 257                 (sb-kernel:make-lisp-obj
 258                  (sb-kernel:get-lisp-obj-address
 259                   #'identity))))))
 260
 261 ;;; Older CHENEYGC systems didn't perform any real pointer validity
 262 ;;; checks beyond "is this pointer to somewhere in heap space".
 263 (with-test (:name (:make-lisp-obj :pointer-validation))
 264   ;; Fun and games: We need to test MAKE-LISP-OBJ with a known-bogus
 265   ;; address, but we also need the GC to not pitch a fit if it sees an
 266   ;; object with said bogus address.  Thus, construct our known-bogus
 267   ;; object within an area of unboxed storage (a vector) in static
 268   ;; space.  We'll make it a simple object, (CONS 0 0), which has an
 269   ;; in-memory representation of two consecutive zero words.  We
 270   ;; allocate a three-word vector so that we can guarantee a
 271   ;; double-word aligned double-word of zeros no matter what happens
 272   ;; with the vector-data-offset (currently double-word aligned).
 273   (let* ((memory (sb-int:make-static-vector 3 :element-type `(unsigned-byte ,sb-vm:n-word-bits)
 274                                             :initial-element 0))
 275          (vector-data-address (sb-sys:sap-int (sb-kernel::vector-sap memory)))
 276          (object-base-address (logandc2 (+ vector-data-address sb-vm:lowtag-mask) sb-vm:lowtag-mask))
 277          (object-tagged-address (+ object-base-address sb-vm:list-pointer-lowtag)))
 278     (multiple-value-bind (object valid-p)
 279         (sb-kernel:make-lisp-obj object-tagged-address nil)
 280       (declare (ignore object))
 281       (assert (not valid-p)))))
 282
 283 (defun test-debugger (control form &rest targets)
 284   (let ((out (make-string-output-stream))
 285         (oops t))
 286     (unwind-protect
 287          (progn
 288            (with-simple-restart (debugger-test-done! "Debugger Test Done!")
 289              (let* ((*debug-io* (make-two-way-stream
 290                                  (make-string-input-stream control)
 291                                  (make-broadcast-stream out #+nil *standard-output*)))
 292                     ;; Initial announcement goes to *ERROR-OUTPUT*
 293                     (*error-output* *debug-io*)
 294                     (*invoke-debugger-hook* nil))
 295                (handler-bind ((error #'invoke-debugger))
 296                  (eval form))))
 297            (setf oops nil))
 298       (when oops
 299         (error "Uncontrolled unwind from debugger test.")))
 300     ;; For sanity's sake this is outside the *debug-io* rebinding -- otherwise
 301     ;; it could swallow our asserts!
 302     (with-input-from-string (s (get-output-stream-string out))
 303       (loop for line = (read-line s nil)
 304             while line
 305             do (assert targets nil "Line = ~a" line)
 306                #+nil
 307                (format *error-output* "Got: ~A~%" line)
 308                (let ((match (pop targets)))
 309                  (if (eq '* match)
 310                      ;; Whatever, till the next line matches.
 311                      (let ((text (pop targets)))
 312                        #+nil
 313                        (format *error-output* "Looking for: ~A~%" text)
 314                        (unless (search text line)
 315                          (push text targets)
 316                          (push match targets)))
 317                      (unless (search match line)
 318                        (format *error-output* "~&Wanted: ~S~%   Got: ~S~%" match line)
 319                        (setf oops t))))))
 320     ;; Check that we saw everything we wanted
 321     (when targets
 322       (error "Missed: ~S" targets))
 323     (assert (not oops))))
 324
 325 (with-test (:name (:debugger :source 1)
 326             ;; Division is done by an assembly routine on ppc
 327             ;; and it can't locate the div-by-zero error there
 328             :fails-on :ppc)
 329   (test-debugger
 330    "d
 331     source 0
 332     debugger-test-done!"
 333    `(progn
 334       (defun this-will-break (x)
 335                (declare (optimize debug))
 336                (let* ((y (- x x))
 337                       (z (/ x y)))
 338                  (+ x z)))
 339       (this-will-break 1))
 340    '*
 341    "debugger invoked"
 342    '*
 343    "DIVISION-BY-ZERO"
 344    "Operation was (/ 1 0)"
 345    '*
 346    "INTEGER-/-INTEGER"
 347    "(THIS-WILL-BREAK 1)"
 348    "1]"
 349    "(/ X Y)"
 350    "1]"))
 351
 352 (with-test (:name (:debugger :source 2))
 353   (test-debugger
 354    "d
 355     source 0
 356     debugger-test-done!"
 357    `(locally (declare (optimize (speed 0) (safety 3) (debug 3)))
 358       (let ((f #'(lambda (x cont)
 359                    (print x (make-broadcast-stream))
 360                    (if (zerop x)
 361                        (error "~%foo")
 362                        (funcall cont (1- x) cont)))))
 363         (funcall f 10 f)))
 364    '*
 365    "debugger"
 366    '*
 367    "foo"
 368    '*
 369    "source: (ERROR \"~%foo\")"
 370    '*
 371    "(LAMBDA (X CONT)"
 372    '*
 373    "(FUNCALL CONT (1- X) CONT)"
 374    "1]"))
 375
 376 (with-test (:name (:debugger :bogus-debug-fun :source))
 377   (test-debugger
 378    "d
 379     debugger-test-done!"
 380    `(let ()
 381       (#.(gensym)))
 382    '*
 383    "undefined function"
 384    '*
 385    "1]"))
 386
 387 (with-test (:name (disassemble :high-debug-eval))
 388   (eval `(defun this-will-be-disassembled (x)
 389            (declare (optimize debug))
 390            (+ x x)))
 391   (let* ((oopses (make-string-output-stream))
 392          (disassembly
 393            (let ((*error-output* oopses))
 394              (with-output-to-string (*standard-output*)
 395                (disassemble 'this-will-be-disassembled)))))
 396     (with-input-from-string (s disassembly)
 397       (assert (search "; disassembly for THIS-WILL-BE-DISASSEMBLED"
 398                       (read-line s))))
 399     (let ((problems (get-output-stream-string oopses)))
 400       (unless (zerop (length problems))
 401         (error problems)))))
 402
 403 (defun this-too-will-be-disasssembled (x)
 404   (declare (optimize debug))
 405   (+ x x))
 406
 407 (with-test (:name (disassemble :high-debug-load))
 408   (let* ((oopses (make-string-output-stream))
 409          (disassembly
 410            (let ((*error-output* oopses))
 411              (with-output-to-string (*standard-output*)
 412                (disassemble 'this-too-will-be-disasssembled)))))
 413     (with-input-from-string (s disassembly)
 414       (assert (equal "; disassembly for THIS-TOO-WILL-BE-DISASSSEMBLED"
 415                      (read-line s))))
 416     (let ((problems (get-output-stream-string oopses)))
 417       (unless (zerop (length problems))
 418         (error problems)))))
 419
 420 ;; The test named :GF-dispatch-backtrace depends on the fact that renaming
 421 ;; a closure works, and that the debugger can extract a closure name.
 422 ;; First things first: verify that a closure can be named.
 423 (defun make-adder (x)
 424   (sb-impl::set-closure-name (lambda (y) (+ x y)) `(adder ,x)))
 425 (with-test (:name :closure-renaming-really-works)
 426   (let ((f1 (make-adder 5))
 427         (expect "#<CLOSURE (ADDER 5)"))
 428     (assert (= (mismatch (write-to-string (make-adder 5)) expect)
 429                (length expect)))
 430     (assert (and (eq (sb-impl::set-closure-name f1 "ADD5") f1)
 431                  (string= (sb-impl::%fun-name f1) "ADD5")))))
 432
 433 (with-test (:name (:xep-arglist-clean-up :bug-1192929))
 434   (assert
 435    (block nil
 436      (handler-bind ((error (lambda (e)
 437                              (declare (ignore e))
 438                              (return (< (length (car (sb-debug:list-backtrace :count 1)))
 439                                         10)))))
 440        (funcall (compile nil `(lambda (i) (declare ((mod 65536) i)) i)) nil)))))
 441
 442 ;;; bug-1261646
 443
 444 (defun print-backtrace-to-string/debug-print-variable-alist (x)
 445   (values
 446    (with-output-to-string (stream)
 447      (let ((*debug-print-variable-alist* '((*print-length* . 5)
 448                                            (*print-level* . 3))))
 449        (sb-debug:print-backtrace :stream stream :count 5)))
 450    x)) ; Force use of X to prevent flushing
 451
 452 (with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
 453                    *print-length* :bug-1261646))
 454   (let* ((printed (print-backtrace-to-string/debug-print-variable-alist (make-array 200)))
 455          (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
 456          (position (+ (search call printed) (length call))))
 457     (assert (eql position (search "#(0 0 0 0 0 ...)" printed :start2 position)))))
 458
 459 (with-test (:name (:print-frame-call :respect *debug-print-variable-alist*
 460                    *print-level* :bug-1261646))
 461   (let* ((printed (print-backtrace-to-string/debug-print-variable-alist
 462                    '(((((1)))))))
 463          (call "(PRINT-BACKTRACE-TO-STRING/DEBUG-PRINT-VARIABLE-ALIST ")
 464          (position (+ (search call printed) (length call))))
 465     (assert (eql position (search "((#))" printed :start2 position)))))
 466
 467
 468 (defvar *x* nil)
 469 (defun foo (a) a)
 470
 471 (with-test (:name :trace-debug-arg)
 472   (trace foo :print-after (setf *x* (sb-debug:arg 0)))
 473   (foo 1)
 474   (assert (eql *x* 1))
 475
 476   (trace foo :print (setf *x* (sb-debug:arg 0)))
 477   (foo 2)
 478   (assert (eql *x* 2))
 479
 480   (trace foo :condition (eql (setf *x* (sb-debug:arg 0)) 0))
 481   (foo 3)
 482   (assert (eql *x* 3))
 483
 484   (trace foo :condition-after (setf *x* (sb-debug:arg 0)))
 485   (foo 4)
 486   (assert (eql *x* 4))
 487
 488   (trace foo :break (and (setf *x* (sb-debug:arg 0)) nil))
 489   (foo 5)
 490   (assert (eql *x* 5))
 491
 492   (trace foo :break-all (and (setf *x* (sb-debug:arg 0)) nil))
 493   (foo 6)
 494   (assert (eql *x* 6))
 495   (trace foo :break-after (and (setf *x* (sb-debug:arg 0)) nil))
 496   (foo 7))
 497
 498 (defun frobbleize (arg) (declare (ignore arg)) (sb-debug:list-backtrace) 'win)
 499 (defmethod low-debug-method ((self t))
 500   (declare (optimize (debug 0)))
 501   (frobbleize 'me) ; make this not a tail call, so it remains on stack
 502   5)
 503 (with-test (:name :clean-fast-method-frame-lossage)
 504   (low-debug-method 42)) ; no need to assert. it either crashes or doesn't
 505
 506 (defun return-65535 ()
 507   65535)
 508
 509 (with-test (:name :indirect-closure-values)
 510   (let ((count 0))
 511     (block nil
 512       (handler-bind ((error (lambda (c)
 513                               (declare (ignore c))
 514                               (sb-debug::map-backtrace
 515                                (lambda (frame)
 516                                  (let ((sb-debug::*current-frame* frame)
 517                                        (name (sb-debug::frame-call frame)))
 518                                    (when (or (eq name 'test)
 519                                              (and (consp name)
 520                                                   (or (eql (search '(labels f1) name) 0)
 521                                                       (eql (search '(labels f2) name) 0))))
 522                                      (incf count)
 523                                      (assert (eql (var 'a) 2))))))
 524                               (return))))
 525         (funcall
 526          (compile nil
 527                   `(sb-int:named-lambda test ()
 528                      (declare (optimize debug))
 529                      (let ((a 1))
 530                        (labels
 531                            ((f1 ()
 532                               (incf a)
 533                               (signal 'error))
 534                             (f2 ()
 535                               (f1)))
 536                          (f2))))))))
 537     (assert (= count 3))))
 538
 539 (with-test (:name :indirect-closure-values.2)
 540   (let ((count 0))
 541     (block nil
 542       (handler-bind ((error (lambda (c)
 543                               (declare (ignore c))
 544                               (sb-debug::map-backtrace
 545                                (lambda (frame)
 546                                  (let ((sb-debug::*current-frame* frame)
 547                                        (name (sb-debug::frame-call frame)))
 548                                    (when (or (eq name 'test)
 549                                              (and (consp name)
 550                                                   (or (eql (search '(labels f1) name) 0)
 551                                                       (eql (search '(labels f2) name) 0))))
 552                                      (incf count)
 553                                      (assert (eql (var 'a) 65535))))))
 554                               (return))))
 555         (funcall
 556          (compile nil
 557                   `(sb-int:named-lambda test ()
 558                      (declare (optimize debug))
 559                      (let ((a (return-65535)))
 560                        (declare ((unsigned-byte 16) a))
 561                        (labels
 562                            ((f1 ()
 563                               (incf a)
 564                               (signal 'error))
 565                             (f2 ()
 566                               (f1)))
 567                          (f2))))))))
 568     (assert (= count 3))))
 569
 570 (with-test (:name :non-tail-self-call-bad-variables)
 571   (let ((count 0))
 572     (block nil
 573       (handler-bind ((error (lambda (c)
 574                               (declare (ignore c))
 575                               (sb-debug::map-backtrace
 576                                (lambda (frame)
 577                                  (let ((sb-debug::*current-frame* frame))
 578                                    (multiple-value-bind (name args)
 579                                        (sb-debug::frame-call frame)
 580                                      (when (eq name 'test)
 581                                        (assert (or (null args)
 582                                                    (equal args '(nil))))
 583                                        (incf count))))))
 584                               (return))))
 585         (funcall
 586          (compile nil `(sb-int:named-lambda test (&optional x)
 587                          (declare (optimize sb-c::recognize-self-calls))
 588                          (signal 'error :format-control "~a" :format-arguments (list x))
 589                          (test 1)
 590                          1)))))
 591     (assert (= count 1))))
 592
 593 (with-test (:name :local-tail-call-variables)
 594   (let ((count 0))
 595     (block nil
 596       (handler-bind ((error (lambda (c)
 597                               (declare (ignore c))
 598                               (sb-debug::map-backtrace
 599                                (lambda (frame)
 600                                  (let ((sb-debug::*current-frame* frame))
 601                                    (multiple-value-bind (name args)
 602                                        (sb-debug::frame-call frame)
 603                                      (when (eq name 'test)
 604                                        (assert (equal args '(error)))
 605                                        (incf count))))))
 606                               (return))))
 607         (funcall
 608          (compile nil `(sb-int:named-lambda test (x)
 609                          (signal x)
 610                          ;; If :local-tail-call fails, this will fail
 611                          ;; too, because there's no jump between
 612                          ;; SIGNAL and the call to TAIL and it will
 613                          ;; show (flet tail) in the backtrace.
 614                          (flet ((tail ()))
 615                            (declare (notinline tail))
 616                            (tail))))
 617          'error)))
 618     (assert (= count 1))))
 619
 620 (with-test (:name :variables-surrounding-inlined-code)
 621   (let ((count 0))
 622     (block nil
 623       (handler-bind ((error (lambda (c)
 624                               (declare (ignore c))
 625                               (sb-debug::map-backtrace
 626                                (lambda (frame)
 627                                  (let ((sb-debug::*current-frame* frame))
 628                                    (multiple-value-bind (name)
 629                                        (sb-debug::frame-call frame)
 630                                      (when (eq name 'test)
 631                                        (assert (equal (sb-debug:var 'l) '(1 2 3)))
 632                                        (incf count))))))
 633                               (return))))
 634         (funcall
 635          (compile nil `(sb-int:named-lambda test (a i)
 636                          (declare (optimize (debug 3)))
 637                          (let ((l (list 1 2 3)))
 638                            (aref a i)
 639                            l)))
 640          #(1) 2)))
 641     (assert (= count 1))))
 642
 643 (with-test (:name :variables-surrounding-inlined-code.2)
 644   (let ((count 0))
 645     (block nil
 646       (handler-bind ((error (lambda (c)
 647                               (declare (ignore c))
 648                               (sb-debug::map-backtrace
 649                                (lambda (frame)
 650                                  (let ((sb-debug::*current-frame* frame))
 651                                    (multiple-value-bind (name)
 652                                        (sb-debug::frame-call frame)
 653                                      (when (eq name 'test)
 654                                        (assert (equal (sb-debug:var 'l) '(1 2 3)))
 655                                        (incf count))))))
 656                               (return))))
 657         (funcall
 658          (compile nil `(sb-int:named-lambda test (c)
 659                          (declare (optimize (debug 3)))
 660                          (let ((l (list 1 2 3)))
 661                            (map 'list #'signal c)
 662                            l)))
 663          '(error))))
 664     (assert (= count 1))))