+;;;; Testing the behavior of foreign calls trying to unwind the stack. Uses win32-stack-unwind.c.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+#-win32 (quit :unix-status 104) ;; This is extremely win32-specific.
+
+(use-package :sb-alien)
+
+;;; Callbacks are not part of the exported interface yet -- when they are this can
+;;; go away.
+(import 'sb-alien::alien-lambda)
+
+(defun run-compiler ()
+ (let ((proc (run-program "gcc" '("win32-stack-unwind.c"
+ "-mno-cygwin" "-shared"
+ "-o" "win32-stack-unwind.dll")
+ :search t)))
+ (unless (zerop (process-exit-code proc))
+ (error "Bad exit code: ~S"
+ (process-exit-code proc)))))
+
+(run-compiler)
+
+(load-shared-object "win32-stack-unwind.dll")
+
+
+(defvar *current-test-callback*)
+
+(defparameter *test-callback-thunk*
+ (sb-alien::alien-callback
+ (function void)
+ #'(lambda () (funcall *current-test-callback*))))
+
+(defun establish-return-frame (callback)
+ "Establish an SEH frame for use as a target with PERFORM-TEST-UNWIND and invoke CALLBACK via FUNCALL"
+ ;; We don't use a LET here because we don't want to accidentally
+ ;; correct a blown binding stack pointer just yet.
+ (setf *current-test-callback* callback)
+ (alien-funcall (extern-alien "establish_return_frame"
+ (function void (* (function void))))
+ (alien-sap *test-callback-thunk*))
+ (makunbound '*current-test-callback*)
+ (values))
+
+(defun perform-test-unwind ()
+ "Perform an RtlUnwind to the surrounding ESTABLISH-RETURN-FRAME frame."
+ (alien-funcall (extern-alien "perform_test_unwind" (function void))))
+
+
+;;; An attempt to detect and clean up latent fatalities in the
+;;; post-test environent.
+
+(defmacro with-test-environment (args &body body)
+ (declare (ignore args))
+ (let ((old-bsp (gensym))
+ (old-cuwp (gensym))
+ (old-ccb (gensym))
+ (old-asp (gensym)))
+ `(let ((*standard-input* *standard-input*))
+ (let ((,old-bsp (+ sb-vm::*binding-stack-pointer* 2))
+ (,old-cuwp sb-vm::*current-unwind-protect-block*)
+ (,old-ccb sb-vm:*current-catch-block*)
+ (,old-asp sb-vm::*alien-stack*))
+ (handler-case
+ (let ((result (progn ,@body))
+ extra-results)
+ (when (not (eql ,old-bsp sb-vm::*binding-stack-pointer*))
+ #+(or)
+ (format t "~A ~A~%" ,old-bsp sb-vm::*binding-stack-pointer*)
+ (push :bsp-fail extra-results))
+ (when (not (eql ,old-cuwp sb-vm::*current-unwind-protect-block*))
+ (push :cuwp-fail extra-results))
+ (when (not (eql ,old-ccb sb-vm:*current-catch-block*))
+ (push :ccb-fail extra-results))
+ (when (not (eql ,old-asp sb-vm::*alien-stack*))
+ (push :asp-fail extra-results))
+ (setf sb-vm::*current-unwind-protect-block* ,old-cuwp)
+ (setf sb-vm:*current-catch-block* ,old-ccb)
+ (setf sb-vm::*alien-stack* ,old-asp)
+ (list* result extra-results))
+ (error ()
+ :error))))))
+
+
+;;; Test cases.
+
+(with-test (:name #1=:base-case)
+ ;; Tests that the unwind test machinery works.
+ (let ((result
+ (with-test-environment ()
+ (establish-return-frame (lambda () (perform-test-unwind)))
+ :success)))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+(with-test (:name #1=:special-binding)
+ ;; Tests that special bindings are undone properly during
+ ;; unwind.
+ (let ((result
+ (with-test-environment ()
+ (let ((foo :success))
+ (declare (special foo))
+ (establish-return-frame (lambda ()
+ (let ((foo nil))
+ (declare (special foo))
+ (perform-test-unwind))))
+ foo))))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+(with-test (:name #1=:unwind-protect)
+ ;; Tests that unwind-protect forms are run during unwind.
+ (let ((result
+ (with-test-environment ()
+ (let (result)
+ (establish-return-frame (lambda ()
+ (unwind-protect
+ (perform-test-unwind)
+ (setf result :success))))
+ result))))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+(with-test (:name #1=:unwind-protect-nlx)
+ ;; Tests that unwind-protect forms that are run during unwind
+ ;; can do a non-local exit to abort the unwind.
+ (let ((result
+ (with-test-environment ()
+ (let (result)
+ (establish-return-frame (lambda ()
+ (block nil
+ (unwind-protect
+ (perform-test-unwind)
+ (return)))
+ (setf result :success)))
+ result))))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+(with-test (:name #1=:no-unwind)
+ ;; Basic smoke test of establish-return-frame.
+ (let ((result
+ (with-test-environment ()
+ (establish-return-frame (lambda ()))
+ :success)))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+(with-test (:name #1=:no-unwind-error)
+ ;; Tests that EXCEPTION_BREAKPOINT is caught and handled
+ ;; correctly within callbacks.
+ (let ((result
+ (with-test-environment ()
+ (establish-return-frame (lambda ()
+ (handler-case
+ (some-undefined-function)
+ (undefined-function ()))))
+ :success)))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+(with-test (:name #1=:unwind-foreign-frame)
+ ;; Tests that unwinding a foreign SEH frame isn't completely
+ ;; broken.
+ (let ((result
+ (with-test-environment ()
+ (block nil
+ (establish-return-frame (lambda () (return :success)))))))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+(with-test (:name #1=:unwind-protect-unwind-foreign-frame)
+ ;; Tests that an unwind-protect block is allowed to unwind
+ ;; past the original unwind target.
+ (let ((result
+ (with-test-environment ()
+ (block nil
+ (establish-return-frame (lambda ()
+ (unwind-protect
+ (perform-test-unwind)
+ (return :success))))))))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+(with-test (:name #1=:unwind-error)
+ ;; Another test for unwinding an SEH frame.
+ (let ((result
+ (with-test-environment ()
+ (handler-case
+ (establish-return-frame (lambda ()
+ (error "Foo!")))
+ (error ()
+ :success)))))
+ (format t "~S result: ~S~%" #1# result)
+ (assert (eql :success (car result)))))
+
+;;;; success!
projects / sbcl.git / commitdiff