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 @@ ...@@ -14,7 +14,9 @@
do (write-object object stream))))) do (write-object object stream)))))
(defun gc () (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) (defmacro time-with-gc (&body body)
`(progn (gc) `(progn (gc)
...@@ -9,7 +9,8 @@ ...@@ -9,7 +9,8 @@
string null symbol string null symbol
storable-class storable-class
standard-object standard-object
fixnum bignum ratio))) fixnum bignum ratio
(declaim (type simple-vector *codes*)) (declaim (type simple-vector *codes*))
...@@ -303,22 +304,47 @@ ...@@ -303,22 +304,47 @@
(defmethod object-size ((list cons)) (defmethod object-size ((list cons))
(let ((count (+ 1 1))) ;; type + +end+ (let ((count (+ 1 1))) ;; type + +end+
(mapc (lambda (x) (cond ((list-of-objects-p list)
(incf count (object-size x))) (incf count (+ (* (length list)
list) +id-length+)
(1- +sequence-length+)))) ;; sans +end+
(mapc (lambda (x)
(incf count (object-size x)))
count)) count))
(defmethod write-object ((list cons) stream) (defmethod write-object ((list cons) stream)
(write-n-bytes #.(type-code 'cons) 1 stream) (cond ((list-of-objects-p list)
(dolist (item list) (write-list-of-objects list stream))
(write-object item stream)) (t
(write-n-bytes +end+ 1 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) (defreader cons (stream)
(loop for code = (read-n-bytes 1 stream) (loop for code = (read-n-bytes 1 stream)
until (= code +end+) until (= code +end+)
collect (call-reader code stream))) 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 ;;; storable-class
(defmethod object-size ((class storable-class)) (defmethod object-size ((class storable-class))
...@@ -500,8 +526,7 @@ ...@@ -500,8 +526,7 @@
(let ((*storage* storage) (let ((*storage* storage)
(*indexes* *indexes*)) (*indexes* *indexes*))
(clear-cashes) (clear-cashes)
(read-file (or file (storage-file *storage*))) (read-file (or file (storage-file *storage*)))))
(defun save-data (storage &optional file) (defun save-data (storage &optional file)
(let ((*storage* storage)) (let ((*storage* storage))
...@@ -101,34 +101,6 @@ ...@@ -101,34 +101,6 @@
(interlink-slots object (interlink-slots object
(standard-instance-access object loc) (standard-instance-access object loc)
relation))) relation)))
(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 () (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