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