gc.impure.lisp

   1 ;;;; gc tests
   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 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 (defparameter *x* ())
  17
  18 (defun cons-madly ()
  19   (loop repeat 10000 do
  20         (setq *x* (make-string 100000))))
  21
  22 ;; check that WITHOUT-INTERRUPTS doesn't block the gc trigger
  23 (sb-sys:without-interrupts (cons-madly))
  24
  25 ;; check that WITHOUT-INTERRUPTS doesn't block SIG_STOP_FOR_GC
  26 #+sb-thread
  27 (sb-sys:without-interrupts
  28   (let ((thread (sb-thread:make-thread (lambda () (sb-ext:gc)))))
  29     (loop while (sb-thread:thread-alive-p thread))))
  30
  31 (let ((gc-happend nil))
  32   (push (lambda () (setq gc-happend t)) sb-ext:*after-gc-hooks*)
  33
  34   ;; check that WITHOUT-GCING defers explicit gc
  35   (sb-sys:without-gcing
  36     (gc)
  37     (assert (not gc-happend)))
  38   (assert gc-happend)
  39
  40   ;; check that WITHOUT-GCING defers SIG_STOP_FOR_GC
  41   #+sb-thread
  42   (let ((in-without-gcing nil))
  43     (setq gc-happend nil)
  44     (sb-thread:make-thread (lambda ()
  45                              (loop while (not in-without-gcing))
  46                              (sb-ext:gc)))
  47     (sb-sys:without-gcing
  48       (setq in-without-gcing t)
  49       (sleep 3)
  50       (assert (not gc-happend)))
  51     ;; give the hook time to run
  52     (sleep 1)
  53     (assert gc-happend)))
  54
  55 ;;; SB-EXT:GENERATION-* accessors returned bogus values for generation > 0
  56 (with-test (:name :bug-529014 :skipped-on '(not :gencgc))
  57   (loop for i from 0 to sb-vm:+pseudo-static-generation+
  58      do (assert (= (sb-ext:generation-bytes-consed-between-gcs i)
  59                    (truncate (sb-ext:bytes-consed-between-gcs)
  60                              sb-vm:+highest-normal-generation+)))
  61         ;; FIXME: These parameters are a) tunable in the source and b)
  62         ;; duplicated multiple times there and now here.  It would be good to
  63         ;; OAOO-ify them (probably to src/compiler/generic/params.lisp).
  64         (assert (= (sb-ext:generation-minimum-age-before-gc i) 0.75))
  65         (assert (= (sb-ext:generation-number-of-gcs-before-promotion i) 1))))
  66
  67 (defun stress-gc ()
  68   (let* ((x (make-array (truncate (* 0.2 (dynamic-space-size))
  69                                   sb-vm:n-word-bytes))))
  70     (elt x 0)))
  71
  72 (with-test (:name :bug-936304)
  73   (gc :full t)
  74   (time
  75    (assert (eq :ok (handler-case
  76                        (progn
  77                          (loop repeat 50 do (stress-gc))
  78                          :ok)
  79                      (storage-condition ()
  80                        :oom))))))
  81
  82 (with-test (:name :bug-981106)
  83   (gc :full t)
  84   (time
  85    (assert (eq :ok
  86                (handler-case
  87                    (dotimes (runs 100 :ok)
  88                      (let* ((n (truncate (dynamic-space-size) 1200))
  89                             (len (length
  90                                   (with-output-to-string (string)
  91                                     (dotimes (i n)
  92                                       (write-sequence "hi there!" string))))))
  93                        (assert (eql len (* n (length "hi there!"))))))
  94                  (storage-condition ()
  95                    :oom))))))