tests/stress-gc.lisp

   1 ;;;; a stress test for the garbage collector
   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 ;;;; TO DO:
  15 ;;;;   * Add conses:
  16 ;;;;     ** Make REPR-CONS.
  17 ;;;;     ** Some generations should be lists, not vectors.
  18 ;;;;   * Make it so that ASSIGN-GENERATION on an existing generation
  19 ;;;;     only overwrites some of the elements (randomly), not all.
  20 ;;;;   * Review the GC code to look for other stuff I should test.
  21
  22 (in-package :cl-user)
  23
  24 (declaim (optimize (safety 3) (speed 2)))
  25
  26 ;;; a table of functions REPR-FOO which bear a vague correspondence
  27 ;;; to the types of memory representations used by SBCL (with each
  28 ;;; typically trying to exercise that type of representation)
  29 (defvar *reprs*)
  30 (declaim (type simple-vector *reprs*))
  31
  32 (defun random-element (seq)
  33   (elt seq (random (length seq))))
  34
  35 (defun repr (i)
  36   (declare (type fixnum i))
  37   (let ((result (svref *reprs* (mod i (length *reprs*)))))
  38     #+nil (/show "REPRESENT" i result)
  39     result))
  40
  41 (defun stress-gc (n-passes &optional (size 3000))
  42   (format t "~&beginning STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size)
  43   (let ((generations (make-array (isqrt size) :initial-element nil))
  44         ;; We allocate on the order of MOST-POSITIVE-FIXNUM things
  45         ;; before doing a full GC.
  46         (max-passes-to-full-gc (floor most-positive-fixnum size))
  47         (remaining-passes-to-full-gc 0))
  48     (dotimes (j-pass n-passes)
  49       #+nil (/show j-pass)
  50       (if (plusp remaining-passes-to-full-gc)
  51           (decf remaining-passes-to-full-gc)
  52           (progn
  53             #+nil (/show "doing GC :FULL T")
  54             (gc :full t)
  55             (setf remaining-passes-to-full-gc (random max-passes-to-full-gc))))
  56       (let* (;; (The (ISQRT (RANDOM (EXPT .. 2))) distribution here is
  57              ;; intended to give a distribution of lifetimes of memory
  58              ;; usage, with low-indexed generations tending to live
  59              ;; for a long time.)
  60              (i-generation (isqrt (random (expt (length generations) 2))))
  61              (generation-i (aref generations i-generation)))
  62         #+nil (/show i-generation generation-i)
  63         (when generation-i
  64           (assert-generation i-generation generation-i))
  65         (when (or (null generation-i)
  66                   (plusp (random 3)))
  67           #+nil (/show "allocating or reallocating" i-generation)
  68           (setf generation-i
  69                 (make-array (random (1+ size)))))
  70         (assign-generation i-generation generation-i)
  71         (when (plusp (random 3))
  72           (assert-generation i-generation generation-i))
  73         (setf (aref generations i-generation)
  74               generation-i))))
  75   (format t "~&done with STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size))
  76
  77 (defvar *expected*)
  78 (defvar *got*)
  79 (defun assert-generation (index-of-generation generation)
  80   (dotimes (index-within-generation (length generation))
  81     #+nil (/show "assert-generation" index-of-generation index-within-generation)
  82     (let ((element-of-generation (aref generation index-within-generation))
  83           (repr (repr (+ index-within-generation index-of-generation))))
  84       (unless (funcall repr index-within-generation element-of-generation)
  85         ;; KLUDGE: We bind these to special variables for the
  86         ;; convenience of the debugger, which ca. SBCL 0.6.6 is too
  87         ;; wimpy to inspect lexical variables.
  88         (let ((*expected* (funcall repr index-within-generation))
  89               (*got* element-of-generation))
  90           (error "bad element #~W in generation #~D:~%  expected ~S~%  from ~S,~%  got ~S"
  91                  index-within-generation
  92                  index-of-generation
  93                  *expected*
  94                  repr
  95                  *got*))))))
  96
  97 (defun assign-generation (index-of-generation generation)
  98   (dotimes (index-within-generation (length generation))
  99     #+nil (/show "assert-generation" index-of-generation index-within-generation)
 100     (setf (aref generation index-within-generation)
 101           (funcall (repr (+ index-within-generation index-of-generation))
 102                    index-within-generation))))
 103
 104 (defun repr-fixnum (index &optional (value nil value-p))
 105   (let ((fixnum (the fixnum (+ index 101))))
 106     (if value-p
 107         (eql fixnum value)
 108         fixnum)))
 109
 110 (defun repr-function (index &optional (value nil value-p))
 111   (let ((fixnum (mod (+ index 2) 3)))
 112     (if value-p
 113         (eql fixnum (funcall value))
 114         (ecase fixnum
 115           (0 #'repr-fixnum-zero)
 116           (1 #'repr-fixnum-one)
 117           (2 #'repr-fixnum-two)))))
 118 (defun repr-fixnum-zero () 0)
 119 (defun repr-fixnum-one () 1)
 120 (defun repr-fixnum-two () 2)
 121
 122 (defstruct repr-instance slot)
 123 (defun repr-instance (index &optional (value nil value-p))
 124   (let ((fixnum (mod (* index 3) 4)))
 125     (if value-p
 126         (and (typep value 'repr-instance)
 127              (eql (repr-instance-slot value) fixnum))
 128         (make-repr-instance :slot fixnum))))
 129
 130 (defun repr-eql-hash-table (index &optional (value nil value-p))
 131   (let ((first-fixnum (mod (* index 31) 9))
 132         (n-fixnums 5))
 133     (if value-p
 134         (and (hash-table-p value)
 135              (= (hash-table-count value) n-fixnums)
 136              (dotimes (i n-fixnums t)
 137                (unless (= (gethash (+ i first-fixnum) value) i)
 138                  (return nil)))
 139              #|
 140              (repr-bignum index (gethash 'bignum value))
 141              (repr-ratio index (gethash 'ratio value))
 142              |#)
 143         (let ((hash-table (make-hash-table :test 'eql)))
 144           (dotimes (i n-fixnums)
 145             (setf (gethash (+ first-fixnum i) hash-table) i))
 146           #|
 147           (setf (gethash 'bignum hash-table) (repr-bignum index)
 148                 (gethash 'ratio hash-table) (repr-ratio index))
 149           |#
 150           hash-table))))
 151
 152 (defun repr-weak-key-hash-table (index &optional (value nil value-p))
 153   (let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
 154         (n 5))
 155     (if value-p
 156         (and (hash-table-p value)
 157              (<= (hash-table-count value) n)
 158              (dotimes (i n t)
 159                (let ((x (gethash (+ i first) value)))
 160                  (unless (or (null x) (= x i))
 161                    (return nil)))))
 162         (let ((hash-table (make-hash-table
 163                            :weakness :key
 164                            :test (random-element '(eq eql equal equalp)))))
 165           (dotimes (i n)
 166             (setf (gethash (+ first i) hash-table) i))
 167           hash-table))))
 168
 169 (defun repr-bignum (index &optional (value nil value-p))
 170   (let ((bignum (+ index 10000300020)))
 171     (if value-p
 172         (eql value bignum)
 173         bignum)))
 174
 175 (defun repr-ratio (index &optional (value nil value-p))
 176   (let ((ratio (/ index (1+ index))))
 177     (if value-p
 178         (eql value ratio)
 179         ratio)))
 180
 181 (defun repr-single-float (index &optional (value nil value-p))
 182   (let ((single-float (* 0.25 (float index) (1+ (float index)))))
 183     (if value-p
 184         (eql value single-float)
 185         single-float)))
 186
 187 (defun repr-double-float (index &optional (value nil value-p))
 188   (let ((double-float (+ 0.25d0 (1- index) (1+ (float index)))))
 189     (if value-p
 190         (eql value double-float)
 191         double-float)))
 192
 193 (defun repr-simple-string (index &optional (value nil value-p))
 194   (let ((length (mod index 14)))
 195     (if value-p
 196         (and (stringp value)
 197              (typep value 'simple-array)
 198              (= (length value) length))
 199         (make-string length))))
 200
 201 (defun repr-simple-vector (index &optional (value nil value-p))
 202   (let ((length (mod (1+ index) 16)))
 203     (if value-p
 204         (and (simple-vector-p value)
 205              (= (array-dimension value 0) length))
 206         (make-array length))))
 207
 208 (defun repr-complex-vector (index &optional (value nil value-p))
 209   (let* ((size (mod (* 5 index) 13))
 210          (length (floor size 3)))
 211     (if value-p
 212         (and (vectorp value)
 213              (not (typep value 'simple-array))
 214              (= (array-dimension value 0) size)
 215              (= (length value) length))
 216         (make-array size :fill-pointer length))))
 217
 218 (defun repr-symbol (index &optional (value nil value-p))
 219   (let* ((symbols #(zero one two three four))
 220          (symbol (aref symbols (mod index (length symbols)))))
 221     (if value-p
 222         (eq value symbol)
 223         symbol)))
 224
 225 (defun repr-base-char (index &optional (value nil value-p))
 226   (let* ((base-chars #(#\z #\o #\t #\t #\f #\f #\s #\s #\e))
 227          (base-char (aref base-chars (mod index (length base-chars)))))
 228     (if value-p
 229         (eql value base-char)
 230         base-char)))
 231
 232 (setf *reprs*
 233       (vector #'repr-fixnum
 234               #'repr-function
 235               #'repr-instance
 236               #'repr-eql-hash-table
 237               #'repr-weak-key-hash-table
 238 #|
 239               #'repr-equal-hash-table
 240               #'repr-equalp-hash-table
 241 |#
 242               #'repr-bignum
 243               #'repr-ratio
 244               #'repr-single-float
 245               #'repr-double-float
 246 #|
 247               #'repr-complex-single-float
 248               #'repr-complex-double-float
 249               #'repr-simple-array
 250 |#
 251               #'repr-simple-string
 252 #|
 253               #'repr-simple-bit-vector
 254 |#
 255               #'repr-simple-vector
 256 #|
 257               #'repr-simple-array-u2
 258               #'repr-simple-array-u4
 259               #'repr-simple-array-u8
 260               #'repr-simple-array-u16
 261               #'repr-simple-array-u32
 262               #'repr-simple-array-single-float
 263               #'repr-simple-array-double-float
 264               #'repr-complex-string
 265               #'repr-complex-bit-vector
 266 |#
 267               #'repr-complex-vector
 268 #|
 269               #'repr-complex-array
 270               ;; TO DO: #'repr-funcallable-instance
 271 |#
 272               #'repr-symbol
 273               #'repr-base-char
 274               ;; TO DO: #'repr-sap
 275               ;; TO DO? #'repr-unbound-marker
 276               ;; TO DO? #'repr-weak-pointer
 277               ;; TO DO? #'repr-instance-header
 278               ;; TO DO? #'repr-fdefn
 279               ))