1 ;;;; tests of the system's ability to catch resource exhaustion problems
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 #+interpreter
(invoke-restart 'run-tests
::skip-file
)
16 (test-util::disable-profiling
)
18 ;;; Prior to sbcl-0.7.1.38, doing something like (RECURSE), even in
19 ;;; safe code, would crash the entire Lisp process. Then the soft
20 ;;; stack checking was introduced, which checked (in safe code) for
21 ;;; stack exhaustion at each lambda.
23 ;;; Post 0.7.6.1, this was rewritten to use mprotect()-based stack
24 ;;; protection which does not require lisp code to check anything,
25 ;;; and works at all optimization settings. However, it now signals a
26 ;;; STORAGE-CONDITION instead of an ERROR.
34 ;; Don't want to keep seeing failures that happen under parallel-exec
35 ;; (It's not even "random" now - it's pretty reliable)
36 ;; Gotta do with fork() or something that I don't care to diagnose.
37 #+(and darwin x86-64 parallel-test-runner
) (invoke-restart 'run-tests
::skip-file
)
39 (setf (extern-alien "lose_on_corruption_p" int
) 0)
41 ;;; Base-case: detecting exhaustion
42 (with-test (:name
(:exhaust
:basic
))
43 (assert (eq :exhausted
46 (storage-condition (c)
50 ;;; Regression test: we used to misconfigure the stack for new threads on win32.
52 (with-test (:name
(:exhaust
:basic
:new-thread
))
53 (assert (eq :exhausted
54 (sb-thread:join-thread
55 (sb-thread:make-thread
59 (storage-condition (c)
63 ;;; Check that non-local control transfers restore the stack
64 ;;; exhaustion checking after unwinding -- and that previous test
66 (with-test (:name
(:exhaust
:non-local-control
))
67 (let ((exhaust-count 0)
71 (handler-bind ((storage-condition (lambda (c)
73 (if (= *count
* (incf exhaust-count
))
79 (assert (= exhaust-count recurse-count
*count
*))))
81 ;;; Check that we can safely use user-provided restarts to
83 (with-test (:name
(:exhaust
:restarts
))
84 (let ((exhaust-count 0)
87 (handler-bind ((storage-condition (lambda (c)
89 (if (= *count
* (incf exhaust-count
))
91 (invoke-restart (find-restart 'ok
))))))
93 (with-simple-restart (ok "ok")
96 (assert (= exhaust-count recurse-count
*count
*))))
98 ;;; We can get away with writing to the stack on unwind as long as we don't
99 ;;; write on the Windows-managed control stack guard page /after/ triggering the
100 ;;; memory protection set up by win32_reset_stack_overflow_guard_page(). This is
101 ;;; certainly not fool proof, though.
102 (with-test (:name
(:exhaust
:write-to-stack-on-unwind
)
103 :skipped-on
(not :win32
))
105 (labels ((recurse-and-write-to-stack-on-unwind ()
106 (let ((x (random 1.0)))
108 (recurse-and-write-to-stack-on-unwind)
109 (incf x
(random 1.0))))))
111 (handler-bind ((storage-condition (lambda (c)
112 (format t
"Got ~s, unwinding...~%" c
)
115 (recurse-and-write-to-stack-on-unwind))))
116 (assert (eql count
1))))
118 ;;; On Windows, we can freely write to the stack while handling
119 ;;; STORAGE-CONDITION because its equivalent to CONTROL_STACK_RETURN_GUARD_PAGE
120 ;;; is only set up while unwinding from the STACK_OVERFLOW_EXCEPTION handler.
121 ;;; On other platforms, while handling the initial STORAGE-CONDITION, this test
122 ;;; will re-trigger the CONTROL_STACK_RETURN_GUARD_PAGE and
123 ;;; CONTROL_STACK_GUARD_PAGE, and issue a CORRUPTION WARNING.
124 (with-test (:name
(:exhaust
:write-to-stack-in-handler
)
125 :skipped-on
(not :win32
))
126 (labels ((recurse-and-write-to-stack-on-error ()
128 (handler-bind ((storage-condition (lambda (c)
130 (setq x
(random 1.0)))))
131 (recurse-and-write-to-stack-on-error)
133 (handler-case (recurse-and-write-to-stack-on-error)
134 (storage-condition ()))))
136 (with-test (:name
(:exhaust
:binding-stack
))
138 (symbols (loop repeat
1024 collect
(gensym)))
139 (values (loop repeat
1024 collect nil
)))
141 (labels ((exhaust-binding-stack (i)
142 (progv symbols values
143 (exhaust-binding-stack (1+ i
)))))
145 (exhaust-binding-stack 0)
146 (sb-kernel::binding-stack-exhausted
()
150 (with-test (:name
(:exhaust
:alien-stack
)
151 :skipped-on
(not :c-stack-is-control-stack
))
153 (labels ((exhaust-alien-stack (i)
154 (with-alien ((integer-array (array int
500)))
155 (+ (deref integer-array
0)
156 (exhaust-alien-stack (1+ i
))))))
158 (exhaust-alien-stack 0)
159 (sb-kernel::alien-stack-exhausted
()