tests/win32-foreign-stack-unwind.impure.lisp

   1 ;;;; Testing the behavior of foreign calls trying to unwind the stack.  Uses win32-stack-unwind.c.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 #-win32 (quit :unix-status 104) ;; This is extremely win32-specific.
  15
  16 (use-package :sb-alien)
  17
  18 ;;; Callbacks are not part of the exported interface yet -- when they are this can
  19 ;;; go away.
  20 (import 'sb-alien::alien-lambda)
  21
  22 (defun run-compiler ()
  23   (let ((proc (run-program "gcc" '("win32-stack-unwind.c"
  24                                    "-mno-cygwin" "-shared"
  25                                    "-o" "win32-stack-unwind.dll")
  26                            :search t)))
  27     (unless (zerop (process-exit-code proc))
  28       (error "Bad exit code: ~S"
  29              (process-exit-code proc)))))
  30
  31 (run-compiler)
  32
  33 (load-shared-object (truename "win32-stack-unwind.dll"))
  34
  35
  36 (defvar *current-test-callback*)
  37
  38 (defparameter *test-callback-thunk*
  39   (sb-alien::alien-callback
  40    (function void)
  41    #'(lambda () (funcall *current-test-callback*))))
  42
  43 (defun establish-return-frame (callback)
  44   "Establish an SEH frame for use as a target with PERFORM-TEST-UNWIND and invoke CALLBACK via FUNCALL"
  45   ;; We don't use a LET here because we don't want to accidentally
  46   ;; correct a blown binding stack pointer just yet.
  47   (setf *current-test-callback* callback)
  48   (alien-funcall (extern-alien "establish_return_frame"
  49                                (function void (* (function void))))
  50                  (alien-sap *test-callback-thunk*))
  51   (makunbound '*current-test-callback*)
  52   (values))
  53
  54 (defun perform-test-unwind ()
  55   "Perform an RtlUnwind to the surrounding ESTABLISH-RETURN-FRAME frame."
  56   (alien-funcall (extern-alien "perform_test_unwind" (function void))))
  57
  58
  59 ;;; An attempt to detect and clean up latent fatalities in the
  60 ;;; post-test environent.
  61
  62 (defmacro with-test-environment (args &body body)
  63   (declare (ignore args))
  64   (let ((old-bsp (gensym))
  65         (old-cuwp (gensym))
  66         (old-ccb (gensym))
  67         (old-asp (gensym)))
  68     `(let ((*standard-input* *standard-input*))
  69       (let ((,old-bsp (+ sb-vm::*binding-stack-pointer* 2))
  70             (,old-cuwp sb-vm::*current-unwind-protect-block*)
  71             (,old-ccb sb-vm:*current-catch-block*)
  72             (,old-asp sb-vm::*alien-stack*))
  73         (handler-case
  74             (let ((result (progn ,@body))
  75                   extra-results)
  76               (when (not (eql ,old-bsp sb-vm::*binding-stack-pointer*))
  77                 #+(or)
  78                 (format t "~A ~A~%" ,old-bsp sb-vm::*binding-stack-pointer*)
  79                 (push :bsp-fail extra-results))
  80               (when (not (eql ,old-cuwp sb-vm::*current-unwind-protect-block*))
  81                 (push :cuwp-fail extra-results))
  82               (when (not (eql ,old-ccb sb-vm:*current-catch-block*))
  83                 (push :ccb-fail extra-results))
  84               (when (not (eql ,old-asp sb-vm::*alien-stack*))
  85                 (push :asp-fail extra-results))
  86               (setf sb-vm::*current-unwind-protect-block* ,old-cuwp)
  87               (setf sb-vm:*current-catch-block* ,old-ccb)
  88               (setf sb-vm::*alien-stack* ,old-asp)
  89               (list* result extra-results))
  90           (error ()
  91             :error))))))
  92
  93
  94 ;;; Test cases.
  95
  96 (with-test (:name #1=:base-case)
  97   ;; Tests that the unwind test machinery works.
  98   (let ((result
  99          (with-test-environment ()
 100            (establish-return-frame (lambda () (perform-test-unwind)))
 101            :success)))
 102     (format t "~S result: ~S~%" #1# result)
 103     (assert (eql :success (car result)))))
 104
 105 (with-test (:name #1=:special-binding)
 106   ;; Tests that special bindings are undone properly during
 107   ;; unwind.
 108   (let ((result
 109          (with-test-environment ()
 110            (let ((foo :success))
 111              (declare (special foo))
 112              (establish-return-frame (lambda ()
 113                                        (let ((foo nil))
 114                                          (declare (special foo))
 115                                          (perform-test-unwind))))
 116              foo))))
 117     (format t "~S result: ~S~%" #1# result)
 118     (assert (eql :success (car result)))))
 119
 120 (with-test (:name #1=:unwind-protect)
 121   ;; Tests that unwind-protect forms are run during unwind.
 122   (let ((result
 123          (with-test-environment ()
 124            (let (result)
 125              (establish-return-frame (lambda ()
 126                                        (unwind-protect
 127                                             (perform-test-unwind)
 128                                          (setf result :success))))
 129              result))))
 130     (format t "~S result: ~S~%" #1# result)
 131     (assert (eql :success (car result)))))
 132
 133 (with-test (:name #1=:unwind-protect-nlx)
 134   ;; Tests that unwind-protect forms that are run during unwind
 135   ;; can do a non-local exit to abort the unwind.
 136   (let ((result
 137          (with-test-environment ()
 138            (let (result)
 139              (establish-return-frame (lambda ()
 140                                        (block nil
 141                                          (unwind-protect
 142                                               (perform-test-unwind)
 143                                            (return)))
 144                                        (setf result :success)))
 145              result))))
 146     (format t "~S result: ~S~%" #1# result)
 147     (assert (eql :success (car result)))))
 148
 149 (with-test (:name #1=:no-unwind)
 150   ;; Basic smoke test of establish-return-frame.
 151   (let ((result
 152          (with-test-environment ()
 153            (establish-return-frame (lambda ()))
 154            :success)))
 155     (format t "~S result: ~S~%" #1# result)
 156     (assert (eql :success (car result)))))
 157
 158 (with-test (:name #1=:no-unwind-error)
 159   ;; Tests that EXCEPTION_BREAKPOINT is caught and handled
 160   ;; correctly within callbacks.
 161   (let ((result
 162          (with-test-environment ()
 163            (establish-return-frame (lambda ()
 164                                      (handler-case
 165                                          (some-undefined-function)
 166                                        (undefined-function ()))))
 167            :success)))
 168     (format t "~S result: ~S~%" #1# result)
 169     (assert (eql :success (car result)))))
 170
 171 (with-test (:name #1=:unwind-foreign-frame)
 172   ;; Tests that unwinding a foreign SEH frame isn't completely
 173   ;; broken.
 174   (let ((result
 175          (with-test-environment ()
 176            (block nil
 177              (establish-return-frame (lambda () (return :success)))))))
 178     (format t "~S result: ~S~%" #1# result)
 179     (assert (eql :success (car result)))))
 180
 181 (with-test (:name #1=:unwind-protect-unwind-foreign-frame)
 182   ;; Tests that an unwind-protect block is allowed to unwind
 183   ;; past the original unwind target.
 184   (let ((result
 185          (with-test-environment ()
 186            (block nil
 187              (establish-return-frame (lambda ()
 188                                        (unwind-protect
 189                                             (perform-test-unwind)
 190                                          (return :success))))))))
 191     (format t "~S result: ~S~%" #1# result)
 192     (assert (eql :success (car result)))))
 193
 194 (with-test (:name #1=:unwind-error)
 195   ;; Another test for unwinding an SEH frame.
 196   (let ((result
 197          (with-test-environment ()
 198            (handler-case
 199                (establish-return-frame (lambda ()
 200                                          (error "Foo!")))
 201              (error ()
 202                :success)))))
 203     (format t "~S result: ~S~%" #1# result)
 204     (assert (eql :success (car result)))))
 205
 206 ;;;; success!