1 ;;;; a stress test for the garbage collector
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
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.
24 (declaim (optimize (safety 3) (speed 2)))
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)
30 (declaim (type simple-vector *reprs*))
32 (defun random-element (seq)
33 (elt seq (random (length seq))))
36 (declare (type fixnum i))
37 (let ((result (svref *reprs* (mod i (length *reprs*)))))
38 #+nil (/show "REPRESENT" i result)
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)
50 (if (plusp remaining-passes-to-full-gc)
51 (decf remaining-passes-to-full-gc)
53 #+nil (/show "doing 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
60 (i-generation (isqrt (random (expt (length generations) 2))))
61 (generation-i (aref generations i-generation)))
62 #+nil (/show i-generation generation-i)
64 (assert-generation i-generation generation-i))
65 (when (or (null generation-i)
67 #+nil (/show "allocating or reallocating" i-generation)
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)
75 (format t "~&done with STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size))
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
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))))
104 (defun repr-fixnum (index &optional (value nil value-p))
105 (let ((fixnum (the fixnum (+ index 101))))
110 (defun repr-function (index &optional (value nil value-p))
111 (let ((fixnum (mod (+ index 2) 3)))
113 (eql fixnum (funcall value))
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)
122 (defstruct repr-instance slot)
123 (defun repr-instance (index &optional (value nil value-p))
124 (let ((fixnum (mod (* index 3) 4)))
126 (and (typep value 'repr-instance)
127 (eql (repr-instance-slot value) fixnum))
128 (make-repr-instance :slot fixnum))))
130 (defun repr-eql-hash-table (index &optional (value nil value-p))
131 (let ((first-fixnum (mod (* index 31) 9))
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)
140 (repr-bignum index (gethash 'bignum value))
141 (repr-ratio index (gethash 'ratio value))
143 (let ((hash-table (make-hash-table :test 'eql)))
144 (dotimes (i n-fixnums)
145 (setf (gethash (+ first-fixnum i) hash-table) i))
147 (setf (gethash 'bignum hash-table) (repr-bignum index)
148 (gethash 'ratio hash-table) (repr-ratio index))
152 (defun repr-weak-key-hash-table (index &optional (value nil value-p))
153 (let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
156 (and (hash-table-p value)
157 (<= (hash-table-count value) n)
159 (let ((x (gethash (+ i first) value)))
160 (unless (or (null x) (= x i))
162 (let ((hash-table (make-hash-table
164 :test (random-element '(eq eql equal equalp)))))
166 (setf (gethash (+ first i) hash-table) i))
169 (defun repr-bignum (index &optional (value nil value-p))
170 (let ((bignum (+ index 10000300020)))
175 (defun repr-ratio (index &optional (value nil value-p))
176 (let ((ratio (/ index (1+ index))))
181 (defun repr-single-float (index &optional (value nil value-p))
182 (let ((single-float (* 0.25 (float index) (1+ (float index)))))
184 (eql value single-float)
187 (defun repr-double-float (index &optional (value nil value-p))
188 (let ((double-float (+ 0.25d0 (1- index) (1+ (float index)))))
190 (eql value double-float)
193 (defun repr-simple-string (index &optional (value nil value-p))
194 (let ((length (mod index 14)))
197 (typep value 'simple-array)
198 (= (length value) length))
199 (make-string length))))
201 (defun repr-simple-vector (index &optional (value nil value-p))
202 (let ((length (mod (1+ index) 16)))
204 (and (simple-vector-p value)
205 (= (array-dimension value 0) length))
206 (make-array length))))
208 (defun repr-complex-vector (index &optional (value nil value-p))
209 (let* ((size (mod (* 5 index) 13))
210 (length (floor size 3)))
213 (not (typep value 'simple-array))
214 (= (array-dimension value 0) size)
215 (= (length value) length))
216 (make-array size :fill-pointer length))))
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)))))
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)))))
229 (eql value base-char)
233 (vector #'repr-fixnum
236 #'repr-eql-hash-table
237 #'repr-weak-key-hash-table
239 #'repr-equal-hash-table
240 #'repr-equalp-hash-table
247 #'repr-complex-single-float
248 #'repr-complex-double-float
253 #'repr-simple-bit-vector
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
267 #'repr-complex-vector
270 ;; TO DO: #'repr-funcallable-instance
275 ;; TO DO? #'repr-unbound-marker
276 ;; TO DO? #'repr-weak-pointer
277 ;; TO DO? #'repr-instance-header
278 ;; TO DO? #'repr-fdefn