0.7.8.42:
[sbcl.git] / 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