unwind-to-frame-and-call.impure.lisp

   1 ;;;; This file is for testing UNWIND-TO-FRAME-AND-CALL, used for
   2 ;;;; implementing RESTART-FRAME and RETURN-FROM-FRAME in the debugger.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; While most of SBCL is derived from the CMU CL system, the test
   8 ;;;; files (like this one) were written from scratch after the fork
   9 ;;;; from CMU CL.
  10 ;;;;
  11 ;;;; This software is in the public domain and is provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  13 ;;;; more information.
  14
  15 ;;; The debugger doesn't have any native knowledge of the interpreter
  16 (when (eq sb-ext:*evaluator-mode* :interpret)
  17   (sb-ext:exit :code 104))
  18
  19 (declaim (optimize debug))
  20
  21 (defun return-from-frame (frame-name &rest values)
  22   (let ((frame (sb-di::top-frame)))
  23     (loop until (equal frame-name
  24                        (sb-debug::frame-call frame))
  25           do (setf frame (sb-di::frame-down frame)))
  26     (assert frame)
  27     (assert (sb-debug::frame-has-debug-tag-p frame))
  28     (sb-debug::unwind-to-frame-and-call frame
  29                                         (lambda ()
  30                                           (values-list values)))))
  31
  32 (defun restart-frame (frame-name)
  33   (let ((frame (sb-di::top-frame)))
  34     (loop until (equal (sb-debug::frame-call frame)
  35                        frame-name)
  36           do (setf frame (sb-di::frame-down frame)))
  37     (assert frame)
  38     (assert (sb-debug::frame-has-debug-tag-p frame))
  39     (let* ((call-list (sb-debug::frame-call-as-list frame))
  40            (fun (fdefinition (car call-list))))
  41       (sb-debug::unwind-to-frame-and-call frame
  42                                           (lambda ()
  43                                             (apply fun (cdr call-list)))))))
  44
  45 (defvar *foo*)
  46 (defvar *a*)
  47 (defvar *b*)
  48 (defvar *c*)
  49
  50 \f
  51 ;;;; Test RESTART-FRAME
  52
  53 (define-condition restart-condition () ())
  54
  55 (defvar *count* 0)
  56
  57 (defun restart/special (*foo*)
  58   (incf *count*)
  59   (unless *a*
  60     (setf *a* t)
  61     (signal 'restart-condition))
  62   *foo*)
  63
  64 (defun restart/optional-special (&optional (*foo* 1))
  65   (incf *count*)
  66   (unless *a*
  67     (setf *a* t)
  68     (signal 'restart-condition))
  69   *foo*)
  70
  71 (defun restart/normal (foo)
  72   (incf *count*)
  73   (unless *a*
  74     (setf *a* t)
  75     (signal 'restart-condition))
  76   foo)
  77
  78 (defun test-restart (name)
  79   (setf *a* nil)
  80   (let ((*foo* 'x))
  81     (let ((*foo* 'y)
  82           (*count* 0))
  83       (handler-bind ((restart-condition (lambda (c)
  84                                           (declare (ignore c))
  85                                           (restart-frame name))))
  86         (assert (eql (funcall name 1) 1))
  87         (assert (eql *count* 2))))
  88     ;; Check that the binding stack was correctly unwound.
  89     (assert (eql *foo* 'x))))
  90
  91 (with-test (:name (:restart-frame :special) :fails-on :win32)
  92   (test-restart 'restart/special))
  93
  94 (with-test (:name (:restart-frame :optional-special) :fails-on :win32)
  95   (test-restart 'restart/optional-special))
  96
  97 (with-test (:name (:restart-frame :normal) :fails-on :win32)
  98   (test-restart 'restart/normal))
  99
 100 \f
 101 ;;;; Test RETURN-FROM-FRAME with normal functions
 102
 103 (define-condition return-condition () ())
 104
 105 (defun return/special (*foo*)
 106   (unless *a*
 107     (setf *a* t)
 108     (signal 'return-condition))
 109   *foo*)
 110
 111 (defun return/optional-special (&optional (*foo* 1))
 112   (unless *a*
 113     (setf *a* t)
 114     (signal 'return-condition))
 115   *foo*)
 116
 117 (defun return/normal (foo)
 118   (unless *a*
 119     (setf *a* t)
 120     (signal 'return-condition))
 121   foo)
 122
 123 (defun do-signal ()
 124   (signal 'return-condition))
 125
 126 (defun return/catch (foo)
 127   (catch 'y
 128     (do-signal))
 129   foo)
 130
 131 (defun test-return (name)
 132   (setf *a* nil)
 133   (let ((*foo* 'x))
 134     (let ((*foo* 'y))
 135       (handler-bind ((return-condition (lambda (c)
 136                                           (declare (ignore c))
 137                                           (return-from-frame name 1 2 3 4))))
 138         (assert (equal (multiple-value-list (funcall name 0))
 139                        (list 1 2 3 4)))))
 140     ;; Check that the binding stack was correctly unwound.
 141     (assert (eql *foo* 'x))))
 142
 143 (with-test (:name (:return-from-frame :special) :fails-on :win32)
 144   (test-return 'return/special))
 145
 146 (with-test (:name (:return-from-frame :optional-special) :fails-on :win32)
 147   (test-return 'return/optional-special))
 148
 149 (with-test (:name (:return-from-frame :normal) :fails-on :win32)
 150   (test-return 'return/normal))
 151
 152 (defun throw-y () (throw 'y 'y))
 153
 154 ;; Check that *CURRENT-CATCH-BLOCK* was correctly restored.
 155 (with-test (:name :current-catch-block-restored :fails-on :win32)
 156   (assert (eql (catch 'y
 157                  (test-return 'return/catch)
 158                  (throw-y))
 159                'y)))
 160
 161 \f
 162 ;;;; Test RETURN-FROM-FRAME with local functions
 163
 164 (define-condition in-a () ())
 165 (define-condition in-b () ())
 166
 167 (defun locals ()
 168   (flet ((a ()
 169            (signal 'in-a)
 170            (values 1 2))
 171          (b ()
 172            (signal 'in-b)
 173            1))
 174     (setf *a* (multiple-value-list (a)))
 175     (setf *b* (multiple-value-list (b)))))
 176
 177 (defun hairy-locals ()
 178   (let ((*c* :bad))
 179     (flet ((a (&optional *c*)
 180              (signal 'in-a)
 181              (values 1 2))
 182            (b (&key *c*)
 183              (signal 'in-b)
 184              1))
 185       ;; Ensure that A and B actually appear in the backtrace; the
 186       ;; compiler for some reason likes to optimize away single-use
 187       ;; local functions with hairy lambda-lists even on high debug
 188       ;; levels.
 189       (setf *a* (a :good))
 190       (setf *b* (b :*c* :good))
 191       ;; Do the real tests
 192       (setf *a* (multiple-value-list (a :good)))
 193       (setf *b* (multiple-value-list (b :*c* :good))))))
 194
 195 (defun test-locals (name)
 196   (handler-bind ((in-a (lambda (c)
 197                          (declare (ignore c))
 198                          (return-from-frame `(flet a :in ,name) 'x 'y)))
 199                  (in-b (lambda (c)
 200                          (declare (ignore c))
 201                          (return-from-frame `(flet b :in ,name) 'z))))
 202     (funcall name))
 203   ;; We're intentionally not testing for returning a different amount
 204   ;; of values than the local functions are normally returning. It's
 205   ;; hard to think of practical cases where that'd be useful, but
 206   ;; allowing it (as in the old fully CATCH-based implementation of
 207   ;; UNWIND-TO-FRAME-AND-CALL) will make it harder for the compiler to
 208   ;; work well.
 209   (let ((*foo* 'x))
 210     (let ((*foo* 'y))
 211       (assert (equal *a* '(x y)))
 212       (assert (equal *b* '(z))))
 213     (assert (eql *foo* 'x))))
 214
 215 (with-test (:name (:return-from-frame :local-function) :fails-on :win32)
 216   (test-locals 'locals))
 217
 218 (with-test (:name (:return-from-frame :hairy-local-function) :fails-on :win32)
 219   (test-locals 'hairy-locals))
 220
 221 \f
 222 ;;;; Test RETURN-FROM-FRAME with anonymous functions
 223
 224 (define-condition anon-condition () ())
 225
 226 (defparameter *anon-1*
 227   (lambda (foo)
 228     (signal 'anon-condition)
 229     foo))
 230
 231 (defparameter *anon-2*
 232   (lambda (*foo*)
 233     (signal 'anon-condition)
 234     *foo*))
 235
 236 (defun make-anon-3 ()
 237   (let ((a (lambda (foo)
 238              (signal 'anon-condition)
 239              foo)))
 240     (funcall a 1)
 241     a))
 242
 243 (defun make-anon-4 ()
 244   (let ((a (lambda (*foo*)
 245              (signal 'anon-condition)
 246              *foo*)))
 247     (funcall a 1)
 248     a))
 249
 250 (defparameter *anon-3* (make-anon-3))
 251 (defparameter *anon-4* (make-anon-4))
 252
 253 (defun test-anon (fun var-name &optional in)
 254   (handler-bind ((anon-condition (lambda (c)
 255                                    (declare (ignore c))
 256                                    (return-from-frame
 257                                     `(lambda (,var-name) ,@(when in `(:in ,in)))
 258                                     'x 'y))))
 259     (let ((*foo* 'x))
 260       (let ((*foo* 'y))
 261         (assert (equal (multiple-value-list (funcall fun 1))
 262                        '(x y)))
 263         (assert (eql *foo* 'y)))
 264       (assert (eql *foo* 'x)))))
 265
 266 (with-test (:name (:return-from-frame :anonymous :toplevel) :fails-on :win32)
 267   (test-anon *anon-1* 'foo (namestring *load-truename*)))
 268
 269 (with-test (:name (:return-from-frame :anonymous :toplevel-special)
 270                   :fails-on :win32)
 271   (test-anon *anon-2* '*foo* (namestring *load-truename*)))
 272
 273 (with-test (:name (:return-from-frame :anonymous) :fails-on :win32)
 274   (test-anon *anon-3* 'foo 'make-anon-3))
 275
 276 (with-test (:name (:return-from-frame :anonymous :special) :fails-on :win32)
 277   (test-anon *anon-4* '*foo* 'make-anon-4))
 278
 279 \f
 280 ;;;; Test that unwind cleanups are executed
 281
 282 (defvar *unwind-state* nil)
 283 (defvar *signal* nil)
 284
 285 (defun unwind-1 ()
 286   (unwind-protect
 287        (when *signal*
 288          (signal 'return-condition))
 289     (push :unwind-1 *unwind-state*)))
 290
 291 (defun unwind-2 ()
 292   (unwind-protect
 293        (unwind-1)
 294     (push :unwind-2 *unwind-state*)))
 295
 296 (defun test-unwind (fun wanted)
 297   (handler-bind ((return-condition (lambda (c)
 298                                      (declare (ignore c))
 299                                      (return-from-frame fun
 300                                                         'x 'y))))
 301     (dolist (*signal* (list nil t))
 302       (let ((*foo* 'x)
 303             (*unwind-state* nil))
 304         (let ((*foo* 'y))
 305           (if *signal*
 306               (assert (equal (multiple-value-list (funcall fun))
 307                              '(x y)))
 308               (funcall fun))
 309           (assert (equal *unwind-state* wanted))
 310           (assert (eql *foo* 'y)))
 311         (assert (eql *foo* 'x))))))
 312
 313 (with-test (:name :test-unwind-1 :fails-on :win32)
 314   (test-unwind 'unwind-1 '(:unwind-1)))
 315 (with-test (:name :test-unwind-2 :fails-on :win32)
 316   (test-unwind 'unwind-2 '(:unwind-2 :unwind-1)))
 317
 318 ;;; Regression in 1.0.10.47 reported by James Knight
 319
 320 (defun inner1 (tla)
 321   (zerop tla))
 322
 323 (declaim (inline inline-fun))
 324 (defun inline-fun (tla)
 325   (or (inner1 tla)
 326       (inner1 tla)))
 327
 328 (defun foo (predicate)
 329   (funcall predicate 2))
 330
 331 (defun test ()
 332   (let ((blah (foo #'inline-fun)))
 333     (inline-fun 3)))
 334
 335 (with-test (:name (:debug-instrumentation :inline/xep))
 336   (test))
 337