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)
  51                   :broken-on '(and :sunos :x86-64)
  52                   :skipped-on :win32)
  53   (let ((exhaust-count 0)
  54         (recurse-count 0))
  55     (tagbody
  56      :retry
  57        (handler-bind ((storage-condition (lambda (c)
  58                                            (declare (ignore c))
  59                                            (if (= *count* (incf exhaust-count))
  60                                                (go :stop)
  61                                                (go :retry)))))
  62          (incf recurse-count)
  63          (recurse))
  64      :stop)
  65     (assert (= exhaust-count recurse-count *count*))))
  66
  67 ;;; Check that we can safely use user-provided restarts to
  68 ;;; unwind.
  69 (with-test (:name (:exhaust :restarts)
  70                   :broken-on '(and :sunos :x86-64)
  71                   :skipped-on :win32)
  72   (let ((exhaust-count 0)
  73         (recurse-count 0))
  74     (block nil
  75       (handler-bind ((storage-condition (lambda (c)
  76                                           (declare (ignore c))
  77                                           (if (= *count* (incf exhaust-count))
  78                                               (return)
  79                                               (invoke-restart (find-restart 'ok))))))
  80         (loop
  81            (with-simple-restart (ok "ok")
  82              (incf recurse-count)
  83              (recurse)))))
  84     (assert (= exhaust-count recurse-count *count*))))
  85
  86 (with-test (:name (:exhaust :binding-stack) :skipped-on :win32)
  87   (let ((ok nil)
  88         (symbols (loop repeat 1024 collect (gensym)))
  89         (values (loop repeat 1024 collect nil)))
  90     (gc :full t)
  91     (labels ((exhaust-binding-stack (i)
  92                (progv symbols values
  93                  (exhaust-binding-stack (1+ i)))))
  94       (handler-case
  95           (exhaust-binding-stack 0)
  96         (sb-kernel::binding-stack-exhausted ()
  97           (setq ok t)))
  98       (assert ok))))
  99
 100 (with-test (:name (:exhaust :alien-stack)
 101                   :skipped-on '(not :c-stack-is-control-stack)
 102                   :fails-on :win32)
 103   (let ((ok nil))
 104     (labels ((exhaust-alien-stack (i)
 105                (with-alien ((integer-array (array int 500)))
 106                  (+ (deref integer-array 0)
 107                     (exhaust-alien-stack (1+ i))))))
 108       (handler-case
 109           (exhaust-alien-stack 0)
 110         (sb-kernel::alien-stack-exhausted ()
 111           (setq ok t)))
 112       (assert ok))))
 113
 114 ;;; OK!