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-pointer
*))
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-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
))
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
)))))