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