Clean up listify-rest-args VOP on x86-64.
[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 (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*))
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*))
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))
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!