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