Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4243
Added Files: classes-new.lisp serializer2-locks.lisp serializer3.lisp Log Message:
Adding missing files, some of these will go away later but I want to keep a record of my work to date. I really should have put this on a branch, but it got out of control before I realized how much rewiring I was doing!
-----------
--- /project/elephant/cvsroot/elephant/src/elephant/classes-new.lisp 2007/01/16 00:55:22 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/classes-new.lisp 2007/01/16 00:55:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; classes.lisp -- persistent objects via metaobjects ;;; ;;; Initial version 8/26/2004 by Andrew Blumberg ;;; ablumberg@common-lisp.net ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ablumberg@common-lisp.net blee@common-lisp.net ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT")
(defvar *debug-si* nil)
(defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid (sc *store-controller*)) "Sets the OID and home controller" (declare (ignore initargs)) (if (null sc) (error "Initialize instance for type persistent requires valid store controller argument :sc")) (if from-oid (setf (oid instance) from-oid) (setf (oid instance) (next-oid sc))) (setf (:dbcn-spc-pst instance) (controller-spec sc)) (cache-instance sc instance))
(defclass persistent-object (persistent) () (:metaclass persistent-metaclass) (:documentation "Superclass of all user-defined persistent classes. This is automatically inherited if you use the persistent-metaclass metaclass."))
;; ================================================ ;; METACLASS INITIALIZATION AND CHANGES ;; ================================================
(defmethod ensure-class-using-class :around ((class (eql nil)) name &rest args &key index) "Support the :index class option" (let ((result (apply #'call-next-method class name (remove-index-keyword args)))) (when (and index (subtypep (type-of result) 'persistent-metaclass)) (update-indexed-record result nil :class-indexed t)) result))
(defmethod ensure-class-using-class :around ((class persistent-metaclass) name &rest args &key index) "Support the :index class option on redefinition" (let ((result (apply #'call-next-method class name (remove-index-keyword args)))) (when index (update-indexed-record result nil :class-indexed t)) result)) (defun remove-index-keyword (list) (cond ((null list) nil) ((eq (car list) :index) (cddr list)) (t (cons (car list) (remove-index-keyword (cdr list))))))
(defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) (persistent-object (find-class 'persistent-object)) (not-already-persistent (loop for superclass in direct-superclasses never (eq (class-of superclass) persistent-metaclass)))) (if (and (not (eq class persistent-object)) not-already-persistent) (apply #'call-next-method class slot-names :direct-superclasses (cons persistent-object direct-superclasses) args) (call-next-method))))
(defmethod finalize-inheritance :around ((instance persistent-metaclass)) "Update the persistent slot records in the metaclass." (prog1 (call-next-method) (when (not (slot-boundp instance '%persistent-slots)) (setf (%persistent-slots instance) (cons (persistent-slot-names instance) nil))) (update-indexed-record instance (indexed-slot-names-from-defs instance))))
(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) (update-indexed-record instance (indexed-slot-names-from-defs instance)) (if (removed-indexing? instance) (progn (let ((class-idx (get-value (class-name instance) (controller-class-root *store-controller*)))) (when class-idx (wipe-class-indexing instance class-idx))) (setf (%index-cache instance) nil)) (set-db-synch instance :class)) ;; #+allegro ;; (loop with persistent-slots = (persistent-slots instance) ;; for slot-def in (class-direct-slots instance) ;; when (member (slot-definition-name slot-def) persistent-slots) ;; do (initialize-accessors slot-def instance)) (make-instances-obsolete instance))))
;; ================================================ ;; PERSISTENT OBJECT MAINTENANCE ;; ================================================
;; ;; CLASS INSTANCE INITIALIZATION ;;
(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for implementations to optimize setting the slots via initforms and initargs in such a way that slot-value-using-class et al aren't used. We also handle writing any indices after the class is fully initialized. Calls the next method for the transient slots." (let* ((class (find-class (class-name (class-of instance)))) (oid (oid instance)) (persistent-slot-names (persistent-slot-names class))) (flet ((persistent-slot-p (item) (member item persistent-slot-names :test #'eq))) (let ((transient-slot-inits (if (eq slot-names t) ; t means all slots (transient-slot-names class) (remove-if #'persistent-slot-p slot-names))) (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) (inhibit-indexing oid) (unwind-protect (progn ;; initialize the persistent slots ourselves (initialize-persistent-slots class instance persistent-slot-inits initargs) ;; let the implementation initialize the transient slots (apply #'call-next-method instance transient-slot-inits initargs)) (uninhibit-indexing oid)) ;; Inhibit indexing altogether if the object already was defined (ie being created ;; from an oid) as it should be indexed already. This hack avoids a deadlock ;; situation where we write the class or index page that we are currently reading ;; via a cursor without going through the cursor abstraction. There has to be a ;; better way to do this. (when (and (indexed class) (not from-oid)) (let ((class-index (find-class-index class))) (when class-index (setf (get-value oid class-index) instance)))) ))))
(defun initialize-persistent-slots (class instance persistent-slot-inits initargs) (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs with slot-initargs = (slot-definition-initargs slot-def) when (member initarg slot-initargs :test #'eq) do (setf (slot-value-using-class class instance slot-def) (getf initargs initarg)) (return t)))) (with-transaction (:store-controller (get-con instance)) (loop for slot-def in (class-slots class) unless (initialize-from-initarg slot-def) when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq) unless (slot-boundp-using-class class instance slot-def) do (let ((initfun (slot-definition-initfunction slot-def))) (when initfun (setf (slot-value-using-class class instance slot-def) (funcall initfun))))))))
;; ;; CLASS REDEFINITION PROTOCOL ;;
(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; NOTE: probably should delete discarded slots, but we'll worry about that later ;; (also will want to delete discarded indices since we don't have a good GC) (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) (let* ((class (class-of instance)) (new-persistent-slots (set-difference (persistent-slots class) (old-persistent-slots class)))) ;; Update new persistent slots, the others we get for free (same oid!) ;; Isn't this done by the default call-next-method? (apply #'shared-initialize instance new-persistent-slots initargs)) ))
;; ;; CLASS CHANGE PROTOCOL ;;
(defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key) (let* ((old-class (class-of previous)) (new-class (class-of current)) (new-persistent-slots (set-difference (persistent-slots new-class) (persistent-slots old-class))) (raw-retained-persistent-slots (intersection (persistent-slots new-class) (persistent-slots old-class))) (retained-unbound-slots (loop for slot-name in raw-retained-persistent-slots when (not (persistent-slot-boundp (get-con previous) previous slot-name)) collect slot-name)) (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) (with-transaction (:store-controller (get-con current)) (loop for slot-def in (class-slots new-class) when (member (slot-definition-name slot-def) retained-persistent-slots) do (setf (slot-value-using-class new-class current slot-def) (slot-value-using-class old-class previous (find-slot-def-by-name old-class (slot-definition-name slot-def)))))) ;; Delete this instance from its old class index, if exists (when (indexed old-class) (remove-kv (oid previous) (find-class-index old-class))) (call-next-method)))
;; ;; SLOT ACCESS PROTOCOLS ;;
(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-reader (get-con instance) instance name)))
(defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (declare (optimize (speed 3))) (if (indexed class) (indexed-slot-writer class instance slot-def new-value) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer (get-con instance) new-value instance name))))
(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-boundp (get-con instance) instance name)))
(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) "Checks if the slot exists in the database." (declare (optimize (speed 3))) (loop for slot in (class-slots class) for matches-p = (eq (slot-definition-name slot) slot-name) until matches-p finally (return (if (and matches-p (subtypep (type-of slot) 'persistent-slot-definition)) (persistent-slot-boundp (get-con instance) instance slot-name) (call-next-method)))))
(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." (declare (optimize (speed 3))) ;; NOTE: call remove-indexed-slot here instead? (when (indexed slot-def) (unregister-indexed-slot class (slot-definition-name slot-def))) (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def))) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2-locks.lisp 2007/01/16 00:55:22 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2-locks.lisp 2007/01/16 00:55:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; serializer.lisp -- convert Lisp data to/from byte arrays ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; blee@common-lisp.net ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;
(in-package :elephant)
(defpackage :elephant-serializer2 (:use :cl :elephant :elephant-memutil) (:import-from :elephant *circularity-initial-hash-size* *resourced-byte-spec* get-cached-instance slot-definition-allocation slot-definition-name compute-slots oid))
(in-package :elephant-serializer2)
(declaim (inline int-byte-spec serialize deserialize slots-and-values deserialize-bignum))
(uffi:def-type foreign-char :char)
;; Constants
(defconstant +fixnum+ 1) (defconstant +fixnum64+ 2) (defconstant +char+ 3) (defconstant +single-float+ 4) (defconstant +double-float+ 5) (defconstant +negative-bignum+ 6) (defconstant +positive-bignum+ 7) (defconstant +rational+ 8)
;; Save constants by splitting strings and encoding (defconstant +utf8-string+ 9) (defconstant +utf16-string+ 10) (defconstant +utf32-string+ 11)
;; String-based aggregates (defconstant +pathname+ 12) (defconstant +symbol+ 13)
;; Cached symbol references (defconstant +symbol-id+ 14)
;; stored by id+classname (defconstant +persistent+ 15)
;; Composite objects (defconstant +cons+ 16) (defconstant +hash-table+ 17) (defconstant +object+ 18) (defconstant +array+ 19) (defconstant +struct+ 20) (defconstant +class+ 21)
(defconstant +nil+ #x3F)
;; Arrays (defconstant +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80)
;; ;; The following may be overkill, but is intended to avoid continually ;; allocating hashes each time we serialize an object. I added some ;; adaptation to keep it from dropping and re-allocating if the user ;; continually saves large collections of objects. However the ;; defaults should handle most apps just fine. The queue is useful ;; because a system with 10 threads will need 10 circularity queues if ;; it is storing large objects ;;
;; ;; Circularity Hash for Serializer ;;
(defparameter *circularity-hash-queue* (make-array 20 :fill-pointer 0 :adjustable t) "Circularity ids for the serializer.")
(defparameter *circularity-lock* (ele-make-lock) "Enable multiprocessor ")
(defun get-circularity-hash () "Get a clean hash for object serialization" (declare (optimize (speed 3) (safety 0))) (make-hash-table :test 'eq :size *circularity-initial-hash-size*)) ;; (if (= 0 (length *circularity-hash-queue*)) ;; (make-hash-table :test 'eq :size *circularity-initial-hash-size*)) ;; (ele-with-lock (*circularity-lock*) ;; (vector-pop *circularity-hash-queue*))))
(defun release-circularity-hash (hash) "Return the hash to the queue for reuse" (declare (optimize (speed 3) (safety 0)) (type hash-table hash) (type array *circularity-hash-queue*)) nil) ;; (unless (= (hash-table-count hash) 0) ;; (clrhash hash)) ;; (ele-with-lock (*circularity-lock*) ;; (vector-push-extend hash *circularity-hash-queue*)))
;; ;; Circularity Hash for Serializer ;;
(defparameter *circularity-vector-queue* (make-array 20 :fill-pointer 0 :adjustable t) "A list of vectors used for linear deserialization. This works nicely because all ID's are written
[449 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/serializer3.lisp 2007/01/16 00:55:22 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer3.lisp 2007/01/16 00:55:22 1.1
[582 lines skipped]