1 ;;;; Testing the behavior of foreign calls trying to unwind the stack. Uses win32-stack-unwind.c.
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
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.
17 (use-package :sb-alien)
19 ;;; Callbacks are not part of the exported interface yet -- when they are this can
21 (import 'sb-alien::alien-lambda)
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")
28 (unless (zerop (process-exit-code proc))
29 (error "Bad exit code: ~S"
30 (process-exit-code proc)))))
34 (load-shared-object (truename "win32-stack-unwind.dll"))
37 (defvar *current-test-callback*)
39 (defparameter *test-callback-thunk*
40 (sb-alien::alien-callback
42 #'(lambda () (funcall *current-test-callback*))))
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*)
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))))
60 ;;; An attempt to detect and clean up latent fatalities in the
61 ;;; post-test environent.
63 (defmacro with-test-environment (args &body body)
64 (declare (ignore args))
65 (let ((old-bsp (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*))
75 (let ((result (progn ,@body))
77 (when (not (eql ,old-bsp sb-vm::*binding-stack-pointer*))
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*))
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* ,old-asp)
90 (list* result extra-results))
97 (with-test (:name #1=:base-case)
98 ;; Tests that the unwind test machinery works.
100 (with-test-environment ()
101 (establish-return-frame (lambda () (perform-test-unwind)))
103 (format t "~S result: ~S~%" #1# result)
104 (assert (eql :success (car result)))))
106 (with-test (:name #1=:special-binding)
107 ;; Tests that special bindings are undone properly during
110 (with-test-environment ()
111 (let ((foo :success))
112 (declare (special foo))
113 (establish-return-frame (lambda ()
115 (declare (special foo))
116 (perform-test-unwind))))
118 (format t "~S result: ~S~%" #1# result)
119 (assert (eql :success (car result)))))
121 (with-test (:name #1=:unwind-protect)
122 ;; Tests that unwind-protect forms are run during unwind.
124 (with-test-environment ()
126 (establish-return-frame (lambda ()
128 (perform-test-unwind)
129 (setf result :success))))
131 (format t "~S result: ~S~%" #1# result)
132 (assert (eql :success (car result)))))
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.
138 (with-test-environment ()
140 (establish-return-frame (lambda ()
143 (perform-test-unwind)
145 (setf result :success)))
147 (format t "~S result: ~S~%" #1# result)
148 (assert (eql :success (car result)))))
150 (with-test (:name #1=:no-unwind)
151 ;; Basic smoke test of establish-return-frame.
153 (with-test-environment ()
154 (establish-return-frame (lambda ()))
156 (format t "~S result: ~S~%" #1# result)
157 (assert (eql :success (car result)))))
159 (with-test (:name #1=:no-unwind-error)
160 ;; Tests that EXCEPTION_BREAKPOINT is caught and handled
161 ;; correctly within callbacks.
163 (with-test-environment ()
164 (establish-return-frame (lambda ()
166 (some-undefined-function)
167 (undefined-function ()))))
169 (format t "~S result: ~S~%" #1# result)
170 (assert (eql :success (car result)))))
172 (with-test (:name #1=:unwind-foreign-frame)
173 ;; Tests that unwinding a foreign SEH frame isn't completely
176 (with-test-environment ()
178 (establish-return-frame (lambda () (return :success)))))))
179 (format t "~S result: ~S~%" #1# result)
180 (assert (eql :success (car result)))))
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.
186 (with-test-environment ()
188 (establish-return-frame (lambda ()
190 (perform-test-unwind)
191 (return :success))))))))
192 (format t "~S result: ~S~%" #1# result)
193 (assert (eql :success (car result)))))
195 (with-test (:name #1=:unwind-error)
196 ;; Another test for unwinding an SEH frame.
198 (with-test-environment ()
200 (establish-return-frame (lambda ()
204 (format t "~S result: ~S~%" #1# result)
205 (assert (eql :success (car result)))))