(in-package :kira)
(defconstant +object-cache-size+ 10000 "Initial size for OBJECT-CACHE of OBJECT-DATABASE.")
(defconstant +object-buffer-size+ 32768 "Initial space (in octets) for objects in COMMIT.")
(defconstant +meta-object-id+ 0 "This object must exist. See ENSURE-META-OBJECT.")
(defclass object-database ()
((directory :accessor object-database-directory)
(object-cache :reader object-cache :initform (make-hash-table :weak :value :size +object-cache-size+))
(dirty-objects :reader dirty-objects :initform (make-buffer (truncate +object-cache-size+ 20) t))
(object-buffer :reader object-buffer :initform (make-buffer +object-buffer-size+))
(object-lock :reader object-lock :initform (make-lock 'object))
(object-data :reader object-data)
(object-index :reader object-index)
(last-object-id :accessor last-object-id)
meta-object))
(defmethod print-object ((object-database object-database) stream)
(with-accessors ((directory object-database-directory)) object-database
(unless (slot-boundp object-database 'directory) (return-from print-object (call-next-method)))
(print-unreadable-object (object-database stream :type t :identity t) (prin1 directory stream))))
(defvar *object-database* (make-instance 'object-database))
(defstaticvar +slot-not-loaded+ (list "Slot Not Loaded"))
(defun memory-mapped-file (slot-name &optional (object-database *object-database*))
(let ((element-type (ecase slot-name (object-data 'octet) (object-index 'binary-word))))
(let ((pathname (case slot-name (object-data #p"objects.dat") (object-index #p"objects.idx"))))
(values (merge-pathnames pathname (object-database-directory object-database)) element-type))))
(defclass object ()
((slot-layout :accessor slot-layout)
(object-id :reader object-id :type fixnum)
(slot-area :initform nil :accessor slot-area)
(object-database :initform *object-database*
:accessor object-database)))
(set-dispatch-macro-character
#\# #\K
#'(lambda (stream sub-char object-id)
(assert (char-equal sub-char #\K))
(prog1 (if *read-suppress* nil (get-object object-id))
(when (eql (peek-char nil stream nil nil) #\/)
(progn (read-char stream) (read stream nil))))))
(defmethod print-object ((object object) stream)
(with-slots (object-database object-id) object
(if (and (slot-boundp object 'object-database) (slot-boundp object 'object-id))
(let ((dirty-object-p (position object (dirty-objects object-database))))
(format stream "#~DK/~S~:[~;*~]" object-id (type-of object) dirty-object-p))
(call-next-method))))
(defmethod slot-unbound ((class t) (object object) (slot-name (eql 'object-id)))
(let ((allocated-object-id (incf (last-object-id (object-database object)))))
(with-accessors ((object-cache object-cache)) (object-database object)
(setf (gethash allocated-object-id object-cache) object)
(setf (slot-value object 'object-id) allocated-object-id))))
(defun object-layout (object &optional (slot-layout (slot-layout object)))
"Return the list of persistent slot names for the OBJECT having SLOT-LAYOUT."
(if (symbolp slot-layout) (values (object-slots object)) (qcr slot-layout)))
(defun get-object (object-id)
(let* ((object-database *object-database*)
(object-cache (object-cache object-database)))
(with-lock-grabbed ((object-lock object-database))
(or (gethash object-id object-cache)
(multiple-value-bind (slot-layout slot-area) (load-object-record object-id)
(whereas ((class-name (if (symbolp slot-layout) slot-layout (qar slot-layout))))
(let ((instance (allocate-instance (find-class class-name))))
(setf (slot-value instance 'object-database) object-database)
(setf (slot-value instance 'slot-layout) slot-layout)
(setf (slot-value instance 'slot-area) slot-area)
(setf (gethash object-id object-cache) instance)
(setf (slot-value instance 'object-id) object-id)
(persistent-initialize instance))))))))
(defun persistent-initialize (instance)
(when (slot-area instance)
(dolist (slot-name (object-layout instance) instance)
(setf (slot-value instance slot-name) +slot-not-loaded+)))
(shared-initialize instance t))
(defmethod slot-missing :around ((class t) (object object) slot-name (operation (eql 'setf)) &optional new-value)
(when (and (eq new-value +slot-not-loaded+) (slot-area object)) (setq new-value (load-slot object slot-name)))
(call-next-method class object slot-name operation new-value))
(defun remap-file (slot-name)
(multiple-value-bind (pathname element-type) (memory-mapped-file slot-name)
(setf (slot-value *object-database* slot-name) (mmap pathname element-type))))
(defmacro with-memory-mapped-file ((stream &rest open-arguments) &body body)
`(call-with-memory-mapped-file #'(lambda (,stream) ,@body) ,@open-arguments))
(defun open-memory-mapped-file (slot-name &optional if-exists)
(multiple-value-bind (pathname element-type) (memory-mapped-file slot-name)
(open pathname :direction :io :if-exists if-exists :element-type element-type)))
(defun call-with-memory-mapped-file (function slot-name &optional if-exists)
(with-open-stream (stream (open-memory-mapped-file slot-name if-exists))
(let ((initial-length (if stream (file-length stream) 0)))
(unwind-protect (funcall function stream)
(when stream
(let ((new-length (require-type (file-length stream) 'array-index)))
(locally (declare (type array-index initial-length new-length))
(unless (and (plusp initial-length) (= new-length initial-length))
(incf new-length (if (eq slot-name 'object-data) 524288 2048))
(stream-length stream new-length)
(remap-file slot-name)))))))))
(defun ensure-memory-mapped-file (slot-name creator)
(let ((file-exists-p (probe-file (memory-mapped-file slot-name))))
(if file-exists-p (remap-file slot-name) (funcall creator))))
(defun binary-symbol-sequence (cached-symbol)
(orf (get cached-symbol 'binary-symbol-sequence)
(with-output-to-vector
(stream nil :external-format +binary-external-format+)
(write-binary-object cached-symbol stream))))
(defun make-data-file ()
(with-memory-mapped-file (data-output 'object-data :error)
(write-sequence (binary-symbol-sequence 'data) data-output)
(write-sequence (binary-symbol-sequence 'free) data-output)))
(defun open-database (pathname)
(setq *default-external-format* +binary-external-format+)
(setq pathname (ensure-directory-pathname pathname))
(prog1 (setq *object-database* (make-instance 'object-database))
(setf (object-database-directory *object-database*) pathname)
(when (obsolete-object-index-p) (drop-file 'object-index))
(ensure-memory-mapped-file 'object-data #'make-data-file)
(ensure-memory-mapped-file 'object-index #'update-object-index)))
(defun release-memory-mapping (slot-name)
(when (slot-boundp *object-database* slot-name)
(munmap (slot-value *object-database* slot-name))
(slot-makunbound *object-database* slot-name)))
(defun close-database (&optional (*object-database* *object-database*))
(mapc #'release-memory-mapping '(object-data object-index))
(reset-buffer (dirty-objects *object-database*))
(slot-makunbound *object-database* 'meta-object)
(slot-makunbound *object-database* 'last-object-id)
(if (plusp (hash-table-count (object-cache *object-database*)))
(progn (clrhash (object-cache *object-database*)) t)
nil))
(defun object-pointer (object-id &aux (object-index (object-index *object-database*)))
(if (< object-id (length object-index)) (aref object-index object-id) 0))
(defun load-object-record (object-id)
(let ((pointer (object-pointer object-id)))
(when (eql pointer 0) (return-from load-object-record))
(let ((object-data (object-data *object-database*)))
(multiple-value-bind (end tag chunk-offset) (skip-binary-object object-data pointer)
(unless (eql tag +object-record-tag+) (error "Bad object record: ~D." object-id))
(with-binary-chunk-iterator (get-object-record-part) (object-data chunk-offset end)
(let ((record-id (get-object-record-part t)) (slot-layout (get-object-record-part t)))
(unless (eql record-id object-id) (error "Object record ID mismatch: ~D." object-id))
(values slot-layout (get-binary-octet-vector object-data chunk-offset end))))))))
(defun free-pointer (object-database)
(let* ((object-data (object-data object-database))
(meta-object-pointer (object-pointer +meta-object-id+))
(free-pointer (skip-binary-object object-data meta-object-pointer)))
(unless (marker= object-data free-pointer 'free)
(error "Expected free marker at ~D." free-pointer))
(values free-pointer meta-object-pointer)))
(defun commit (&optional (object-database *object-database*))
(with-lock-grabbed ((object-lock object-database))
(when (plusp (length (dirty-objects object-database)))
(let ((*object-database* object-database)
(dirty-objects (dirty-objects object-database))
(meta-object (meta-object object-database))
(free-marker (binary-symbol-sequence 'free))
(object-buffer (reset-buffer (object-buffer object-database))))
(multiple-value-bind (free-pointer predecessor) (free-pointer object-database)
(with-output-to-vector (stream object-buffer :external-format +binary-external-format+)
(loop initially (setf (qbr meta-object) (unless (eql predecessor 0) predecessor))
with object for counter fixnum upfrom 0 while (< counter (length dirty-objects))
unless (eql (object-id (setq object (aref dirty-objects counter))) +meta-object-id+)
do (write-object-record object stream))
(setf (qar meta-object) (get-local-time))
(write-object-record meta-object stream))
(with-memory-mapped-file
(data-output 'object-data :overwrite)
(file-position data-output free-pointer)
(write-sequence object-buffer data-output)
(write-sequence free-marker data-output)
(finish-output data-output))
(update-object-index free-pointer :overwrite)
(map nil #'reload-object-record dirty-objects)
(reload-object-record meta-object)
(prog1 t (reset-buffer dirty-objects)))))))
(defun reload-object-record (object &aux (object-id (object-id object)))
(multiple-value-bind (slot-layout slot-area) (load-object-record object-id)
(unless slot-area (error "Couldn't load object record: ~D." object-id))
(setf (slot-area object) slot-area (slot-layout object) slot-layout)))
(defun upgraded-slot-layout (object &aux (slot-layout (slot-layout object)))
(cond ((and (symbolp slot-layout) (eq slot-layout (type-of object))) slot-layout)
(t (let ((class-name (type-of object)) (slot-names (object-slots object)))
(if (and (typep slot-layout 'quad)
(eq (qar slot-layout) class-name)
(equal (qcr slot-layout) slot-names))
slot-layout
(let ((*object-database* (object-database object)))
(ensure-slot-layout class-name slot-names)))))))
(defun write-object-record (object stream)
(with-binary-chunk (stream +object-record-tag+)
(write-binary-object (object-id object) stream)
(let ((new-layout (upgraded-slot-layout object))
(old-layout-list (object-layout object))
(slot-area (slot-area object)))
(write-binary-object new-layout stream)
(dolist (slot-name (object-layout object new-layout))
(prog ((slot-value (slot-value object slot-name)))
(when (eq slot-value +slot-not-loaded+)
(whereas ((offset (find-slot slot-name slot-area old-layout-list)))
(copy-binary-object slot-area offset stream) (return t))
(setq slot-value (initialize-slot object slot-name)))
(write-binary-object slot-value stream))))))
(defmethod slot-unbound ((class t) (object-database object-database) (slot-name (eql 'last-object-id)))
(loop with object-index = (object-index object-database) with last-object-id fixnum = (length object-index)
do (decf last-object-id) while (and (plusp last-object-id) (zerop (aref object-index last-object-id)))
finally (return (setf (slot-value object-database 'last-object-id) (max 0 last-object-id)))))
(defun find-slot (slot-name slot-area slot-layout-list)
(loop with end of-type fixnum = (if slot-area (length slot-area) (return-from find-slot nil))
for offset fixnum = 0 then (skip-binary-object slot-area offset) while slot-layout-list
while (< offset end) when (eq (pop slot-layout-list) slot-name) return offset))
(defun load-slot (instance slot-name)
(let* ((slot-area (slot-area instance))
(slot-layout-list (object-layout instance))
(*object-database* (object-database instance))
(offset (find-slot slot-name slot-area slot-layout-list)))
(cond ((eq offset nil) (initialize-slot instance slot-name))
(t (nth-value 0 (get-binary-object slot-area offset))))))
(defgeneric initialize-slot (instance slot-name)
(:method ((instance object) (slot-name symbol))
(cond ((slot-exists-p instance slot-name)
(slot-makunbound instance slot-name)
(let ((slot-name-list (list slot-name)))
(shared-initialize instance slot-name-list))
(slot-value instance slot-name)))))
(defun reset-object (instance)
(if (typep instance 'quad)
(let ((value (if (slot-area instance) +slot-not-loaded+ nil)))
(setf (slot-value instance 'qar) value (slot-value instance 'qbr) value
(slot-value instance 'qcr) value (slot-value instance 'qdr) value))
(multiple-value-bind (persistent-slots transient-slots) (object-slots instance)
(loop for slot-name in persistent-slots do (slot-makunbound instance slot-name))
(loop for slot-name in transient-slots do (slot-makunbound instance slot-name))
(persistent-initialize instance))))
(defun rollback (&optional (object-database *object-database*))
(let ((dirty-objects (dirty-objects object-database)))
(with-lock-grabbed ((object-lock object-database))
(slot-makunbound object-database 'last-object-id)
(map nil #'reset-object dirty-objects)
(reset-object (meta-object object-database))
(prog1 t (reset-buffer dirty-objects)))))
(defun mark-dirty-object (object)
(let ((object-database (object-database object)))
(with-lock-grabbed ((object-lock object-database))
(with-slots (dirty-objects) object-database
(loop with vector = (array-data-and-offset dirty-objects)
for i of-type array-index from 0 below (length dirty-objects)
when (eq (svref vector i) object) do (return-from mark-dirty-object)
finally (vector-push-extend object dirty-objects) (return object))))))
(defmethod initialize-instance :after ((instance object) &key)
"Mark the just-created instance." (mark-dirty-object instance))
(defun find-quad (key head)
(loop for quad = head then (qdr quad)
unless (typep quad 'quad) return nil
when (eq (qar quad) key) return quad))
(defun find-slot-layout (class-name slot-names &aux (meta-object (meta-object)))
(loop with head-layout = (qcr meta-object) as slot-layout = (find-quad class-name head-layout)
while slot-layout do (when (equal (qcr slot-layout) slot-names) (return slot-layout))
do (setq head-layout (qdr slot-layout))))
(defun ensure-slot-layout (class-name slot-names)
(or (find-slot-layout class-name slot-names)
(let ((meta-object (meta-object *object-database*)))
(setf (qcr meta-object) (make-instance 'quad
:qar class-name
:qcr slot-names
:qdr (qcr meta-object))))))
(defmethod slot-unbound ((class t) (instance object) (slot-name (eql 'slot-layout)))
(let ((class-name (class-name class)) (*object-database* (object-database instance)))
(setf (slot-layout instance) (ensure-slot-layout class-name (object-slots instance)))))
(eval-always
(defun get-object-slots-expansion (class-name direct-persistent-slots direct-transient-slots)
`(defmethod object-slots ((instance ,class-name) &aux persistent-slots transient-slots)
(setf (values persistent-slots transient-slots) (if (next-method-p) (call-next-method)))
(loop for slot-name in ',(append direct-persistent-slots direct-transient-slots)
do (removef slot-name persistent-slots) (removef slot-name transient-slots)
finally (return (values (append persistent-slots ',direct-persistent-slots)
(append transient-slots ',direct-transient-slots)))))))
(defun persistent-slot-value (instance slot-name)
(let ((slot-value (slot-value instance slot-name)))
(prog1 slot-value
(when (eq slot-value +slot-not-loaded+)
(return-from persistent-slot-value
(setf (slot-value instance slot-name)
(load-slot instance slot-name)))))))
(defun (setf persistent-slot-value) (new-value instance slot-name)
(let ((result (setf (slot-value instance slot-name) new-value)))
(progn (mark-dirty-object instance) result)))
(defun normalize-slot-entry (slot-entry)
(cond ((listp slot-entry) slot-entry)
(t (list slot-entry slot-entry))))
(defmacro with-slots* ((&rest slot-entries) instance-form &body body)
(loop with slot-entries = (mapcar #'normalize-slot-entry slot-entries)
with instance of-type symbol = (gensym #"instance")
for (variable-name slot-name) in slot-entries
for slot-value-form = `(persistent-slot-value ,instance ',slot-name)
collect `(,variable-name ,slot-value-form) into symbol-macro-definitions
finally (return `(let ((,instance ,instance-form))
(symbol-macrolet (,.symbol-macro-definitions)
,@body)))))
(eval-always
(defun parse-slot-options (class-name slot-name slot-options)
(collecting (method-definitions abridged-slot-options)
(loop initially (assert (evenp (length slot-options)))
with option-name and option-value
until (endp slot-options)
do (setq option-name (pop slot-options))
(setq option-value (pop slot-options))
(let (reader-name writer-name)
(case option-name
(:accessor
(setq reader-name option-value)
(setq writer-name `(setf ,option-value)))
(:reader (setq reader-name option-value))
(:writer (setq writer-name option-value)))
(when reader-name
(collect
`(defmethod ,reader-name ((instance ,class-name))
(persistent-slot-value instance ',slot-name))
:into method-definitions))
(when writer-name
(collect
`(defmethod ,writer-name (new-value (instance ,class-name))
(setf (persistent-slot-value instance ',slot-name) new-value))
:into method-definitions))
(unless (or reader-name writer-name)
(collect option-name :into abridged-slot-options)
(collect option-value :into abridged-slot-options)))
finally (return (values method-definitions abridged-slot-options))))))
(defmacro define-persistent-class (class-name superclass-names slot-specifiers . class-options)
(collecting (method-definition-expansions new-slot-specifiers persistent-slots transient-slots)
(loop for (slot-name . slot-options) in slot-specifiers
for allocation = (getf slot-options :allocation)
do (when (member slot-name '(slot-layout object-id slot-area object-database))
(unless (eq class-name 'quad) (error "Special slot: ~S." slot-name)))
if (and allocation (not (eq allocation :persistent)))
do (collect slot-name :into transient-slots)
(collect `(,slot-name ,@slot-options)
:into new-slot-specifiers)
else
do (sansf slot-options :allocation)
(collect slot-name :into persistent-slots)
(multiple-value-bind (method-definitions new-slot-options)
(parse-slot-options class-name slot-name slot-options)
(collect `(progn ,.method-definitions) :into method-definition-expansions)
(collect `(,slot-name ,.new-slot-options) :into new-slot-specifiers)))
(unless (member 'object superclass-names) (appendf superclass-names '(object)))
`(progn (defclass ,class-name ,superclass-names ,new-slot-specifiers ,@class-options)
,(get-object-slots-expansion class-name persistent-slots transient-slots)
,.method-definition-expansions (find-class ',class-name))))
(define-persistent-class quad ()
((slot-layout :initform 'quad :allocation :instance)
(qar :initform nil :initarg :qar :accessor qar)
(qbr :initform nil :initarg :qbr :accessor qbr)
(qcr :initform nil :initarg :qcr :accessor qcr)
(qdr :initform nil :initarg :qdr :accessor qdr)))
(defmethod slot-unbound ((class t) object-database (slot-name (eql 'meta-object)))
(setf (slot-value object-database 'meta-object) (ensure-meta-object object-database)))
(defun ensure-meta-object (*object-database*)
(with-lock-grabbed ((object-lock *object-database*))
(with-slots (object-cache) *object-database*
(or (get-object +meta-object-id+)
(let ((meta-object (make-instance 'quad)))
(setf (gethash +meta-object-id+ object-cache) meta-object)
(setf (slot-value meta-object 'object-id) +meta-object-id+)
meta-object)))))
(defun meta-object (&optional (object-database *object-database*))
(with-slots (meta-object) object-database meta-object))
(defun get-root (name &optional default)
(let ((r (find-quad name (qdr (meta-object)))))
(if r (qcr r) default)))
(defun (setf get-root) (value name &optional default)
(declare (ignore default))
(let ((r (find-quad name (qdr (meta-object)))))
(cond (r (setf (qcr r) value))
(t (qcr (setf (qdr (meta-object))
(make-instance
'quad
:qar name :qcr value
:qdr (qdr (meta-object)))))))))