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:quit :unix-status 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 (sb-debug::frame-call frame)
  24                        frame-name)
  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))
  92   (test-restart 'restart/special))
  93
  94 (with-test (:name (:restart-frame :optional-special))
  95   (test-restart 'restart/optional-special))
  96
  97 (with-test (:name (:restart-frame :normal))
  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))
 144   (test-return 'return/special))
 145
 146 (with-test (:name (:return-from-frame :optional-special))
 147   (test-return 'return/optional-special))
 148
 149 (with-test (:name (:return-from-frame :normal))
 150   (test-return 'return/normal))
 151
 152 (defun throw-y () (throw 'y 'y))
 153
 154 ;; Check that *CURRENT-CATCH-BLOCK* was correctly restored.
 155 (assert (eql (catch 'y
 156                (test-return 'return/catch)
 157                (throw-y))
 158              'y))
 159
 160 \f
 161 ;;;; Test RETURN-FROM-FRAME with local functions
 162
 163 (define-condition in-a () ())
 164 (define-condition in-b () ())
 165
 166 (defun locals ()
 167   (flet ((a ()
 168            (signal 'in-a)
 169            (values 1 2))
 170          (b ()
 171            (signal 'in-b)
 172            1))
 173     (setf *a* (multiple-value-list (a)))
 174     (setf *b* (multiple-value-list (b)))))
 175
 176 (defun hairy-locals ()
 177   (let ((*c* :bad))
 178     (flet ((a (&optional *c*)
 179              (signal 'in-a)
 180              (values 1 2))
 181            (b (&key *c*)
 182              (signal 'in-b)
 183              1))
 184       ;; Ensure that A and B actually appear in the backtrace; the
 185       ;; compiler for some reason likes to optimize away single-use
 186       ;; local functions with hairy lambda-lists even on high debug
 187       ;; levels.
 188       (setf *a* (a :good))
 189       (setf *b* (b :*c* :good))
 190       ;; Do the real tests
 191       (setf *a* (multiple-value-list (a :good)))
 192       (setf *b* (multiple-value-list (b :*c* :good))))))
 193
 194 (defun test-locals (name)
 195   (handler-bind ((in-a (lambda (c)
 196                          (declare (ignore c))
 197                          (return-from-frame '(flet a) 'x 'y)))
 198                  (in-b (lambda (c)
 199                          (declare (ignore c))
 200                          (return-from-frame '(flet b) 'z))))
 201     (funcall name))
 202   ;; We're intentionally not testing for returning a different amount
 203   ;; of values than the local functions are normally returning. It's
 204   ;; hard to think of practical cases where that'd be useful, but
 205   ;; allowing it (as in the old fully CATCH-based implementation of
 206   ;; UNWIND-TO-FRAME-AND-CALL) will make it harder for the compiler to
 207   ;; work well.
 208   (let ((*foo* 'x))
 209     (let ((*foo* 'y))
 210       (assert (equal *a* '(x y)))
 211       (assert (equal *b* '(z))))
 212     (assert (eql *foo* 'x))))
 213
 214 (with-test (:name (:return-from-frame :local-function))
 215   (test-locals 'locals))
 216
 217 (with-test (:name (:return-from-frame :hairy-local-function))
 218   (test-locals 'hairy-locals))
 219
 220 \f
 221 ;;;; Test RETURN-FROM-FRAME with anonymous functions
 222
 223 (define-condition anon-condition () ())
 224
 225 (defparameter *anon-1*
 226   (lambda (foo)
 227     (signal 'anon-condition)
 228     foo))
 229
 230 (defparameter *anon-2*
 231   (lambda (*foo*)
 232     (signal 'anon-condition)
 233     *foo*))
 234
 235 (defun make-anon-3 ()
 236   (let ((a (lambda (foo)
 237              (signal 'anon-condition)
 238              foo)))
 239     (funcall a 1)
 240     a))
 241
 242 (defun make-anon-4 ()
 243   (let ((a (lambda (*foo*)
 244              (signal 'anon-condition)
 245              *foo*)))
 246     (funcall a 1)
 247     a))
 248
 249 (defparameter *anon-3* (make-anon-3))
 250 (defparameter *anon-4* (make-anon-4))
 251
 252 (defun test-anon (fun var-name)
 253   (handler-bind ((anon-condition (lambda (c)
 254                                    (declare (ignore c))
 255                                    (return-from-frame `(lambda (,var-name))
 256                                                       'x 'y))))
 257     (let ((*foo* 'x))
 258       (let ((*foo* 'y))
 259         (assert (equal (multiple-value-list (funcall fun 1))
 260                        '(x y)))
 261         (assert (eql *foo* 'y)))
 262       (assert (eql *foo* 'x)))))
 263
 264 (with-test (:name (:return-from-frame :anonymous :toplevel))
 265   (test-anon *anon-1* 'foo))
 266
 267 (with-test (:name (:return-from-frame :anonymous :toplevel-special))
 268   (test-anon *anon-2* '*foo*))
 269
 270 (with-test (:name (:return-from-frame :anonymous))
 271   (test-anon *anon-3* 'foo))
 272
 273 (with-test (:name (:return-from-frame :anonymous :special))
 274   (test-anon *anon-4* '*foo*))
 275
 276 \f
 277 ;;;; Test that unwind cleanups are executed
 278
 279 (defvar *unwind-state* nil)
 280 (defvar *signal* nil)
 281
 282 (defun unwind-1 ()
 283   (unwind-protect
 284        (when *signal*
 285          (signal 'return-condition))
 286     (push :unwind-1 *unwind-state*)))
 287
 288 (defun unwind-2 ()
 289   (unwind-protect
 290        (unwind-1)
 291     (push :unwind-2 *unwind-state*)))
 292
 293 (defun test-unwind (fun wanted)
 294   (handler-bind ((return-condition (lambda (c)
 295                                      (declare (ignore c))
 296                                      (return-from-frame fun
 297                                                         'x 'y))))
 298     (dolist (*signal* (list nil t))
 299       (let ((*foo* 'x)
 300             (*unwind-state* nil))
 301         (let ((*foo* 'y))
 302           (if *signal*
 303               (assert (equal (multiple-value-list (funcall fun))
 304                              '(x y)))
 305               (funcall fun))
 306           (assert (equal *unwind-state* wanted))
 307           (assert (eql *foo* 'y)))
 308         (assert (eql *foo* 'x))))))
 309
 310 (test-unwind 'unwind-1 '(:unwind-1))
 311 (test-unwind 'unwind-2 '(:unwind-2 :unwind-1))
 312
 313 ;;; Regression in 1.0.10.47 reported by James Knight
 314
 315 (defun inner1 (tla)
 316   (zerop tla))
 317
 318 (declaim (inline inline-fun))
 319 (defun inline-fun (tla)
 320   (or (inner1 tla)
 321       (inner1 tla)))
 322
 323 (defun foo (predicate)
 324   (funcall predicate 2))
 325
 326 (defun test ()
 327   (let ((blah (foo #'inline-fun)))
 328     (inline-fun 3)))
 329
 330 (with-test (:name (:debug-instrumentation :inline/xep))
 331   (test))
 332