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 (sb-ext:exit :code 104)
  15
  16 (cl:in-package :cl-user)
  17
  18 (load "test-util.lisp")
  19 (load "assertoid.lisp")
  20 (use-package "TEST-UTIL")
  21 (use-package "ASSERTOID")
  22
  23 \f
  24 ;;; Prior to sbcl-0.7.1.38, doing something like (RECURSE), even in
  25 ;;; safe code, would crash the entire Lisp process. Then the soft
  26 ;;; stack checking was introduced, which checked (in safe code) for
  27 ;;; stack exhaustion at each lambda.
  28
  29 ;;; Post 0.7.6.1, this was rewritten to use mprotect()-based stack
  30 ;;; protection which does not require lisp code to check anything,
  31 ;;; and works at all optimization settings.  However, it now signals a
  32 ;;; STORAGE-CONDITION instead of an ERROR.
  33
  34 (defun recurse ()
  35   (recurse)
  36   (recurse))
  37
  38 (defvar *count* 100)
  39
  40 ;;; Base-case: detecting exhaustion
  41 (with-test (:name (:exhaust :basic) :broken-on '(and :sunos :x86-64))
  42   (assert (eq :exhausted
  43               (handler-case
  44                   (recurse)
  45                 (storage-condition (c)
  46                   (declare (ignore c))
  47                   :exhausted)))))
  48
  49 ;;; Check that non-local control transfers restore the stack
  50 ;;; exhaustion checking after unwinding -- and that previous test
  51 ;;; didn't break it.
  52 (with-test (:name (:exhaust :non-local-control)
  53                   :broken-on '(and :sunos :x86-64)
  54                   :skipped-on :win32)
  55   (let ((exhaust-count 0)
  56         (recurse-count 0))
  57     (tagbody
  58      :retry
  59        (handler-bind ((storage-condition (lambda (c)
  60                                            (declare (ignore c))
  61                                            (if (= *count* (incf exhaust-count))
  62                                                (go :stop)
  63                                                (go :retry)))))
  64          (incf recurse-count)
  65          (recurse))
  66      :stop)
  67     (assert (= exhaust-count recurse-count *count*))))
  68
  69 ;;; Check that we can safely use user-provided restarts to
  70 ;;; unwind.
  71 (with-test (:name (:exhaust :restarts)
  72                   :broken-on '(and :sunos :x86-64)
  73                   :skipped-on :win32)
  74   (let ((exhaust-count 0)
  75         (recurse-count 0))
  76     (block nil
  77       (handler-bind ((storage-condition (lambda (c)
  78                                           (declare (ignore c))
  79                                           (if (= *count* (incf exhaust-count))
  80                                               (return)
  81                                               (invoke-restart (find-restart 'ok))))))
  82         (loop
  83            (with-simple-restart (ok "ok")
  84              (incf recurse-count)
  85              (recurse)))))
  86     (assert (= exhaust-count recurse-count *count*))))
  87
  88 (with-test (:name (:exhaust :binding-stack))
  89   (let ((ok nil)
  90         (symbols (loop repeat 1024 collect (gensym)))
  91         (values (loop repeat 1024 collect nil)))
  92     (gc :full t)
  93     (labels ((exhaust-binding-stack (i)
  94                (progv symbols values
  95                  (exhaust-binding-stack (1+ i)))))
  96       (handler-case
  97           (exhaust-binding-stack 0)
  98         (sb-kernel::binding-stack-exhausted ()
  99           (setq ok t)))
 100       (assert ok))))
 101
 102 (with-test (:name (:exhaust :alien-stack)
 103                   :skipped-on '(or (not :c-stack-is-control-stack)))
 104   (let ((ok nil))
 105     (labels ((exhaust-alien-stack (i)
 106                (with-alien ((integer-array (array int 500)))
 107                  (+ (deref integer-array 0)
 108                     (exhaust-alien-stack (1+ i))))))
 109       (handler-case
 110           (exhaust-alien-stack 0)
 111         (sb-kernel::alien-stack-exhausted ()
 112           (setq ok t)))
 113       (assert ok))))
 114
 115 ;;; OK!