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