;;;; 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.
(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*)))))
(defun stress-gc (n-passes &optional (size 3000))
(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))))
+ ;; 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*)
(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 #~W 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)
(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
+ ))
projects / sbcl.git / blobdiff