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