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     #+immobile-space
  27     (sb-vm::map-referencing-objects (lambda (referer) (push referer referers))
  28                                     :immobile v)
  29     (assert (member 'satisfies referers))))
  30
  31 (defparameter *x* ())
  32
  33 (defun cons-madly ()
  34   (loop repeat 10000 do
  35         (setq *x* (make-string 100000))))
  36
  37 ;; check that WITHOUT-INTERRUPTS doesn't block the gc trigger
  38 (sb-sys:without-interrupts (cons-madly))
  39
  40 ;; check that WITHOUT-INTERRUPTS doesn't block SIG_STOP_FOR_GC
  41 #+sb-thread
  42 (sb-sys:without-interrupts
  43   (let ((thread (sb-thread:make-thread (lambda () (sb-ext:gc)))))
  44     (loop while (sb-thread:thread-alive-p thread))))
  45
  46 (let ((gc-happend nil))
  47   (push (lambda () (setq gc-happend t)) sb-ext:*after-gc-hooks*)
  48
  49   ;; check that WITHOUT-GCING defers explicit gc
  50   (sb-sys:without-gcing
  51     (gc)
  52     (assert (not gc-happend)))
  53   (assert gc-happend)
  54
  55   ;; check that WITHOUT-GCING defers SIG_STOP_FOR_GC
  56   #+sb-thread
  57   (let ((in-without-gcing nil))
  58     (setq gc-happend nil)
  59     (sb-thread:make-thread (lambda ()
  60                              (loop while (not in-without-gcing))
  61                              (sb-ext:gc)))
  62     (sb-sys:without-gcing
  63       (setq in-without-gcing t)
  64       (sleep 3)
  65       (assert (not gc-happend)))
  66     ;; give the hook time to run
  67     (sleep 1)
  68     (assert gc-happend)))
  69
  70 ;;; SB-EXT:GENERATION-* accessors returned bogus values for generation > 0
  71 (with-test (:name :bug-529014 :skipped-on '(not :gencgc))
  72   (loop for i from 0 to sb-vm:+pseudo-static-generation+
  73      do (assert (= (sb-ext:generation-bytes-consed-between-gcs i)
  74                    (truncate (sb-ext:bytes-consed-between-gcs)
  75                              sb-vm:+highest-normal-generation+)))
  76         ;; FIXME: These parameters are a) tunable in the source and b)
  77         ;; duplicated multiple times there and now here.  It would be good to
  78         ;; OAOO-ify them (probably to src/compiler/generic/params.lisp).
  79         (assert (= (sb-ext:generation-minimum-age-before-gc i) 0.75))
  80         (assert (= (sb-ext:generation-number-of-gcs-before-promotion i) 1))))
  81
  82 (defun stress-gc ()
  83   ;; Kludge or not?  I don't know whether the smaller allocation size
  84   ;; for sb-safepoint is a legitimate correction to the test case, or
  85   ;; rather hides the actual bug this test is checking for...  It's also
  86   ;; not clear to me whether the issue is actually safepoint-specific.
  87   ;; But the main problem safepoint-related bugs tend to introduce is a
  88   ;; delay in the GC triggering -- and if bug-936304 fails, it also
  89   ;; causes bug-981106 to fail, even though there is a full GC in
  90   ;; between, which makes it seem unlikely to me that the problem is
  91   ;; delay- (and hence safepoint-) related. --DFL
  92   (let* ((x (make-array (truncate #-sb-safepoint (* 0.2 (dynamic-space-size))
  93                                   #+sb-safepoint (* 0.1 (dynamic-space-size))
  94                                   sb-vm:n-word-bytes))))
  95     (elt x 0)))
  96
  97 (with-test (:name :bug-936304)
  98   (gc :full t)
  99   (time
 100    (assert (eq :ok (handler-case
 101                        (progn
 102                          (loop repeat 50 do (stress-gc))
 103                          :ok)
 104                      (storage-condition ()
 105                        :oom))))))
 106
 107 (with-test (:name :bug-981106)
 108   (gc :full t)
 109   (time
 110    (assert (eq :ok
 111                (handler-case
 112                    (dotimes (runs 100 :ok)
 113                      (let* ((n (truncate (dynamic-space-size) 1200))
 114                             (len (length
 115                                   (with-output-to-string (string)
 116                                     (dotimes (i n)
 117                                       (write-sequence "hi there!" string))))))
 118                        (assert (eql len (* n (length "hi there!"))))))
 119                  (storage-condition ()
 120                    :oom))))))
 121
 122 (with-test (:name :gc-logfile :skipped-on '(not :gencgc))
 123   (assert (not (gc-logfile)))
 124   (let ((p #p"gc.log"))
 125     (assert (not (probe-file p)))
 126     (assert (equal p (setf (gc-logfile) p)))
 127     (gc)
 128     (let ((p2 (gc-logfile)))
 129       (assert (equal (truename p2) (truename p))))
 130     (assert (not (setf (gc-logfile) nil)))
 131     (assert (not (gc-logfile)))
 132     (delete-file p)))
 133
 134 #+immobile-code
 135 (with-test (:name (sb-kernel::order-by-in-degree :uninterned-function-names))
 136   ;; This creates two functions whose names are uninterned symbols and
 137   ;; that are both referenced once, resulting in a tie
 138   ;; w.r.t. ORDER-BY-IN-DEGREE. Uninterned symbols used to cause an
 139   ;; error in the tie-breaker.
 140   (let* ((sb-c::*compile-to-memory-space* :immobile)
 141          (f (eval `(defun ,(gensym) ())))
 142          (g (eval `(defun ,(gensym) ()))))
 143     (eval `(defun h () (,f) (,g))))
 144   (sb-kernel::order-by-in-degree))
 145
 146 (defparameter *pin-test-object* nil)
 147 (defparameter *pin-test-object-address* nil)
 148
 149 (with-test (:name (sb-sys:with-pinned-objects :actually-pins-objects)
 150                   :skipped-on ':cheneygc)
 151   ;; The interpreters (both sb-eval and sb-fasteval) special-case
 152   ;; WITH-PINNED-OBJECTS as a "special form", because the x86oid
 153   ;; version of WITH-PINNED-OBJECTS uses black magic that isn't
 154   ;; supportable outside of the compiler.  The non-x86oid versions of
 155   ;; WITH-PINNED-OBJECTS don't use black magic, but are overridden
 156   ;; anyway.  But the special-case logic was, historically broken, and
 157   ;; this affects all gencgc targets (cheneygc isn't affected because
 158   ;; cheneygc WITH-PINNED-OBJECTS devolves to WITHOUT-GCING).
 159   ;;
 160   ;; Our basic approach is to allocate some kind of object and stuff
 161   ;; it where it doesn't need to be on the control stack.  We then pin
 162   ;; the object, take its address and store that somewhere as well,
 163   ;; force a full GC, re-take the address, and see if it moved.
 164   (locally (declare (notinline make-string)) ;; force full call
 165     (setf *pin-test-object* (make-string 100)))
 166   (sb-sys:with-pinned-objects (*pin-test-object*)
 167     (setf *pin-test-object-address*
 168           (sb-kernel:get-lisp-obj-address *pin-test-object*))
 169     (gc :full t)
 170     (assert (= (sb-kernel:get-lisp-obj-address *pin-test-object*)
 171                *pin-test-object-address*))))