tests/stress-gc.lisp

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