1 ;;;; a stress test for the garbage collector
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.
13 (declaim (optimize (safety 3) (speed 2)))
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)
19 (declaim (type simple-vector *reprs*))
22 (declare (type fixnum i))
23 (let ((result (svref *reprs* (mod i (length *reprs*)))))
24 #+nil (/show "REPRESENT" i result)
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)
36 (if (plusp remaining-passes-to-full-gc)
37 (decf remaining-passes-to-full-gc)
39 #+nil (/show "doing 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
46 (i-generation (isqrt (random (expt (length generations) 2))))
47 (generation-i (aref generations i-generation)))
48 #+nil (/show i-generation generation-i)
50 (assert-generation i-generation generation-i))
51 (when (or (null generation-i)
53 #+nil (/show "allocating or reallocating" i-generation)
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)
61 (format t "~&done with STRESS-GC N-PASSES=~D SIZE=~D~%" n-passes size))
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
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))))
90 (defun repr-fixnum (index &optional (value nil value-p))
91 (let ((fixnum (the fixnum (+ index 101))))
96 (defun repr-function (index &optional (value nil value-p))
97 (let ((fixnum (mod (+ index 2) 3)))
99 (eql fixnum (funcall value))
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)
108 (defstruct repr-instance slot)
109 (defun repr-instance (index &optional (value nil value-p))
110 (let ((fixnum (mod (* index 3) 4)))
112 (and (typep value 'repr-instance)
113 (eql (repr-instance-slot value) fixnum))
114 (make-repr-instance :slot fixnum))))
116 (defun repr-eql-hash-table (index &optional (value nil value-p))
117 (let ((first-fixnum (mod (* index 31) 9))
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)
126 (repr-bignum index (gethash 'bignum value))
127 (repr-ratio index (gethash 'ratio value))
129 (let ((hash-table (make-hash-table :test 'eql)))
130 (dotimes (i n-fixnums)
131 (setf (gethash (+ first-fixnum i) hash-table) i))
133 (setf (gethash 'bignum hash-table) (repr-bignum index)
134 (gethash 'ratio hash-table) (repr-ratio index))
138 (defun repr-bignum (index &optional (value nil value-p))
139 (let ((bignum (+ index 10000300020)))
144 (defun repr-ratio (index &optional (value nil value-p))
145 (let ((ratio (/ index (1+ index))))
150 (defun repr-single-float (index &optional (value nil value-p))
151 (let ((single-float (* 0.25 (float index) (1+ (float index)))))
153 (eql value single-float)
156 (defun repr-double-float (index &optional (value nil value-p))
157 (let ((double-float (+ 0.25d0 (1- index) (1+ (float index)))))
159 (eql value double-float)
162 (defun repr-simple-string (index &optional (value nil value-p))
163 (let ((length (mod index 14)))
166 (typep value 'simple-array)
167 (= (length value) length))
168 (make-string length))))
170 (defun repr-simple-vector (index &optional (value nil value-p))
171 (let ((length (mod (1+ index) 16)))
173 (and (simple-vector-p value)
174 (= (array-dimension value 0) length))
175 (make-array length))))
177 (defun repr-complex-vector (index &optional (value nil value-p))
178 (let* ((size (mod (* 5 index) 13))
179 (length (floor size 3)))
182 (not (typep value 'simple-array))
183 (= (array-dimension value 0) size)
184 (= (length value) length))
185 (make-array size :fill-pointer length))))
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)))))
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)))))
198 (eql value base-char)
202 (vector #'repr-fixnum
205 #'repr-eql-hash-table
207 #'repr-equal-hash-table
208 #'repr-equalp-hash-table
215 #'repr-complex-single-float
216 #'repr-complex-double-float
221 #'repr-simple-bit-vector
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
235 #'repr-complex-vector
238 ;; TO DO: #'repr-funcallable-instance
239 ;; TO DO: #'repr-byte-code-function
240 ;; TO DO: #'repr-byte-code-closure
245 ;; TO DO? #'repr-unbound-marker
246 ;; TO DO? #'repr-weak-pointer
247 ;; TO DO? #'repr-instance-header
248 ;; TO DO? #'repr-fdefn