tests/exhaust.impure.lisp

   1 ;;;; tests of the system's ability to catch resource exhaustion problems
   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 #+interpreter (invoke-restart 'run-tests::skip-file)
  15
  16 (test-util::disable-profiling)
  17 \f
  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.
  22
  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.
  27
  28 (defun recurse ()
  29   (recurse)
  30   (recurse))
  31
  32 (defvar *count* 100)
  33
  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)
  38
  39 (setf (extern-alien "lose_on_corruption_p" int) 0)
  40
  41 ;;; Base-case: detecting exhaustion
  42 (with-test (:name (:exhaust :basic))
  43   (assert (eq :exhausted
  44               (handler-case
  45                   (recurse)
  46                 (storage-condition (c)
  47                   (declare (ignore c))
  48                   :exhausted)))))
  49
  50 ;;; Regression test: we used to misconfigure the stack for new threads on win32.
  51 #+sb-thread
  52 (with-test (:name (:exhaust :basic :new-thread))
  53   (assert (eq :exhausted
  54               (sb-thread:join-thread
  55                (sb-thread:make-thread
  56                 (lambda ()
  57                   (handler-case
  58                       (recurse)
  59                     (storage-condition (c)
  60                       (declare (ignore c))
  61                       :exhausted))))))))
  62
  63 ;;; Check that non-local control transfers restore the stack
  64 ;;; exhaustion checking after unwinding -- and that previous test
  65 ;;; didn't break it.
  66 (with-test (:name (:exhaust :non-local-control))
  67   (let ((exhaust-count 0)
  68         (recurse-count 0))
  69     (tagbody
  70      :retry
  71        (handler-bind ((storage-condition (lambda (c)
  72                                            (declare (ignore c))
  73                                            (if (= *count* (incf exhaust-count))
  74                                                (go :stop)
  75                                                (go :retry)))))
  76          (incf recurse-count)
  77          (recurse))
  78      :stop)
  79     (assert (= exhaust-count recurse-count *count*))))
  80
  81 ;;; Check that we can safely use user-provided restarts to
  82 ;;; unwind.
  83 (with-test (:name (:exhaust :restarts))
  84   (let ((exhaust-count 0)
  85         (recurse-count 0))
  86     (block nil
  87       (handler-bind ((storage-condition (lambda (c)
  88                                           (declare (ignore c))
  89                                           (if (= *count* (incf exhaust-count))
  90                                               (return)
  91                                               (invoke-restart (find-restart 'ok))))))
  92         (loop
  93            (with-simple-restart (ok "ok")
  94              (incf recurse-count)
  95              (recurse)))))
  96     (assert (= exhaust-count recurse-count *count*))))
  97
  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))
 104   (let ((count 0))
 105     (labels ((recurse-and-write-to-stack-on-unwind ()
 106                (let ((x (random 1.0)))
 107                  (unwind-protect
 108                       (recurse-and-write-to-stack-on-unwind)
 109                    (incf x (random 1.0))))))
 110       (block nil
 111         (handler-bind ((storage-condition (lambda (c)
 112                                             (format t "Got ~s, unwinding...~%" c)
 113                                             (incf count)
 114                                             (return))))
 115           (recurse-and-write-to-stack-on-unwind))))
 116     (assert (eql count 1))))
 117
 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 ()
 127              (let ((x 0))
 128                (handler-bind ((storage-condition (lambda (c)
 129                                                    (declare (ignore c))
 130                                                    (setq x (random 1.0)))))
 131                  (recurse-and-write-to-stack-on-error)
 132                  x))))
 133     (handler-case (recurse-and-write-to-stack-on-error)
 134       (storage-condition ()))))
 135
 136 (with-test (:name (:exhaust :binding-stack))
 137   (let ((ok nil)
 138         (symbols (loop repeat 1024 collect (gensym)))
 139         (values (loop repeat 1024 collect nil)))
 140     (gc :full t)
 141     (labels ((exhaust-binding-stack (i)
 142                (progv symbols values
 143                  (exhaust-binding-stack (1+ i)))))
 144       (handler-case
 145           (exhaust-binding-stack 0)
 146         (sb-kernel::binding-stack-exhausted ()
 147           (setq ok t)))
 148       (assert ok))))
 149
 150 (with-test (:name (:exhaust :alien-stack)
 151                   :skipped-on (not :c-stack-is-control-stack))
 152   (let ((ok nil))
 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))))))
 157       (handler-case
 158           (exhaust-alien-stack 0)
 159         (sb-kernel::alien-stack-exhausted ()
 160           (setq ok t)))
 161       (assert ok))))
 162
 163 ;;; OK!