- elephant-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[elephant-cvs] CVS elephant/src/elephant
by ieslick 20 Jan '07

20 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv5278/src/elephant Modified Files: controller.lisp cross-platform.lisp package.lisp serializer.lisp serializer2.lisp variables.lisp Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/19 21:03:30 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/20 22:12:17 1.19 @@ -26,7 +26,6 @@ (defparameter *elephant-backends* '((:bdb (:ele-bdb)) (:clsql (:ele-clsql)) -;; (:acache (:ele-acache)) ) "Entries have the form of (backend-type asdf-depends-list") @@ -102,53 +101,6 @@ ;; ;; ================================================ -;; -;; Callback hooks for persistent variables -;; -;; NOTE: Design sketch; not sure I'll include this... - -;;(defvar *variable-hooks* nil -;; "An alist (specs -> varlist) where varlist is tuple of -;; lisp name, store name (auto) and policy") - -;;(defun add-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (push name (assoc spec *variable-hooks* :test #'equal)) -;; (push (cons spec (list name)) *variable-hooks*))) - -;;(defun remove-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (setf (assoc spec *variable-hooks* :test #'equal) -;; (remove name (assoc spec *variable-hooks* :test #'equal))) -;; (error "No hooks declared on ~A" spec))) - -;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil)) -;; `(progn -;; (defvar ,name ,initial-value ,documentation) -;; (add-hook ,name ,spec) -;; ,(case policy -;; (:wrap-mutators -;; `(progn -;; ,(loop for accessor in accessors do -;; (let ((gf (ensure-generic-function -;; `(defmethod ,accessor :after ( - -;; (defpvar *agencies* (:wrap-mutators -;; 'add-agent -;; 'remove-agent -;; 'clear-agents) -;; nil -;; "test") - -;; (defmethod add-agent (agent) -;; (push agent *agencies*)) - -;; (defmethod remove-agent (agent) -;; (setf *agencies* (remove agent *agencies*))) - -;; (defmethod clear-agents (agent) -;; (setf *agencies* nil)) - ;; ;; Open a Store @@ -157,10 +109,11 @@ (defun open-store (spec &rest args) "Conveniently open a store controller." (assert (consp spec)) + ;; setup system config parameters (if necessary) + ;; GF iface to overload by backend (setq *store-controller* (get-controller spec)) (initialize-serializer *store-controller*) - (ensure-properties - (apply #'open-controller *store-controller* args))) + (apply #'open-controller *store-controller* args)) (defun close-store (&optional sc) "Conveniently close the store controller." @@ -205,6 +158,7 @@ ;; Symbol ID caches (symbol-cache :accessor controller-symbol-cache :initform (make-hash-table :size 2000)) (symbol-id-cache :accessor controller-symbol-id-cache :initform (make-hash-table :size 2000)) + (fast-symbols :accessor controller-fast-symbols-p :initform nil) ) (:documentation "Class of objects responsible for the book-keeping of holding DB @@ -213,24 +167,24 @@ (defun initialize-serializer (sc) "Establish serializer version on controller startup" - (cond ((equal (controller-version sc) '(0 6 1)) - (setf (controller-serializer-version sc) 2) - (setf (controller-serialize sc) 'elephant-serializer2::serialize) - (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)) - ((prior-version-p (controller-version sc) '(0 6 0)) + (cond ((prior-version-p (controller-version sc) '(0 6 0)) (setf (controller-serializer-version sc) 1) (setf (controller-serialize sc) 'elephant-serializer1::serialize) (setf (controller-deserialize sc) 'elephant-serializer1::deserialize)) - (t (error "Unsupported Elephant database version")))) + (t + (setf (controller-serializer-version sc) 2) + (setf (controller-serialize sc) 'elephant-serializer2::serialize) + (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)))) ;; ;; VERSIONING ;; -(defvar *restricted-properties* '(:version) - "Properties that are not user manipulable") - -(defmethod controller-version ((sc store-controller)) +(defmethod database-version ((sc store-controller)) + (:documentation "A version determination for a given store + controller that is independant of the serializer as the + serializer is dispatched based on the code version which is a + list of the form '(0 6 0)")) (let ((version (controller-version-cached sc))) (if version version (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) @@ -252,82 +206,6 @@ (prior-version-p (cdr v1) (cdr v2))) (t (error "Version problem!")))) -(defmethod ensure-properties ((sc store-controller)) - "Not sure this test is right (empty root)" - (let ((props (controller-properties sc)) - (empty? (and (empty-btree-p (controller-root sc)) - (empty-btree-p (controller-class-root sc))))) - ;; marked - continue - (unless (assoc :version props) - (if empty? - ;; empty so new database - mark with current code version - (setf (get-value *elephant-properties-label* (controller-root sc)) - (acons :version *elephant-code-version* props)) - ;; has stuff in it but not marked - mark as prior - (setf (get-value *elephant-properties-label* (controller-root sc)) - (acons :version *elephant-unmarked-code-version* props))))) - sc) - - -;; -;; Upgrade paths -;; - -(defmethod up-to-date-p ((sc store-controller)) - (equal (controller-version sc) *elephant-code-version*)) - -(defmethod upgrade ((sc store-controller) target-spec) - (unless (upgradable-p sc) - (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" - (controller-spec sc) - (controller-version sc) - *elephant-code-version* - *elephant-upgrade-table*)) - (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your - data does not require any unsupported features") - (let ((source sc) - (target (open-store target-spec))) - (migrate target source) - (close-store target))) - -(defparameter *elephant-upgrade-table* - '( ((0 6 0) (0 5 0)) - ((0 6 1) (0 6 0)) - )) - -(defmethod upgradable-p ((sc store-controller)) - "Determine if this store can be brought up to date using the upgrade function" - (unwind-protect - (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal)) - (ver (controller-version sc))) - (when (member ver (rest row) :test #'equal)) t) - nil)) - - -;; -;; PROPERTIES -;; - -(defmethod controller-properties ((sc store-controller)) - (get-from-root *elephant-properties-label* :store-controller sc)) - -(defmethod set-ele-property (property value &key (sc *store-controller*)) - (assert (and (symbolp property) (not (member property *restricted-properties*)))) - (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) - (setf (get-value *elephant-properties-label* (controller-root sc)) - (if (assoc property props) - (progn (setf (cdr (assoc property props)) value) - props) - (acons property value props))))) - -(defmethod get-ele-property (property &key (sc *store-controller*)) - (assert (symbolp property)) - (let ((entry (assoc property - (get-from-root *elephant-properties-label* - :store-controller sc)))) - (when entry - (cdr entry)))) - ;; ;; OBJECT CACHE ;; @@ -392,12 +270,6 @@ "Close the db handles and environment. Tries to wipe out references to the db handles.")) -(defgeneric database-version ((sc store-controller)) - (:documentation "A version determination for a given store - controller that is independant of the serializer as the - serializer is dispatched based on the code version which is a - list of the form '(0 6 0)")) - (defgeneric connection-is-indeed-open (controller) (:documentation "Validate the controller and the db that it is connected to") (:method ((controller t)) t)) @@ -411,6 +283,7 @@ "Tell the backend to reclaim any storage caused by key deletion, if possible. This should default to return space to the filesystem rather than just to the free list.")) + ;; ;; Object Root Operations ;; @@ -420,7 +293,7 @@ retrieve it in a later session. N.B. this means it (and everything it points to) won't get gc'd." (declare (type store-controller store-controller)) - (assert (not (eq key *elephant-properties-label*))) +;; (assert (not (eq key *elephant-properties-label*))) (setf (get-value key (controller-root store-controller)) value)) (defun get-from-root (key &key (store-controller *store-controller*)) @@ -453,6 +326,118 @@ (remhash (controller-spec sc) *dbconnection-spec*)) ;; +;; DATABASE PROPERTY INTERFACE (Not used by system as of 0.6.1) +;; + +(defvar *restricted-properties* '() + "Properties that are not user manipulable") + +(defmethod controller-properties ((sc store-controller)) + (get-from-root *elephant-properties-label* :store-controller sc)) + +(defmethod set-ele-property (property value &key (sc *store-controller*)) + (assert (and (symbolp property) (not (member property *restricted-properties*)))) + (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) + (setf (get-value *elephant-properties-label* (controller-root sc)) + (if (assoc property props) + (progn (setf (cdr (assoc property props)) value) + props) + (acons property value props))))) + +(defmethod get-ele-property (property &key (sc *store-controller*)) + (assert (symbolp property)) + (let ((entry (assoc property + (get-from-root *elephant-properties-label* + :store-controller sc)))) + (when entry + (cdr entry)))) + + +;; +;; Upgrade paths +;; + +(defmethod up-to-date-p ((sc store-controller)) + (equal (controller-version sc) *elephant-code-version*)) + +(defmethod upgrade ((sc store-controller) target-spec) + (unless (upgradable-p sc) + (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" + (controller-spec sc) + (controller-version sc) + *elephant-code-version* + *elephant-upgrade-table*)) + (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your + data does not require any unsupported features") + (let ((source sc) + (target (open-store target-spec))) + (migrate target source) + (close-store target))) + +(defparameter *elephant-upgrade-table* + '( ((0 6 0) (0 5 0)) + ((0 6 1) (0 6 0)) + )) + +(defmethod upgradable-p ((sc store-controller)) + "Determine if this store can be brought up to date using the upgrade function" + (unwind-protect + (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal)) + (ver (controller-version sc))) + (when (member ver (rest row) :test #'equal)) t) + nil)) + + +;; +;; Callback hooks for persistent variables +;; + +;; NOTE: Design sketch; not sure I'll promote this... + +;;(defvar *variable-hooks* nil +;; "An alist (specs -> varlist) where varlist is tuple of +;; lisp name, store name (auto) and policy") + +;;(defun add-hook (name spec) +;; (if (assoc spec *variable-hooks* :test #'equal) +;; (push name (assoc spec *variable-hooks* :test #'equal)) +;; (push (cons spec (list name)) *variable-hooks*))) + +;;(defun remove-hook (name spec) +;; (if (assoc spec *variable-hooks* :test #'equal) +;; (setf (assoc spec *variable-hooks* :test #'equal) +;; (remove name (assoc spec *variable-hooks* :test #'equal))) +;; (error "No hooks declared on ~A" spec))) + +;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil)) +;; `(progn +;; (defvar ,name ,initial-value ,documentation) +;; (add-hook ,name ,spec) +;; ,(case policy +;; (:wrap-mutators +;; `(progn +;; ,(loop for accessor in accessors do +;; (let ((gf (ensure-generic-function +;; `(defmethod ,accessor :after ( + +;; (defpvar *agencies* (:wrap-mutators +;; 'add-agent +;; 'remove-agent +;; 'clear-agents) +;; nil +;; "test") + +;; (defmethod add-agent (agent) +;; (push agent *agencies*)) + +;; (defmethod remove-agent (agent) +;; (setf *agencies* (remove agent *agencies*))) + +;; (defmethod clear-agents (agent) +;; (setf *agencies* nil)) + + +;; ;; Support for serialization efficiency ;; @@ -465,6 +450,7 @@ (:documentation "Return a symbol for the ID. This should always succeed. The database should not use the existing serializer to perform this function; but memutils and unicode are available")) + ;; ;; Low-level support for metaclass protocol ;; --- /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/20 22:12:18 1.2 @@ -17,7 +17,7 @@ (in-package :elephant) ;; This is a quick portability hack to avoid external dependencies, if we get -;; to many of these do we need to import a standard library? do we need to import 'port' or some +;; too many of these do we need to import a standard library? do we need to import 'port' or some ;; other thread layer to the elephant dependency list? (defmacro ele-without-interrupts (&body body) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/19 21:03:30 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/20 22:12:18 1.6 @@ -26,7 +26,7 @@ "Elephant: an object-oriented database for Common Lisp with multiple backends for Berkeley DB, SQL and others.") (:export #:*store-controller* #:*current-transaction* #:*auto-commit* - #:*elephant-lib-path* #:*elephant-code-version* + #:*elephant-lib-path* #:*elephant-code-version* #:*fast-symbols* #:store-controller #:controller-root #:controller-class-root #:controller-version #:controller-serializer-version --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/12/16 19:35:10 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/20 22:12:18 1.16 @@ -26,6 +26,9 @@ current Elephant version" (funcall (symbol-function (controller-deserialize sc)) bs sc)) +;;(defun serializer-feature (sc) +;; ( + ;; ;; SQL encoding support ;; --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/20 22:12:18 1.2 @@ -460,27 +460,17 @@ ;; Symbol cache ;; -(defun deserialize-symbol-id (id sc) - "Deserialize a symbol ID by finding it in the cache" - (declare (type fixnum id)) - (let ((symbol (gethash id (controller-symbol-cache sc)))) - (if symbol symbol - (let ((symbol (lookup-persistent-symbol sc id))) - (if symbol - (progn - (setf (gethash id (controller-symbol-cache sc)) symbol) - (setf (gethash symbol (controller-symbol-id-cache sc)) id) - symbol) - (error "Symbol lookup foobar! ID referred to does not exist in database")))))) - (defun serialize-symbol (symbol bs sc) "Serialize a symbol by recording its ID" (declare (type buffer-stream bs) - (type symbol symbol)) - (let ((id (lookup-id symbol sc))) - (declare (type fixnum id)) - (buffer-write-byte +symbol-id+ bs) - (buffer-write-int id bs))) + (type symbol symbol) + (type store-controller sc)) + (if *fast-symbols* + (let ((id (lookup-id symbol sc))) + (declare (type fixnum id)) + (buffer-write-byte +symbol-id+ bs) + (buffer-write-int id bs)) + (serialize-symbol-complete symbol bs))) (defun lookup-id (symbol sc) "Find an id for a symbol or create a new one" @@ -509,6 +499,19 @@ (serialize-string (package-name package) bs) (buffer-write-byte +nil+ bs))))) +(defun deserialize-symbol-id (id sc) + "Deserialize a symbol ID by finding it in the cache" + (declare (type fixnum id)) + (let ((symbol (gethash id (controller-symbol-cache sc)))) + (if symbol symbol + (let ((symbol (lookup-persistent-symbol sc id))) + (if symbol + (progn + (setf (gethash id (controller-symbol-cache sc)) symbol) + (setf (gethash symbol (controller-symbol-id-cache sc)) id) + symbol) + (error "Symbol lookup foobar! ID referred to does not exist in database")))))) + ;; ;; Array type tags --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/12/16 19:35:10 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/20 22:12:18 1.7 @@ -43,6 +43,8 @@ Users attempting to directly write this variable will run into an error") +(defvar *fast-symbols* nil) + ;;;;;;;;;;;;;;;;; ;;;; Serializer optimization parameters

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 20 Jan '07

20 Jan '07

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv5278/src/memutil Modified Files: memutil.lisp Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/12/16 19:35:10 1.13 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/01/20 22:12:18 1.14 @@ -84,7 +84,7 @@ (eval-when (compile) (declaim - (optimize (speed 3) (safety 1) (space 0) (debug 0)) + #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)) (inline read-int read-uint read-float read-double write-int write-uint write-float write-double offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs

1 0

[elephant-cvs] CVS elephant
by ieslick 20 Jan '07

20 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv5278 Modified Files: TODO config.sexp Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/TODO 2007/01/19 21:03:29 1.32 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/20 22:12:17 1.33 @@ -114,16 +114,16 @@ x Remove sleepycat name. Change sleepycat to db-bdb to reflect oracle ownership and avoid confusion for new users -0.6.2 - Advanded work, low-hanging fruit (Fall '06) +0.6.2 - Advanded work, low-hanging fruit (Summer '07) -------------------------------------------------- + - Persistent variables (abstraction that allows compound lisp objects at the cost of + full serialization after each write that indirects through the API). Can this be done + with clean semantics or should we punt it? - Class option MOP add-on to support declared persistent baseclass slots for standard base classes - Evaluate porting elephant to closer-to-MOP to make it easier to support additional lisps and to seriously clean up metaclasses.lisp and classes.lisp protocols - A wrapper around migration that emulates a stop-and-copy GC - -0.6.3 - Documentation & Tools (Winter '06) --------------------------------------------------- - Tutorial example rethink: update the blog tutorial using indexed objects to create different views as well as integrating something like logging for admin or version control purposes. @@ -135,6 +135,7 @@ 0.7.0: Fast In-Memory Database (Not backwards compatible) -------------------------------------------------- + - Full support for DCM or integration of DCM functionality - Integrate prevalence-like in-memory database system for single image, multiple-thread operation - Fast serializer port w/ upgrade strategy and prevalence like storage solution - Further improve SQL 64-bit serialization performance (if possible) @@ -170,16 +171,18 @@ 0.9.0 - Supporting Tools Release -------------------------------------------------- - - Document DCM? - - Add needed support (if any) for persistent graph structures & queries (Ian on a branch) - - Simple object query language (Ian - orthogonal, on main branch) - - Repository browser (Ian - orthogonal, on main branch) - (a simple REPL tool to see what classes are in a repository and - what state they're in...useful for long-lived repositories) - - - - + - Support a simple object query language over the database + - Add special support (if any) for persistent graph structures & queries (ala AllegroCache) + - Repository browser - a simple REPL tool like the Slime inspector + to see what classes are in a repository and what state they're in...useful + for long-lived repositories or if you've forgotten a variable name + +1.0 - Production release (1st fully supported version since 0.7.1) +-------------------------------------------------- + - Finalize supported platforms (LispWorks? OpenMCL?) + - Significant work on test cases & testing framework + - Final pass of performance enhancements + - Invite community review and testing ======================================================== ======================================================== --- /project/elephant/cvsroot/elephant/config.sexp 2006/12/16 19:35:09 1.2 +++ /project/elephant/cvsroot/elephant/config.sexp 2007/01/20 22:12:17 1.3 @@ -1,8 +1,9 @@ -((:berkeley-db-root . "/usr/local/BerkeleyDB.4.4/") +((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.4/") + (:berkeley-db-lib-dir . "/opt/local/lib/db44/") (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.4/lib/libDB-4.4.dylib") (:pthread-lib . nil) (:clsql-lib . nil) - (:fast-symbols . t)) + (:fast-symbols . nil)) ;; Typical pthread settings are: /lib/tls/libpthread.so.0 ;; nil means that the library in question is not loaded

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 20 Jan '07

20 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv5278/src/db-bdb Modified Files: berkeley-db.lisp libberkeley-db.c libberkeley-db.def Log Message: Promoted diff's provided by the community (Pierre and Gabor) as well as a checkpoint of ongoing work to get the 0.6.1 development tree on HEAD working again. --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/19 21:03:29 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/20 22:12:17 1.3 @@ -466,7 +466,17 @@ (wrap-errno db-env-get-flags (env) :outs 2 :documentation "Get flags of an environment.") - + +(def-function ("db_env_txn_checkpoint" %db-env-txn-checkpoint) + ((env :pointer-void) + (kbyte :unsigned-int) + (min :unsigned-int) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-env-txn-checkpoint (env kbyte min flags) + :flags (force) + :documentation "Make a checkpoint.") ;; Database --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/19 21:03:29 1.4 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/20 22:12:17 1.5 @@ -210,6 +210,11 @@ return dbenv->get_flags(dbenv, flagsp); } +int db_env_txn_checkpoint(DB_ENV *dbenv, u_int32_t kbyte, u_int32_t min, + u_int32_t flags) { + return dbenv->txn_checkpoint(dbenv, kbyte, min, flags); +} + /* Database */ DB *db_cr(DB_ENV *dbenv, u_int32_t flags, int *errno) { --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def 2006/11/11 18:41:10 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def 2007/01/20 22:12:17 1.2 @@ -19,6 +19,7 @@ db_env_remove db_env_set_flags db_env_get_flags + db_env_txn_checkpoint db_cr db_close db_open

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 19 Jan '07

19 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv4428/src/db-bdb Modified Files: bdb-controller.lisp berkeley-db.lisp libberkeley-db.c Added Files: bdb-symbol-tables.lisp Log Message: Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/12/16 19:35:10 1.14 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/19 21:03:29 1.15 @@ -57,16 +57,6 @@ (string t) (otherwise nil)))) -(defmethod controller-version ((sc store-controller)) - (let ((version (controller-version sc))) - (if version version - (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) - (if (probe-file path) - (with-open-file (stream path :direction :input) - (read stream)) - (with-open-file (stream path :direction :output) - (write *elephant-code-version* :stream stream))))))) - ;; ;; Open/close ;; --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2006/11/11 18:43:31 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/19 21:03:29 1.2 @@ -1673,10 +1673,11 @@ :returning :int) (def-function ("db_set_lisp_compare" %db-set-lisp-compare) - ((db :pointer-void)) + ((db :pointer-void) + (version :int)) :returning :int) -(wrap-errno db-set-lisp-compare (db) :documentation +(wrap-errno db-set-lisp-compare (db version) :documentation "Sets the Btree comparision function to a hand-cooked function for Elephant to compare lisp values.") @@ -1686,10 +1687,11 @@ :returning :int) (def-function ("db_set_lisp_dup_compare" %db-set-lisp-dup-compare) - ((db :pointer-void)) + ((db :pointer-void) + (version :int)) :returning :int) -(wrap-errno db-set-lisp-dup-compare (db) :documentation +(wrap-errno db-set-lisp-dup-compare (db version) :documentation "Sets the duplicate comparision function to a hand-cooked function for Elephant to compare lisp values.") --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/16 18:02:27 1.3 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/19 21:03:29 1.4 @@ -873,8 +873,8 @@ void db_multiple_key_next(void *pointer, DBT *data, unsigned char **key, u_int32_t *ret_key_size, unsigned char **result, u_int32_t *result_size) { - DB_MULTIPLE_KEY_NEXT(pointer, data, - *key, *ret_key_size, + DB_MULTIPLE_KEY_NEXT(pointer, data, + *key, *ret_key_size, *result, *result_size); } --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp 2007/01/19 21:03:30 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp 2007/01/19 21:03:30 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; controller.lisp -- Lisp interface to a Berkeley DB store ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)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 :db-bdb) (defmethod lookup-persistent-symbol-id ((sc bdb-store-controller) symbol) "Look up and create id association for symbol" (with-buffer-streams (keybuf valbuf) (buffer-write-int *symbol-to-id-table-oid* keybuf) (serialize-symbol-complete symbol keybuf) (let ((buf (db-get-key-buffered (controller-btrees sc) keybuf valbuf))) (if buf (values (buffer-read-int buf) T) (values (create-persistent-symbol sc symbol keybuf valbuf) t))))) (defun create-persistent-symbol (sc symbol keybuf valbuf) "Takes an symbol->id table + symbol keybuf, allocates an ID and updates the persistent tables." (reset-buffer-stream valbuf) ;; Just to avoid any contamination ;; (with-transaction (:txn-nosync t :dirty-read t) (format t "getting next symid") (let ((id (next-symid sc))) ;; allocate a new unique id ;; Update symbol->id table (format t "Writing sym->id: ~A -> ~A~%" symbol id) (buffer-write-int id valbuf) (format t "Putting id into table location~%") (db-put-buffered (controller-btrees sc) keybuf valbuf :auto-commit *auto-commit*) ;; Write id->symbol table (reset-buffer-stream keybuf) (reset-buffer-stream valbuf) (format t "Writing id->sym: ~A -> ~A~%" id symbol) (buffer-write-int *id-to-symbol-table-oid* keybuf) (buffer-write-int id keybuf) (serialize-symbol-complete symbol valbuf) (db-put-buffered (controller-btrees sc) keybuf valbuf :auto-commit *auto-commit*) id) ;; ) ) (defmethod lookup-persistent-symbol ((sc bdb-store-controller) id) "Lookup the ID associated with a symbol" (with-buffer-streams (keybuf valbuf) (format t "Looking up: ~A~%" id) (buffer-write-int *id-to-symbol-table-oid* keybuf) (buffer-write-int id keybuf) (format t "Get for id: ~A~%" id) (let ((buf (db-get-key-buffered (controller-btrees sc) keybuf valbuf))) (format t "Got buf: ~A~%" buf) (if buf (values (deserialize buf sc) T) (error "Invalid ID - no persistent mapping for ID"))))) ;; ;; Stress test ;; (defun stress-test (iters syms) (loop for i fixnum from 0 upto iters do (format t "Iteration ~A~%" i) ;; (with-transaction () ;; (print *current-transaction*) (loop for i fixnum from 0 upto (length syms) do (add-to-root (nth i syms) (nth i syms))))) (defun make-syms (num &aux list) (loop for i fixnum from 0 below num do (let* ((str (format nil "test~A" i)) (sym (intern str))) (push sym list))) (nreverse list))

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by ieslick 19 Jan '07

19 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv4428/src/db-clsql Modified Files: sql-collections.lisp Log Message: Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/11/11 18:41:11 1.6 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/01/19 21:03:30 1.7 @@ -136,7 +136,7 @@ (tup tuples (cdr tup))) ((= i len) nil) (setf (aref (:sql-crsr-ks cursor) i) - (deserialize-from-base64-string (caar tup) :sc sc))) + (deserialize-from-base64-string (caar tup) sc))) (sort (:sql-crsr-ks cursor) #'my-generic-less-than) (setf (:sql-crsr-ck cursor) 0) (setf (cursor-initialized-p cursor) t) @@ -362,14 +362,14 @@ (declare (optimize (speed 3))) (unless (cursor-initialized-p cursor) (cursor-init cursor)) - (let ((idx (position key (:sql-crsr-ks cursor)))) + (let ((idx (position key (:sql-crsr-ks cursor) :test #'equal))) (if idx - (progn - (setf (:sql-crsr-ck cursor) idx) - (setf (:dp-nmbr cursor) 0) - (cursor-current-x cursor :returnpk t)) - (cursor-un-init cursor) - ))) + (progn + (setf (:sql-crsr-ck cursor) idx) + (setf (:dp-nmbr cursor) 0) + (cursor-current-x cursor :returnpk t)) + (cursor-un-init cursor) + ))) (defun array-index-if (p a) (do ((i 0 (1+ i)))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 19 Jan '07

19 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4428/src/elephant Modified Files: controller.lisp package.lisp Log Message: Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/12/16 19:35:10 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/19 21:03:30 1.18 @@ -198,7 +198,7 @@ (class-root :reader controller-class-root :documentation "This should be a persistent indexed btree instantiated by the backend") ;; Upgradable serializer strategy - (version :accessor controller-version :initform nil) + (version :accessor controller-version-cached :initform nil) (serializer-version :accessor controller-serializer-version :initform nil) (serialize :accessor controller-serialize :initform nil) (deserialize :accessor controller-deserialize :initform nil) @@ -230,11 +230,16 @@ (defvar *restricted-properties* '(:version) "Properties that are not user manipulable") -(defgeneric controller-version ((sc store-controller)) - (:documentation "Return the elephant version of this controller - should not - require the serializer to operate as it may be used to determine - the serializer version used to read the DB. This has to be valid - prior to the DB being opened.")) +(defmethod controller-version ((sc store-controller)) + (let ((version (controller-version-cached sc))) + (if version version + (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) + (if (probe-file path) + (with-open-file (stream path :direction :input) + (setf (controller-version-cached sc) (read stream))) + (with-open-file (stream path :direction :output) + (setf (controller-version-cached sc) + (write *elephant-code-version* :stream stream)))))))) (defun prior-version-p (v1 v2) "Is v1 an equal or earlier version than v2" --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/12/16 19:35:10 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/19 21:03:30 1.5 @@ -29,7 +29,8 @@ #:*elephant-lib-path* #:*elephant-code-version* #:store-controller #:controller-root #:controller-class-root - #:controller-version #:controller-serialize #:controller-deserialize + #:controller-version #:controller-serializer-version + #:controller-serialize #:controller-deserialize #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp #:get-cached-instance #:flush-instance-cache

1 0

[elephant-cvs] CVS elephant
by ieslick 19 Jan '07

19 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv4428 Modified Files: TODO ele-bdb.asd elephant.asd Log Message: Added missing file; Henrik's fixes to ele-bdb and clsql cursor-pset --- /project/elephant/cvsroot/elephant/TODO 2006/12/16 19:35:09 1.31 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/19 21:03:29 1.32 @@ -14,7 +14,6 @@ - flexible handling of 64-bit fixnums Stability: -- Remove build gensym warnings in sleepycat.lisp - Delete persistent slot values from the slot store with remove-kv to ensure that there's no data left lying around if you define then redefine a class and add back a persistent slot name that you thought was deleted and it gets the old @@ -61,6 +60,8 @@ parameter that determines if this is the default? Performance: +- Allow dump of fast-symbol tables for low-level reconstruction in case of + catastrophic errors - Metering and understanding locking issues. Large transactions seem to use a lot of locks. In general understanding how to use Berkeley DB efficiently seems like a good thing. (From Ben) @@ -85,6 +86,7 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- +January 2006 checkin x Improved optimization options to be more user controlled (Pierre Thierry) x Implement backend support for symbol-table protocol x Speed up symbol storage and reference using symbol id's @@ -94,7 +96,10 @@ x New build interface; all-lisp compilation (sans win32) x Simplify user-specific configuration parameters using config.sexp and my-config.sexp x Make sure to ensure thread safety in buffer-stream allocation! +x Investigated gensym warnings in berkeley-db.lisp (caused by an FFI macro, no harm in it) +x Remove warnings in libberkeley-db.c +Prior to December 2006 x BDB overwrite of values makes DB grow [So far I can only find that it grows on the 2nd write, but not after that...artifact of page allocation or caching of memory pools?] --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/12/16 19:35:09 1.13 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/01/19 21:03:29 1.14 @@ -31,11 +31,16 @@ (defun get-config-option (option component) (unless *bdb-config* - (with-open-file (config (make-pathname :defaults (asdf:component-pathname - (asdf:component-system component)) - :name "my-config" - :type "sexp")) - (setf *bdb-config* (read config)))) + (let ((filespec (make-pathname :defaults (asdf:component-pathname + +(asdf:component-system component)) + :name "my-config" + :type "sexp"))) + (unless (probe-file filespec) + (error "Missing file. Copy config.sexp in elephant root +directory to my-config.sexp and edit it appropriately.")) + (with-open-file (config filespec) + (setf *bdb-config* (read config))))) (cdr (assoc option *bdb-config*))) ;; --- /project/elephant/cvsroot/elephant/elephant.asd 2006/12/16 19:35:09 1.21 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/01/19 21:03:29 1.22 @@ -130,8 +130,8 @@ (defsystem elephant :name "elephant" :author "Ben Lee <blee(a)common-lisp.net>" - :version "0.6.0" - :maintainer "Ben Lee <blee(a)common-lisp.net>" + :version "0.6.1" + :maintainer "Robert Read <read(a)robertlread.net>" :licence "LLGPL" :description "Object database for Common Lisp" :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro."

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 16 Jan '07

16 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv771 Modified Files: libberkeley-db.c Log Message: Fixed build errors in db-bdb C interface file. This file is not yet complete for serializer2 --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2006/12/16 19:35:10 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/16 18:02:27 1.3 @@ -67,7 +67,7 @@ /* Pointer arithmetic utility functions */ /* should these be in network-byte order? probably not..... */ int read_int(char *buf, int offset) { - int int; + int i; memcpy(&i, buf+offset, sizeof(int)); return i; } @@ -79,7 +79,7 @@ } int32_t read_int32(char *buf, int offset) { - int int32_t; + int32_t i; memcpy(&i, buf+offset, sizeof(int32_t)); return i; } @@ -119,7 +119,7 @@ memcpy(buf+offset, &num, sizeof(int)); } -void write_uint(char *buf, unsighed int num, int offset) { +void write_uint(char *buf, unsigned int num, int offset) { memcpy(buf+offset, &num, sizeof(unsigned int)); } @@ -277,6 +277,7 @@ double read_num(char *buf); int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2); +int wcs_cmp(const wchar_t *a, int32_t length1, const wchar_t *b, int32_t length2); int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2); int utf16_cmp(const char *s1, int32_t length1, const char *s2, int32_t length2); @@ -316,7 +317,7 @@ } /* Compare types. */ - if + /* ISE: need extra conditional here...forget why, so research it */ difference = at - bt; if (difference) return difference; @@ -335,7 +336,7 @@ case 20: case 21: case 22: - return wcs_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); + return wcs_cmp((wchar_t*)ad+9, read_int(ad, 5), (wchar_t*)bd+9, read_int(bd, 5)); default: return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); } @@ -368,33 +369,37 @@ /* Compare numerics. */ if (type_numeric2(at) && type_numeric2(bt)) { - ddifference = read_num2(ad+4) - read_num2(bd+4); + /* ddifference = read_num2(ad+4) - read_num2(bd+4); */ + ddifference = read_num(ad+4) - read_num(bd+4); if (ddifference > 0) return 1; else if (ddifference < 0) return -1; return 0; } /* Compare types. */ - if + /* ISE: need extra conditional here...forget why, so research it */ difference = at - bt; if (difference) return difference; - ;; TODO: compare strings of different sizes? - ;; TODO: compare symbol-ids? + /* TODO: compare strings of different sizes? */ + /* TODO: compare symbol-ids? */ /* Same type! */ switch (at) { - case #x3F: /* nil */ + case 0x3F: /* nil */ return 0; case 9: /* 8-bit string */ + return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); + /* ISE: Why did I do this? if( bt == 9 ) return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); else return full_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)) + */ case 10: /* 16-bit string */ return utf16_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); case 11: - return wcs_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); + return wcs_cmp((wchar_t*)ad+9, read_int32(ad, 5), (wchar_t*)bd+9, read_int32(bd, 5)); default: return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); } @@ -866,8 +871,8 @@ } void db_multiple_key_next(void *pointer, DBT *data, - char **key, u_int32_t *ret_key_size, - char **result, u_int32_t *result_size) { + unsigned char **key, u_int32_t *ret_key_size, + unsigned char **result, u_int32_t *result_size) { DB_MULTIPLE_KEY_NEXT(pointer, data, *key, *ret_key_size, *result, *result_size); @@ -875,7 +880,7 @@ /* Transactions */ -DB_TXN * db_txn_begin(DB_ENV *env, DB_TXN *parent, +DB_TXN *db_txn_begin(DB_ENV *env, DB_TXN *parent, u_int32_t flags, int *errno) { DB_TXN * p; *errno = env->txn_begin(env, parent, &p, flags);

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 16 Jan '07

16 Jan '07

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(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)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(a)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]

1 0