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   (assert (eq :ok (handler-case
 100                        (progn
 101                          (loop repeat 50 do (stress-gc))
 102                          :ok)
 103                      (storage-condition ()
 104                        :oom)))))
 105
 106 (with-test (:name :bug-981106)
 107   (gc :full t)
 108   (assert (eq :ok
 109                (handler-case
 110                    (dotimes (runs 100 :ok)
 111                      (let* ((n (truncate (dynamic-space-size) 1200))
 112                             (len (length
 113                                   (with-output-to-string (string)
 114                                     (dotimes (i n)
 115                                       (write-sequence "hi there!" string))))))
 116                        (assert (eql len (* n (length "hi there!"))))))
 117                  (storage-condition ()
 118                    :oom)))))
 119
 120 (with-test (:name :gc-logfile :skipped-on '(not :gencgc))
 121   (assert (not (gc-logfile)))
 122   (let ((p #p"gc.log"))
 123     (assert (not (probe-file p)))
 124     (assert (equal p (setf (gc-logfile) p)))
 125     (gc)
 126     (let ((p2 (gc-logfile)))
 127       (assert (equal (truename p2) (truename p))))
 128     (assert (not (setf (gc-logfile) nil)))
 129     (assert (not (gc-logfile)))
 130     (delete-file p)))
 131
 132 #+immobile-code
 133 (with-test (:name (sb-kernel::order-by-in-degree :uninterned-function-names))
 134   ;; This creates two functions whose names are uninterned symbols and
 135   ;; that are both referenced once, resulting in a tie
 136   ;; w.r.t. ORDER-BY-IN-DEGREE. Uninterned symbols used to cause an
 137   ;; error in the tie-breaker.
 138   (let* ((sb-c::*compile-to-memory-space* :immobile)
 139          (f (eval `(defun ,(gensym) ())))
 140          (g (eval `(defun ,(gensym) ()))))
 141     (eval `(defun h () (,f) (,g))))
 142   (sb-kernel::order-by-in-degree))
 143
 144 (defparameter *pin-test-object* nil)
 145 (defparameter *pin-test-object-address* nil)
 146
 147 (with-test (:name (sb-sys:with-pinned-objects :actually-pins-objects)
 148                   :skipped-on ':cheneygc)
 149   ;; The interpreters (both sb-eval and sb-fasteval) special-case
 150   ;; WITH-PINNED-OBJECTS as a "special form", because the x86oid
 151   ;; version of WITH-PINNED-OBJECTS uses black magic that isn't
 152   ;; supportable outside of the compiler.  The non-x86oid versions of
 153   ;; WITH-PINNED-OBJECTS don't use black magic, but are overridden
 154   ;; anyway.  But the special-case logic was, historically broken, and
 155   ;; this affects all gencgc targets (cheneygc isn't affected because
 156   ;; cheneygc WITH-PINNED-OBJECTS devolves to WITHOUT-GCING).
 157   ;;
 158   ;; Our basic approach is to allocate some kind of object and stuff
 159   ;; it where it doesn't need to be on the control stack.  We then pin
 160   ;; the object, take its address and store that somewhere as well,
 161   ;; force a full GC, re-take the address, and see if it moved.
 162   (locally (declare (notinline make-string)) ;; force full call
 163     (setf *pin-test-object* (make-string 100)))
 164   (sb-sys:with-pinned-objects (*pin-test-object*)
 165     (setf *pin-test-object-address*
 166           (sb-kernel:get-lisp-obj-address *pin-test-object*))
 167     (gc :full t)
 168     (assert (= (sb-kernel:get-lisp-obj-address *pin-test-object*)
 169                *pin-test-object-address*))))
 170
 171 (defun ensure-code/data-separation ()
 172   (let* ((n-bits (+ sb-vm::last-free-page 10))
 173          (code-bits (make-array n-bits :element-type 'bit))
 174          (data-bits (make-array n-bits :element-type 'bit))
 175          (total-code-size 0))
 176     (sb-vm::map-allocated-objects
 177      (lambda (obj type size)
 178        ;; M-A-O disables GC, therefore GET-LISP-OBJ-ADDRESS is safe
 179        (let ((obj-addr (sb-kernel:get-lisp-obj-address obj))
 180              (array (cond ((= type sb-vm:code-header-widetag)
 181                            (incf total-code-size size)
 182                            code-bits)
 183                           (t
 184                            data-bits))))
 185          ;; This is not the most efficient way to update the bit arrays,
 186          ;; but the simplest and clearest for sure. (The loop could avoided
 187          ;; if the current page is the same as the previously seen page)
 188          (loop for index from (sb-vm::find-page-index obj-addr)
 189                to (sb-vm::find-page-index (+ (logandc2 obj-addr sb-vm:lowtag-mask)
 190                                              (1- size)))
 191                do (setf (sbit array index) 1))))
 192      :dynamic)
 193     (assert (not (find 1 (bit-and code-bits data-bits))))
 194     (let* ((code-bytes-consumed
 195             (* (count 1 code-bits) sb-vm:gencgc-card-bytes))
 196            (waste
 197             (- total-code-size code-bytes-consumed)))
 198       ;; This should be true for all platforms.
 199       ;; Some have as little as .5% space wasted.
 200       (assert (< waste (* 3/100 code-bytes-consumed))))))
 201
 202 (compile 'ensure-code/data-separation)
 203
 204 (with-test (:name :code/data-separation
 205                   :skipped-on '(:not :gencgc))
 206   (ensure-code/data-separation))