tests/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 #+win32
  79 (defun decline ()
  80   ;; these tests currently fail no matter whether threads are enabled or
  81   ;; not, but on threaded builds the failure mode is particularly
  82   ;; unfortunate.  As a workaround, opt out of running the test.
  83   #+sb-thread
  84   (error "this test fails with exception 0xc0000029 ~
  85           (STATUS_INVALID_UNWIND_TARGET), from which we cannot currently ~
  86           recover"))
  87
  88 (defun test-restart (name)
  89   #+win32 (decline)
  90   (setf *a* nil)
  91   (let ((*foo* 'x))
  92     (let ((*foo* 'y)
  93           (*count* 0))
  94       (handler-bind ((restart-condition (lambda (c)
  95                                           (declare (ignore c))
  96                                           (restart-frame name))))
  97         (assert (eql (funcall name 1) 1))
  98         (assert (eql *count* 2))))
  99     ;; Check that the binding stack was correctly unwound.
 100     (assert (eql *foo* 'x))))
 101
 102 (with-test (:name (:restart-frame :special) :fails-on :win32)
 103   (test-restart 'restart/special))
 104
 105 (with-test (:name (:restart-frame :optional-special) :fails-on :win32)
 106   (test-restart 'restart/optional-special))
 107
 108 (with-test (:name (:restart-frame :normal) :fails-on :win32)
 109   (test-restart 'restart/normal))
 110
 111 \f
 112 ;;;; Test RETURN-FROM-FRAME with normal functions
 113
 114 (define-condition return-condition () ())
 115
 116 (defun return/special (*foo*)
 117   (unless *a*
 118     (setf *a* t)
 119     (signal 'return-condition))
 120   *foo*)
 121
 122 (defun return/optional-special (&optional (*foo* 1))
 123   (unless *a*
 124     (setf *a* t)
 125     (signal 'return-condition))
 126   *foo*)
 127
 128 (defun return/normal (foo)
 129   (unless *a*
 130     (setf *a* t)
 131     (signal 'return-condition))
 132   foo)
 133
 134 (defun do-signal ()
 135   (signal 'return-condition))
 136
 137 (defun return/catch (foo)
 138   (catch 'y
 139     (do-signal))
 140   foo)
 141
 142 (defun test-return (name)
 143   #+win32 (decline)
 144   (setf *a* nil)
 145   (let ((*foo* 'x))
 146     (let ((*foo* 'y))
 147       (handler-bind ((return-condition (lambda (c)
 148                                           (declare (ignore c))
 149                                           (return-from-frame name 1 2 3 4))))
 150         (assert (equal (multiple-value-list (funcall name 0))
 151                        (list 1 2 3 4)))))
 152     ;; Check that the binding stack was correctly unwound.
 153     (assert (eql *foo* 'x))))
 154
 155 (with-test (:name (:return-from-frame :special) :fails-on :win32)
 156   (test-return 'return/special))
 157
 158 (with-test (:name (:return-from-frame :optional-special) :fails-on :win32)
 159   (test-return 'return/optional-special))
 160
 161 (with-test (:name (:return-from-frame :normal) :fails-on :win32)
 162   (test-return 'return/normal))
 163
 164 (defun throw-y () (throw 'y 'y))
 165
 166 ;; Check that *CURRENT-CATCH-BLOCK* was correctly restored.
 167 (with-test (:name :current-catch-block-restored :fails-on :win32)
 168   (assert (eql (catch 'y
 169                  (test-return 'return/catch)
 170                  (throw-y))
 171                'y)))
 172
 173 \f
 174 ;;;; Test RETURN-FROM-FRAME with local functions
 175
 176 (define-condition in-a () ())
 177 (define-condition in-b () ())
 178
 179 (defun locals ()
 180   (flet ((a ()
 181            (signal 'in-a)
 182            (values 1 2))
 183          (b ()
 184            (signal 'in-b)
 185            1))
 186     (setf *a* (multiple-value-list (a)))
 187     (setf *b* (multiple-value-list (b)))))
 188
 189 (defun hairy-locals ()
 190   (let ((*c* :bad))
 191     (flet ((a (&optional *c*)
 192              (signal 'in-a)
 193              (values 1 2))
 194            (b (&key *c*)
 195              (signal 'in-b)
 196              1))
 197       ;; Ensure that A and B actually appear in the backtrace; the
 198       ;; compiler for some reason likes to optimize away single-use
 199       ;; local functions with hairy lambda-lists even on high debug
 200       ;; levels.
 201       (setf *a* (a :good))
 202       (setf *b* (b :*c* :good))
 203       ;; Do the real tests
 204       (setf *a* (multiple-value-list (a :good)))
 205       (setf *b* (multiple-value-list (b :*c* :good))))))
 206
 207 (defun test-locals (name)
 208   #+win32 (decline)
 209   (handler-bind ((in-a (lambda (c)
 210                          (declare (ignore c))
 211                          (return-from-frame `(flet a :in ,name) 'x 'y)))
 212                  (in-b (lambda (c)
 213                          (declare (ignore c))
 214                          (return-from-frame `(flet b :in ,name) 'z))))
 215     (funcall name))
 216   ;; We're intentionally not testing for returning a different amount
 217   ;; of values than the local functions are normally returning. It's
 218   ;; hard to think of practical cases where that'd be useful, but
 219   ;; allowing it (as in the old fully CATCH-based implementation of
 220   ;; UNWIND-TO-FRAME-AND-CALL) will make it harder for the compiler to
 221   ;; work well.
 222   (let ((*foo* 'x))
 223     (let ((*foo* 'y))
 224       (assert (equal *a* '(x y)))
 225       (assert (equal *b* '(z))))
 226     (assert (eql *foo* 'x))))
 227
 228 (with-test (:name (:return-from-frame :local-function) :fails-on :win32)
 229   (test-locals 'locals))
 230
 231 (with-test (:name (:return-from-frame :hairy-local-function) :fails-on :win32)
 232   (test-locals 'hairy-locals))
 233
 234 \f
 235 ;;;; Test RETURN-FROM-FRAME with anonymous functions
 236
 237 (define-condition anon-condition () ())
 238
 239 (defparameter *anon-1*
 240   (lambda (foo)
 241     (signal 'anon-condition)
 242     foo))
 243
 244 (defparameter *anon-2*
 245   (lambda (*foo*)
 246     (signal 'anon-condition)
 247     *foo*))
 248
 249 (defun make-anon-3 ()
 250   (let ((a (lambda (foo)
 251              (signal 'anon-condition)
 252              foo)))
 253     (funcall a 1)
 254     a))
 255
 256 (defun make-anon-4 ()
 257   (let ((a (lambda (*foo*)
 258              (signal 'anon-condition)
 259              *foo*)))
 260     (funcall a 1)
 261     a))
 262
 263 (defparameter *anon-3* (make-anon-3))
 264 (defparameter *anon-4* (make-anon-4))
 265
 266 (defun test-anon (fun var-name &optional in)
 267   #+win32 (decline)
 268   (handler-bind ((anon-condition (lambda (c)
 269                                    (declare (ignore c))
 270                                    (return-from-frame
 271                                     `(lambda (,var-name) ,@(when in `(:in ,in)))
 272                                     'x 'y))))
 273     (let ((*foo* 'x))
 274       (let ((*foo* 'y))
 275         (assert (equal (multiple-value-list (funcall fun 1))
 276                        '(x y)))
 277         (assert (eql *foo* 'y)))
 278       (assert (eql *foo* 'x)))))
 279
 280 (with-test (:name (:return-from-frame :anonymous :toplevel) :fails-on :win32)
 281   (test-anon *anon-1* 'foo (namestring *load-truename*)))
 282
 283 (with-test (:name (:return-from-frame :anonymous :toplevel-special)
 284                   :fails-on :win32)
 285   (test-anon *anon-2* '*foo* (namestring *load-truename*)))
 286
 287 (with-test (:name (:return-from-frame :anonymous) :fails-on :win32)
 288   (test-anon *anon-3* 'foo 'make-anon-3))
 289
 290 (with-test (:name (:return-from-frame :anonymous :special) :fails-on :win32)
 291   (test-anon *anon-4* '*foo* 'make-anon-4))
 292
 293 \f
 294 ;;;; Test that unwind cleanups are executed
 295
 296 (defvar *unwind-state* nil)
 297 (defvar *signal* nil)
 298
 299 (defun unwind-1 ()
 300   (unwind-protect
 301        (when *signal*
 302          (signal 'return-condition))
 303     (push :unwind-1 *unwind-state*)))
 304
 305 (defun unwind-2 ()
 306   (unwind-protect
 307        (unwind-1)
 308     (push :unwind-2 *unwind-state*)))
 309
 310 (defun test-unwind (fun wanted)
 311   #+win32 (decline)
 312   (handler-bind ((return-condition (lambda (c)
 313                                      (declare (ignore c))
 314                                      (return-from-frame fun
 315                                                         'x 'y))))
 316     (dolist (*signal* (list nil t))
 317       (let ((*foo* 'x)
 318             (*unwind-state* nil))
 319         (let ((*foo* 'y))
 320           (if *signal*
 321               (assert (equal (multiple-value-list (funcall fun))
 322                              '(x y)))
 323               (funcall fun))
 324           (assert (equal *unwind-state* wanted))
 325           (assert (eql *foo* 'y)))
 326         (assert (eql *foo* 'x))))))
 327
 328 (with-test (:name :test-unwind-1 :fails-on :win32)
 329   (test-unwind 'unwind-1 '(:unwind-1)))
 330 (with-test (:name :test-unwind-2 :fails-on :win32)
 331   (test-unwind 'unwind-2 '(:unwind-2 :unwind-1)))
 332
 333 ;;; Regression in 1.0.10.47 reported by James Knight
 334
 335 (defun inner1 (tla)
 336   (zerop tla))
 337
 338 (declaim (inline inline-fun))
 339 (defun inline-fun (tla)
 340   (or (inner1 tla)
 341       (inner1 tla)))
 342
 343 (defun foo (predicate)
 344   (funcall predicate 2))
 345
 346 (defun test ()
 347   (let ((blah (foo #'inline-fun)))
 348     (inline-fun 3)))
 349
 350 (with-test (:name (:debug-instrumentation :inline/xep))
 351   (test))
 352