X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fstress-gc.lisp;h=415e6cb8d6d17a30058c338f2dbfb2dc0bb3e761;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=7fff862395c3ac8453a78b84b9ca72e1a1b38df2;hpb=667ec9d494530079bef28e8589dd0d3274b935ec;p=sbcl.git diff --git a/tests/stress-gc.lisp b/tests/stress-gc.lisp index 7fff862..415e6cb 100644 --- a/tests/stress-gc.lisp +++ b/tests/stress-gc.lisp @@ -6,7 +6,7 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. @@ -29,6 +29,9 @@ (defvar *reprs*) (declaim (type simple-vector *reprs*)) +(defun random-element (seq) + (elt seq (random (length seq)))) + (defun repr (i) (declare (type fixnum i)) (let ((result (svref *reprs* (mod i (length *reprs*))))) @@ -36,40 +39,40 @@ result)) (defun stress-gc (n-passes &optional (size 3000)) - (format t "~&beginning STRESS-GC N-PASSES=~D SIZE=~D~%" n-passes size) + (format t "~&beginning STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size) (let ((generations (make-array (isqrt size) :initial-element nil)) - ;; We allocate on the order of MOST-POSITIVE-FIXNUM things - ;; before doing a full GC. - (max-passes-to-full-gc (floor most-positive-fixnum size)) - (remaining-passes-to-full-gc 0)) + ;; We allocate on the order of MOST-POSITIVE-FIXNUM things + ;; before doing a full GC. + (max-passes-to-full-gc (floor most-positive-fixnum size)) + (remaining-passes-to-full-gc 0)) (dotimes (j-pass n-passes) #+nil (/show j-pass) (if (plusp remaining-passes-to-full-gc) - (decf remaining-passes-to-full-gc) - (progn - #+nil (/show "doing GC :FULL T") - (gc :full t) - (setf remaining-passes-to-full-gc (random max-passes-to-full-gc)))) + (decf remaining-passes-to-full-gc) + (progn + #+nil (/show "doing GC :FULL T") + (gc :full t) + (setf remaining-passes-to-full-gc (random max-passes-to-full-gc)))) (let* (;; (The (ISQRT (RANDOM (EXPT .. 2))) distribution here is - ;; intended to give a distribution of lifetimes of memory - ;; usage, with low-indexed generations tending to live - ;; for a long time.) - (i-generation (isqrt (random (expt (length generations) 2)))) - (generation-i (aref generations i-generation))) - #+nil (/show i-generation generation-i) - (when generation-i - (assert-generation i-generation generation-i)) - (when (or (null generation-i) - (plusp (random 3))) - #+nil (/show "allocating or reallocating" i-generation) - (setf generation-i - (make-array (random (1+ size))))) - (assign-generation i-generation generation-i) - (when (plusp (random 3)) - (assert-generation i-generation generation-i)) - (setf (aref generations i-generation) - generation-i)))) - (format t "~&done with STRESS-GC N-PASSES=~D SIZE=~D~%" n-passes size)) + ;; intended to give a distribution of lifetimes of memory + ;; usage, with low-indexed generations tending to live + ;; for a long time.) + (i-generation (isqrt (random (expt (length generations) 2)))) + (generation-i (aref generations i-generation))) + #+nil (/show i-generation generation-i) + (when generation-i + (assert-generation i-generation generation-i)) + (when (or (null generation-i) + (plusp (random 3))) + #+nil (/show "allocating or reallocating" i-generation) + (setf generation-i + (make-array (random (1+ size))))) + (assign-generation i-generation generation-i) + (when (plusp (random 3)) + (assert-generation i-generation generation-i)) + (setf (aref generations i-generation) + generation-i)))) + (format t "~&done with STRESS-GC N-PASSES=~W SIZE=~W~%" n-passes size)) (defvar *expected*) (defvar *got*) @@ -77,41 +80,41 @@ (dotimes (index-within-generation (length generation)) #+nil (/show "assert-generation" index-of-generation index-within-generation) (let ((element-of-generation (aref generation index-within-generation)) - (repr (repr (+ index-within-generation index-of-generation)))) + (repr (repr (+ index-within-generation index-of-generation)))) (unless (funcall repr index-within-generation element-of-generation) - ;; KLUDGE: We bind these to special variables for the - ;; convenience of the debugger, which ca. SBCL 0.6.6 is too - ;; wimpy to inspect lexical variables. - (let ((*expected* (funcall repr index-within-generation)) - (*got* element-of-generation)) - (error "bad element #~D in generation #~D:~% expected ~S~% from ~S,~% got ~S" - index-within-generation - index-of-generation - *expected* - repr - *got*)))))) + ;; KLUDGE: We bind these to special variables for the + ;; convenience of the debugger, which ca. SBCL 0.6.6 is too + ;; wimpy to inspect lexical variables. + (let ((*expected* (funcall repr index-within-generation)) + (*got* element-of-generation)) + (error "bad element #~W in generation #~D:~% expected ~S~% from ~S,~% got ~S" + index-within-generation + index-of-generation + *expected* + repr + *got*)))))) (defun assign-generation (index-of-generation generation) (dotimes (index-within-generation (length generation)) #+nil (/show "assert-generation" index-of-generation index-within-generation) (setf (aref generation index-within-generation) - (funcall (repr (+ index-within-generation index-of-generation)) - index-within-generation)))) - + (funcall (repr (+ index-within-generation index-of-generation)) + index-within-generation)))) + (defun repr-fixnum (index &optional (value nil value-p)) (let ((fixnum (the fixnum (+ index 101)))) (if value-p - (eql fixnum value) - fixnum))) + (eql fixnum value) + fixnum))) (defun repr-function (index &optional (value nil value-p)) (let ((fixnum (mod (+ index 2) 3))) (if value-p - (eql fixnum (funcall value)) - (ecase fixnum - (0 #'repr-fixnum-zero) - (1 #'repr-fixnum-one) - (2 #'repr-fixnum-two))))) + (eql fixnum (funcall value)) + (ecase fixnum + (0 #'repr-fixnum-zero) + (1 #'repr-fixnum-one) + (2 #'repr-fixnum-two))))) (defun repr-fixnum-zero () 0) (defun repr-fixnum-one () 1) (defun repr-fixnum-two () 2) @@ -120,140 +123,157 @@ (defun repr-instance (index &optional (value nil value-p)) (let ((fixnum (mod (* index 3) 4))) (if value-p - (and (typep value 'repr-instance) - (eql (repr-instance-slot value) fixnum)) - (make-repr-instance :slot fixnum)))) + (and (typep value 'repr-instance) + (eql (repr-instance-slot value) fixnum)) + (make-repr-instance :slot fixnum)))) (defun repr-eql-hash-table (index &optional (value nil value-p)) (let ((first-fixnum (mod (* index 31) 9)) - (n-fixnums 5)) + (n-fixnums 5)) (if value-p - (and (hash-table-p value) - (= (hash-table-count value) n-fixnums) - (dotimes (i n-fixnums t) - (unless (= (gethash (+ i first-fixnum) value) i) - (return nil))) - #| - (repr-bignum index (gethash 'bignum value)) - (repr-ratio index (gethash 'ratio value)) + (and (hash-table-p value) + (= (hash-table-count value) n-fixnums) + (dotimes (i n-fixnums t) + (unless (= (gethash (+ i first-fixnum) value) i) + (return nil))) + #| + (repr-bignum index (gethash 'bignum value)) + (repr-ratio index (gethash 'ratio value)) |#) - (let ((hash-table (make-hash-table :test 'eql))) - (dotimes (i n-fixnums) - (setf (gethash (+ first-fixnum i) hash-table) i)) - #| - (setf (gethash 'bignum hash-table) (repr-bignum index) - (gethash 'ratio hash-table) (repr-ratio index)) + (let ((hash-table (make-hash-table :test 'eql))) + (dotimes (i n-fixnums) + (setf (gethash (+ first-fixnum i) hash-table) i)) + #| + (setf (gethash 'bignum hash-table) (repr-bignum index) + (gethash 'ratio hash-table) (repr-ratio index)) |# - hash-table)))) + hash-table)))) + +(defun repr-weak-key-hash-table (index &optional (value nil value-p)) + (let ((first (+ most-positive-fixnum (mod (* index 31) 9))) + (n 5)) + (if value-p + (and (hash-table-p value) + (<= (hash-table-count value) n) + (dotimes (i n t) + (let ((x (gethash (+ i first) value))) + (unless (or (null x) (= x i)) + (return nil))))) + (let ((hash-table (make-hash-table + :weakness :key + :test (random-element '(eq eql equal equalp))))) + (dotimes (i n) + (setf (gethash (+ first i) hash-table) i)) + hash-table)))) (defun repr-bignum (index &optional (value nil value-p)) (let ((bignum (+ index 10000300020))) (if value-p - (eql value bignum) - bignum))) + (eql value bignum) + bignum))) (defun repr-ratio (index &optional (value nil value-p)) (let ((ratio (/ index (1+ index)))) (if value-p - (eql value ratio) - ratio))) + (eql value ratio) + ratio))) (defun repr-single-float (index &optional (value nil value-p)) (let ((single-float (* 0.25 (float index) (1+ (float index))))) (if value-p - (eql value single-float) - single-float))) + (eql value single-float) + single-float))) (defun repr-double-float (index &optional (value nil value-p)) (let ((double-float (+ 0.25d0 (1- index) (1+ (float index))))) (if value-p - (eql value double-float) - double-float))) + (eql value double-float) + double-float))) (defun repr-simple-string (index &optional (value nil value-p)) (let ((length (mod index 14))) (if value-p - (and (stringp value) - (typep value 'simple-array) - (= (length value) length)) - (make-string length)))) + (and (stringp value) + (typep value 'simple-array) + (= (length value) length)) + (make-string length)))) (defun repr-simple-vector (index &optional (value nil value-p)) (let ((length (mod (1+ index) 16))) (if value-p - (and (simple-vector-p value) - (= (array-dimension value 0) length)) - (make-array length)))) + (and (simple-vector-p value) + (= (array-dimension value 0) length)) + (make-array length)))) (defun repr-complex-vector (index &optional (value nil value-p)) (let* ((size (mod (* 5 index) 13)) - (length (floor size 3))) + (length (floor size 3))) (if value-p - (and (vectorp value) - (not (typep value 'simple-array)) - (= (array-dimension value 0) size) - (= (length value) length)) - (make-array size :fill-pointer length)))) + (and (vectorp value) + (not (typep value 'simple-array)) + (= (array-dimension value 0) size) + (= (length value) length)) + (make-array size :fill-pointer length)))) (defun repr-symbol (index &optional (value nil value-p)) (let* ((symbols #(zero one two three four)) - (symbol (aref symbols (mod index (length symbols))))) + (symbol (aref symbols (mod index (length symbols))))) (if value-p - (eq value symbol) - symbol))) + (eq value symbol) + symbol))) (defun repr-base-char (index &optional (value nil value-p)) (let* ((base-chars #(#\z #\o #\t #\t #\f #\f #\s #\s #\e)) - (base-char (aref base-chars (mod index (length base-chars))))) + (base-char (aref base-chars (mod index (length base-chars))))) (if value-p - (eql value base-char) - base-char))) + (eql value base-char) + base-char))) (setf *reprs* (vector #'repr-fixnum - #'repr-function - #'repr-instance - #'repr-eql-hash-table + #'repr-function + #'repr-instance + #'repr-eql-hash-table + #'repr-weak-key-hash-table #| - #'repr-equal-hash-table - #'repr-equalp-hash-table + #'repr-equal-hash-table + #'repr-equalp-hash-table |# - #'repr-bignum - #'repr-ratio - #'repr-single-float - #'repr-double-float + #'repr-bignum + #'repr-ratio + #'repr-single-float + #'repr-double-float #| - #'repr-complex-single-float - #'repr-complex-double-float - #'repr-simple-array + #'repr-complex-single-float + #'repr-complex-double-float + #'repr-simple-array |# - #'repr-simple-string + #'repr-simple-string #| - #'repr-simple-bit-vector + #'repr-simple-bit-vector |# - #'repr-simple-vector + #'repr-simple-vector #| - #'repr-simple-array-u2 - #'repr-simple-array-u4 - #'repr-simple-array-u8 - #'repr-simple-array-u16 - #'repr-simple-array-u32 - #'repr-simple-array-single-float - #'repr-simple-array-double-float - #'repr-complex-string - #'repr-complex-bit-vector + #'repr-simple-array-u2 + #'repr-simple-array-u4 + #'repr-simple-array-u8 + #'repr-simple-array-u16 + #'repr-simple-array-u32 + #'repr-simple-array-single-float + #'repr-simple-array-double-float + #'repr-complex-string + #'repr-complex-bit-vector |# - #'repr-complex-vector + #'repr-complex-vector #| - #'repr-complex-array - ;; TO DO: #'repr-funcallable-instance + #'repr-complex-array + ;; TO DO: #'repr-funcallable-instance |# - #'repr-symbol - #'repr-base-char - ;; TO DO: #'repr-sap - ;; TO DO? #'repr-unbound-marker - ;; TO DO? #'repr-weak-pointer - ;; TO DO? #'repr-instance-header - ;; TO DO? #'repr-fdefn - )) - \ No newline at end of file + #'repr-symbol + #'repr-base-char + ;; TO DO: #'repr-sap + ;; TO DO? #'repr-unbound-marker + ;; TO DO? #'repr-weak-pointer + ;; TO DO? #'repr-instance-header + ;; TO DO? #'repr-fdefn + ))