Really restore clisp cross-compilation.
[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 random-element (seq)
33   (elt seq (random (length seq))))
34
35 (defun repr (i)
36   (declare (type fixnum i))
37   (let ((result (svref *reprs* (mod i (length *reprs*)))))
38     #+nil (/show "REPRESENT" i result)
39     result))
40
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)
49       #+nil (/show j-pass)
50       (if (plusp remaining-passes-to-full-gc)
51           (decf remaining-passes-to-full-gc)
52           (progn
53             #+nil (/show "doing GC :FULL T")
54             (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
59              ;; for a long time.)
60              (i-generation (isqrt (random (expt (length generations) 2))))
61              (generation-i (aref generations i-generation)))
62         #+nil (/show i-generation generation-i)
63         (when generation-i
64           (assert-generation i-generation generation-i))
65         (when (or (null generation-i)
66                   (plusp (random 3)))
67           #+nil (/show "allocating or reallocating" i-generation)
68           (setf generation-i
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)
74               generation-i))))
75   (format t "~&done with STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size))
76
77 (defvar *expected*)
78 (defvar *got*)
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
92                  index-of-generation
93                  *expected*
94                  repr
95                  *got*))))))
96
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))))
103
104 (defun repr-fixnum (index &optional (value nil value-p))
105   (let ((fixnum (the fixnum (+ index 101))))
106     (if value-p
107         (eql fixnum value)
108         fixnum)))
109
110 (defun repr-function (index &optional (value nil value-p))
111   (let ((fixnum (mod (+ index 2) 3)))
112     (if value-p
113         (eql fixnum (funcall value))
114         (ecase fixnum
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)
121
122 (defstruct repr-instance slot)
123 (defun repr-instance (index &optional (value nil value-p))
124   (let ((fixnum (mod (* index 3) 4)))
125     (if value-p
126         (and (typep value 'repr-instance)
127              (eql (repr-instance-slot value) fixnum))
128         (make-repr-instance :slot fixnum))))
129
130 (defun repr-eql-hash-table (index &optional (value nil value-p))
131   (let ((first-fixnum (mod (* index 31) 9))
132         (n-fixnums 5))
133     (if value-p
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)
138                  (return nil)))
139              #|
140              (repr-bignum index (gethash 'bignum value))
141              (repr-ratio index (gethash 'ratio value))
142              |#)
143         (let ((hash-table (make-hash-table :test 'eql)))
144           (dotimes (i n-fixnums)
145             (setf (gethash (+ first-fixnum i) hash-table) i))
146           #|
147           (setf (gethash 'bignum hash-table) (repr-bignum index)
148                 (gethash 'ratio hash-table) (repr-ratio index))
149           |#
150           hash-table))))
151
152 (defun repr-weak-key-hash-table (index &optional (value nil value-p))
153   (let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
154         (n 5))
155     (if value-p
156         (and (hash-table-p value)
157              (<= (hash-table-count value) n)
158              (dotimes (i n t)
159                (let ((x (gethash (+ i first) value)))
160                  (unless (or (null x) (= x i))
161                    (return nil)))))
162         (let ((hash-table (make-hash-table
163                            :weakness :key
164                            :test (random-element '(eq eql equal equalp)))))
165           (dotimes (i n)
166             (setf (gethash (+ first i) hash-table) i))
167           hash-table))))
168
169 (defun repr-bignum (index &optional (value nil value-p))
170   (let ((bignum (+ index 10000300020)))
171     (if value-p
172         (eql value bignum)
173         bignum)))
174
175 (defun repr-ratio (index &optional (value nil value-p))
176   (let ((ratio (/ index (1+ index))))
177     (if value-p
178         (eql value ratio)
179         ratio)))
180
181 (defun repr-single-float (index &optional (value nil value-p))
182   (let ((single-float (* 0.25 (float index) (1+ (float index)))))
183     (if value-p
184         (eql value single-float)
185         single-float)))
186
187 (defun repr-double-float (index &optional (value nil value-p))
188   (let ((double-float (+ 0.25d0 (1- index) (1+ (float index)))))
189     (if value-p
190         (eql value double-float)
191         double-float)))
192
193 (defun repr-simple-string (index &optional (value nil value-p))
194   (let ((length (mod index 14)))
195     (if value-p
196         (and (stringp value)
197              (typep value 'simple-array)
198              (= (length value) length))
199         (make-string length))))
200
201 (defun repr-simple-vector (index &optional (value nil value-p))
202   (let ((length (mod (1+ index) 16)))
203     (if value-p
204         (and (simple-vector-p value)
205              (= (array-dimension value 0) length))
206         (make-array length))))
207
208 (defun repr-complex-vector (index &optional (value nil value-p))
209   (let* ((size (mod (* 5 index) 13))
210          (length (floor size 3)))
211     (if value-p
212         (and (vectorp value)
213              (not (typep value 'simple-array))
214              (= (array-dimension value 0) size)
215              (= (length value) length))
216         (make-array size :fill-pointer length))))
217
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)))))
221     (if value-p
222         (eq value symbol)
223         symbol)))
224
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)))))
228     (if value-p
229         (eql value base-char)
230         base-char)))
231
232 (setf *reprs*
233       (vector #'repr-fixnum
234               #'repr-function
235               #'repr-instance
236               #'repr-eql-hash-table
237               #'repr-weak-key-hash-table
238 #|
239               #'repr-equal-hash-table
240               #'repr-equalp-hash-table
241 |#
242               #'repr-bignum
243               #'repr-ratio
244               #'repr-single-float
245               #'repr-double-float
246 #|
247               #'repr-complex-single-float
248               #'repr-complex-double-float
249               #'repr-simple-array
250 |#
251               #'repr-simple-string
252 #|
253               #'repr-simple-bit-vector
254 |#
255               #'repr-simple-vector
256 #|
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
266 |#
267               #'repr-complex-vector
268 #|
269               #'repr-complex-array
270               ;; TO DO: #'repr-funcallable-instance
271 |#
272               #'repr-symbol
273               #'repr-base-char
274               ;; TO DO: #'repr-sap
275               ;; TO DO? #'repr-unbound-marker
276               ;; TO DO? #'repr-weak-pointer
277               ;; TO DO? #'repr-instance-header
278               ;; TO DO? #'repr-fdefn
279               ))