Commit ca92680d authored by Stas Boukarev's avatar Stas Boukarev
Browse files

Don't write relations at read-time, store them on disk.

Add a specialized type `list-of-objects'.
parent c38add28
......@@ -14,7 +14,9 @@
do (write-object object stream)))))
(defun gc ()
#+sbcl (sb-ext:gc :full t))
#+sbcl (sb-ext:gc :full t)
#+ccl (progn (ccl:set-lisp-heap-gc-threshold (* 1024 1024 64))
(defmacro time-with-gc (&body body)
`(progn (gc)
......@@ -9,7 +9,8 @@
string null symbol
fixnum bignum ratio)))
fixnum bignum ratio
(declaim (type simple-vector *codes*))
......@@ -303,22 +304,47 @@
(defmethod object-size ((list cons))
(let ((count (+ 1 1))) ;; type + +end+
(mapc (lambda (x)
(incf count (object-size x)))
(cond ((list-of-objects-p list)
(incf count (+ (* (length list)
(1- +sequence-length+)))) ;; sans +end+
(mapc (lambda (x)
(incf count (object-size x)))
(defmethod write-object ((list cons) stream)
(write-n-bytes #.(type-code 'cons) 1 stream)
(dolist (item list)
(write-object item stream))
(write-n-bytes +end+ 1 stream))
(cond ((list-of-objects-p list)
(write-list-of-objects list stream))
(write-n-bytes #.(type-code 'cons) 1 stream)
(dolist (item list)
(write-object item stream))
(write-n-bytes +end+ 1 stream))))
(defreader cons (stream)
(loop for code = (read-n-bytes 1 stream)
until (= code +end+)
collect (call-reader code stream)))
;;; list-of-objects
(defun list-of-objects-p (list)
(loop for i in list
always (typep i 'standard-object)))
(defun write-list-of-objects (list stream)
(write-n-bytes #.(type-code 'list-of-objects) 1 stream)
(write-n-bytes (length list) +sequence-length+ stream)
(dolist (object list)
(write-n-bytes (id object) +id-length+ stream)))
(defreader list-of-objects (stream)
(loop repeat (read-n-bytes +sequence-length+ stream)
for id = (read-n-bytes +id-length+ stream)
collect (get-instance id)))
;;; storable-class
(defmethod object-size ((class storable-class))
......@@ -500,8 +526,7 @@
(let ((*storage* storage)
(*indexes* *indexes*))
(read-file (or file (storage-file *storage*)))
(read-file (or file (storage-file *storage*)))))
(defun save-data (storage &optional file)
(let ((*storage* storage))
......@@ -101,34 +101,6 @@
(interlink-slots object
(standard-instance-access object loc)
(defun interlink-all-objects-first-time ()
(lambda (class objects)
(declare (ignore class))
(loop for object in objects
do (interlink-objects-first-time object)))))
(defun link-slot-first-time (relation object target-object)
(if (and (consp relation)
(eql (car relation) :slot))
(push object (slot-value target-object (cadr relation)))
(push object (getf (relations target-object) relation))))
(defun interlink-slots-first-time (object slot-value relation)
(do-maybe-list (target slot-value)
(when (typep target 'identifiable)
(link-slot-first-time relation object target))))
(defun interlink-objects-first-time (object)
(loop for (loc . relation) in (class-relations (class-of object))
(interlink-slots-first-time object
(standard-instance-access object loc)
(defun clear-cashes ()
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment