Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

96 lines (72 sloc) 3.161 kb
(in-package #:storage)
;;; conses
(defvar *test-file* #p"/tmp/test.db")
(defun save-test (type amount &key object-size)
(with-writing-packages
(let ((object (create-test-object type :object-size object-size)))
(with-io-file (stream *test-file* :direction :output)
(write-object amount stream)
(loop repeat amount
do (write-object object stream))))))
(defun gc ()
#+sbcl (sb-ext:gc :full t)
#+ccl (progn (ccl:set-lisp-heap-gc-threshold (* 1024 1024 64))
(ccl:gc)))
(defmacro time-with-gc (&body body)
`(progn (gc)
(time (progn ,@body))))
(defun load-test ()
(with-reading-packages
(with-io-file (stream *test-file*)
(time-with-gc
(loop repeat (read-next-object stream)
do (read-next-object stream))))))
(defun identity-test (x &optional (mode :both))
(with-writing-packages
(when (member mode '(:both :write))
(with-io-file (stream *test-file* :direction :output)
(write-object x stream))))
(with-reading-packages
(when (member mode '(:both :read))
(with-io-file (stream *test-file*)
(read-next-object stream)))))
(defgeneric create-test-object (type &key &allow-other-keys))
(defmethod create-test-object ((type (eql 'cons)) &key object-size)
(make-list (or object-size 10000) :initial-element nil))
(defmethod create-test-object ((type (eql 'fixnum)) &key)
-1)
(defmethod create-test-object ((type (eql 'bignum)) &key)
(1+ most-positive-fixnum))
(defmethod create-test-object ((type (eql 'string)) &key object-size)
(make-string (or object-size 10000)))
(defmethod create-test-object ((type (eql 'simple-base-string)) &key)
#.(coerce "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
'simple-base-string))
(defmethod create-test-object ((type (eql 'ascii-string)) &key)
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
(defmethod create-test-object ((type (eql 'multibyte-string)) &key)
"АБВГДΑΒΓΔΕΖΗΘΙΚΛαβаб广州话日本語ภาษาไทย한국어")
(defmethod create-test-object ((type (eql 'hash-table)) &key)
(load-time-value (make-hash-table :test 'equal :size 500)))
(defmethod create-test-object ((type (eql 'complex-vector)) &key)
(load-time-value (make-array 10 :adjustable nil :fill-pointer 5)))
(defmethod create-test-object ((type (eql 'complex-array)) &key)
(load-time-value (make-array '(10 10 10) :adjustable t)))
(defmethod create-test-object ((type (eql 'fixnum-ratio)) &key)
1/3)
(defmethod create-test-object ((type (eql 'bignum-ratio)) &key)
2333333331232/2333333331231)
(defmethod create-test-object ((type (eql 'single-float)) &key)
1s0)
(defmethod create-test-object ((type (eql 'double-float)) &key)
-1d0)
(defun class-preallocation-test (storage)
(loop for class in (storage-data storage)
for length = (length (objects-of-class class))
when (plusp length)
collect (cons class length) into info
and
sum length into array-length
finally
(preallocate-objects (setf *indexes* (make-array array-length))
info)))
Jump to Line
Something went wrong with that request. Please try again.