tests/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 ;;; Make sure MAP-REFERENCING-OBJECTS doesn't spuriously treat raw bits as
  17 ;;; potential pointers. Also make sure it sees the SYMBOL-INFO slot.
  18 (defstruct afoo (slot nil :type sb-ext:word))
  19 (defvar *afoo* (make-afoo :slot (sb-kernel:get-lisp-obj-address '*posix-argv*)))
  20 (with-test (:name :map-referencing-objs)
  21   (sb-vm::map-referencing-objects (lambda (x) (assert (not (typep x 'afoo))))
  22                                   :dynamic '*posix-argv*)
  23   (let ((v (sb-kernel:symbol-info 'satisfies)) referers)
  24     (sb-vm::map-referencing-objects (lambda (referer) (push referer referers))
  25                                     #+gencgc :dynamic #-gencgc :static v)
  26     (assert (member 'satisfies referers))))
  27
  28 (defparameter *x* ())
  29
  30 (defun cons-madly ()
  31   (loop repeat 10000 do
  32         (setq *x* (make-string 100000))))
  33
  34 ;; check that WITHOUT-INTERRUPTS doesn't block the gc trigger
  35 (sb-sys:without-interrupts (cons-madly))
  36
  37 ;; check that WITHOUT-INTERRUPTS doesn't block SIG_STOP_FOR_GC
  38 #+sb-thread
  39 (sb-sys:without-interrupts
  40   (let ((thread (sb-thread:make-thread (lambda () (sb-ext:gc)))))
  41     (loop while (sb-thread:thread-alive-p thread))))
  42
  43 (let ((gc-happend nil))
  44   (push (lambda () (setq gc-happend t)) sb-ext:*after-gc-hooks*)
  45
  46   ;; check that WITHOUT-GCING defers explicit gc
  47   (sb-sys:without-gcing
  48     (gc)
  49     (assert (not gc-happend)))
  50   (assert gc-happend)
  51
  52   ;; check that WITHOUT-GCING defers SIG_STOP_FOR_GC
  53   #+sb-thread
  54   (let ((in-without-gcing nil))
  55     (setq gc-happend nil)
  56     (sb-thread:make-thread (lambda ()
  57                              (loop while (not in-without-gcing))
  58                              (sb-ext:gc)))
  59     (sb-sys:without-gcing
  60       (setq in-without-gcing t)
  61       (sleep 3)
  62       (assert (not gc-happend)))
  63     ;; give the hook time to run
  64     (sleep 1)
  65     (assert gc-happend)))
  66
  67 ;;; SB-EXT:GENERATION-* accessors returned bogus values for generation > 0
  68 (with-test (:name :bug-529014 :skipped-on '(not :gencgc))
  69   (loop for i from 0 to sb-vm:+pseudo-static-generation+
  70      do (assert (= (sb-ext:generation-bytes-consed-between-gcs i)
  71                    (truncate (sb-ext:bytes-consed-between-gcs)
  72                              sb-vm:+highest-normal-generation+)))
  73         ;; FIXME: These parameters are a) tunable in the source and b)
  74         ;; duplicated multiple times there and now here.  It would be good to
  75         ;; OAOO-ify them (probably to src/compiler/generic/params.lisp).
  76         (assert (= (sb-ext:generation-minimum-age-before-gc i) 0.75))
  77         (assert (= (sb-ext:generation-number-of-gcs-before-promotion i) 1))))
  78
  79 (defun stress-gc ()
  80   ;; Kludge or not?  I don't know whether the smaller allocation size
  81   ;; for sb-safepoint is a legitimate correction to the test case, or
  82   ;; rather hides the actual bug this test is checking for...  It's also
  83   ;; not clear to me whether the issue is actually safepoint-specific.
  84   ;; But the main problem safepoint-related bugs tend to introduce is a
  85   ;; delay in the GC triggering -- and if bug-936304 fails, it also
  86   ;; causes bug-981106 to fail, even though there is a full GC in
  87   ;; between, which makes it seem unlikely to me that the problem is
  88   ;; delay- (and hence safepoint-) related. --DFL
  89   (let* ((x (make-array (truncate #-sb-safepoint (* 0.2 (dynamic-space-size))
  90                                   #+sb-safepoint (* 0.1 (dynamic-space-size))
  91                                   sb-vm:n-word-bytes))))
  92     (elt x 0)))
  93
  94 (with-test (:name :bug-936304)
  95   (gc :full t)
  96   (time
  97    (assert (eq :ok (handler-case
  98                        (progn
  99                          (loop repeat 50 do (stress-gc))
 100                          :ok)
 101                      (storage-condition ()
 102                        :oom))))))
 103
 104 (with-test (:name :bug-981106)
 105   (gc :full t)
 106   (time
 107    (assert (eq :ok
 108                (handler-case
 109                    (dotimes (runs 100 :ok)
 110                      (let* ((n (truncate (dynamic-space-size) 1200))
 111                             (len (length
 112                                   (with-output-to-string (string)
 113                                     (dotimes (i n)
 114                                       (write-sequence "hi there!" string))))))
 115                        (assert (eql len (* n (length "hi there!"))))))
 116                  (storage-condition ()
 117                    :oom))))))
 118
 119 (with-test (:name :gc-logfile :skipped-on '(not :gencgc))
 120   (assert (not (gc-logfile)))
 121   (let ((p #p"gc.log"))
 122     (assert (not (probe-file p)))
 123     (assert (equal p (setf (gc-logfile) p)))
 124     (gc)
 125     (let ((p2 (gc-logfile)))
 126       (assert (equal (truename p2) (truename p))))
 127     (assert (not (setf (gc-logfile) nil)))
 128     (assert (not (gc-logfile)))
 129     (delete-file p)))