August 2004 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS update: elephant/LICENSE
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv13213 Added Files: LICENSE Log Message: first version Date: Fri Aug 27 10:30:49 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/README
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv13081 Added Files: README Log Message: first version Date: Fri Aug 27 10:30:35 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/TUTORIAL
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv12993 Added Files: TUTORIAL Log Message: first version Date: Fri Aug 27 10:30:25 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/elephant.asd
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv12772 Added Files: elephant.asd Log Message: first version Date: Fri Aug 27 10:30:09 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/functions.lisp
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv12626 Added Files: functions.lisp Log Message: first version Date: Fri Aug 27 10:29:28 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/INSTALL
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv12575 Added Files: INSTALL Log Message: first version Date: Fri Aug 27 10:28:09 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/NOTES
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv23984 Added Files: NOTES Log Message: beginning of a developer doc Date: Thu Aug 26 19:59:46 2004 Author: blee

1 0

[elephant-cvs] CVS update: elephant/src/collections.lisp
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23923/src Modified Files: collections.lisp Log Message: integrated with new serializer Date: Thu Aug 26 19:58:28 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.1.1.1 elephant/src/collections.lisp:1.2 --- elephant/src/collections.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004 +++ elephant/src/collections.lisp Thu Aug 26 19:58:28 2004 @@ -3,93 +3,51 @@ ;;; collection types ;;; abstract hash-like collections ;;; equal hashing (except probably for array, hashe, instance keys!) -(defclass collection () - ((%db :accessor db)) - (:metaclass persistent-metaclass)) - -(defmethod initialize-instance :before ((instance collection) - &rest initargs - &key store-controller - &allow-other-keys) - (declare (ignore initargs)) - (setf (get-store-controller instance) store-controller)) - -(defmethod initialize-instance :after ((instance collection) - &rest initargs) - (declare (ignore initargs)) - (register-collection (get-store-controller instance) instance)) +(defclass collection (persistent) ()) (defgeneric get-value (key ht &rest args)) (defgeneric remove-kv (key ht &rest args)) -;;; auto-serialize keys, values -(defclass serial-hash-mixin () ()) - -(defmethod get-value (key (ht serial-hash-mixin) &rest args) - (deserialize (apply #'db-get (db ht) (serialize key) args) - (get-store-controller ht))) - -(defmethod (setf get-value) (value key (ht serial-hash-mixin) &rest args - &key (transaction *transaction*) - &allow-other-keys) - (apply #'%db-put (db ht) (serialize key) (serialize value) - :transaction transaction args)) - -(defmethod remove-kv (key (ht serial-hash-mixin) &rest args - &key (transaction *transaction*) &allow-other-keys) - (apply #'%db-remove (db ht) (serialize key) :transaction transaction args)) - -;;; string keys, values -(defclass string-hash-mixin () ()) - -(defmethod get-value (key (ht string-hash-mixin) &rest args) - (apply #'db-get (db ht) key args)) - -(defmethod (setf get-value) (value key (ht string-hash-mixin) &rest args - &key (transaction *transaction*) - &allow-other-keys) - (apply #'%db-put (db ht) key value :transaction transaction args)) - -(defmethod remove-kv (key (ht string-hash-mixin) &rest args - &key (transaction *transaction*) &allow-other-keys) - (apply #'%db-remove (db ht) key :transaction transaction args)) - ;;; btree access -(defclass %btree (collection) () - (:metaclass persistent-metaclass)) - -(defmethod initialize-instance :after ((instance %btree) &rest initargs) - (declare (ignore initargs)) - (setf (db instance) - (create-table (get-store-controller instance) - "p-btrees" - (prin1-to-string (oid instance)) - :type :btree))) - -;;; persistent serialized object btrees -(defclass p-btree (%btree serial-hash-mixin) () - (:metaclass persistent-metaclass)) - -;;; persistent string btree -(defclass p-string-btree (%btree string-hash-mixin) () - (:metaclass persistent-metaclass)) - -;;; hash-table access -(defclass %hash-table (collection) () - (:metaclass persistent-metaclass)) - -(defmethod initialize-instance :after ((instance %hash-table) &rest initargs) - (declare (ignore initargs)) - (setf (db instance) - (create-table (get-store-controller instance) - "p-hash-tables" - (prin1-to-string (oid instance)) - :type :hash))) - -;;; persistent serialized object hash-tables -(defclass p-hash-table (%hash-table serial-hash-mixin) () - (:metaclass persistent-metaclass)) +(defclass btree (collection) ()) -;;; persistent string hash-tables -(defclass p-string-hash-table (%hash-table string-hash-mixin) () - (:metaclass persistent-metaclass)) +(defmethod get-value (key (ht btree) &rest args) + (declare (ignore args)) + (buffer-write-int (oid ht) *key-buf*) + (let ((key-length (serialize key *key-buf*))) + (handler-case + (values + (deserialize (db-get-key-buffered (db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length)) + t) + (db-error (err) + (if (= (db-error-errno err) DB_NOTFOUND) + (values nil nil) + (error err)))))) + +(defmethod (setf get-value) (value key (ht btree) &rest args + &key (transaction *current-transaction*) + (auto-commit *auto-commit*) + &allow-other-keys) + (declare (ignore args)) + (buffer-write-int (oid ht) *key-buf*) + (let ((key-length (serialize key *key-buf*)) + (val-length (serialize value *out-buf*))) + (db-put-buffered (db *store-controller*) + (buffer-stream-buffer *key-buf*) key-length + (buffer-stream-buffer *out-buf*) val-length + :transaction transaction + :auto-commit auto-commit))) + +(defmethod remove-kv (key (ht btree) &rest args + &key (transaction *current-transaction*) + (auto-commit *auto-commit*) + &allow-other-keys) + (declare (ignore args)) + (buffer-write-int (oid ht) *key-buf*) + (let ((key-length (serialize key *key-buf*))) + (db-delete-buffered (db *store-controller*) + (buffer-stream-buffer *key-buf*) key-length + :transaction transaction + :auto-commit auto-commit)))

1 0

[elephant-cvs] CVS update: elephant/src/controller.lisp
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23899/src Modified Files: controller.lisp Log Message: the great simplification effort - specials Date: Thu Aug 26 19:58:09 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.1.1.1 elephant/src/controller.lisp:1.2 --- elephant/src/controller.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004 +++ elephant/src/controller.lisp Thu Aug 26 19:58:09 2004 @@ -1,21 +1,14 @@ (in-package "ELEPHANT") -(defparameter *store-controller* nil - "The default store controller which persistent objects talk to.") - (defclass store-controller () - ((path :reader path + ((path :type (or pathname string) + :reader path :initarg :path) - (environment :accessor environment) + (environment :type (or null pointer-void) :accessor environment) + (db :type (or null pointer-void) :accessor db) (root :accessor root) - ;(oid-counter :reader oid-counter) - (persistent-classes :accessor persistent-classes - :initform (make-hash-table)) - (collections :accessor collections - :initform (make-hash-table :test 'eql)) (instance-cache :accessor instance-cache - :initform (make-hash-table :test 'eql)) - (dbs :accessor dbs :initform nil)) + :initform (make-cache-table :test 'eql))) (:documentation "Class of objects responsible for handling the book-keeping of holding DB handles, the cache, table creation, counters, locks, the root and garbage collection, @@ -33,112 +26,58 @@ "Get a persistent thing from the root." (get-value key (root sc))) -(defmethod register-class-slots ((sc store-controller) class slots) - "Register a user-defined subclass of persistent-class with -the controller." - (setf (gethash class (persistent-classes sc)) slots)) - -(defmethod register-class-slots (sc class slots) - nil) - -(defmethod register-collection ((sc store-controller) col) - "Register a collection instance with the controller." - (setf (gethash (oid col) (collections sc)) col)) - -(defmethod register-instance ((sc store-controller) obj) +(defmethod cache-instance ((sc store-controller) obj) "Register an instance of a user persistent-class with the controller." - (setf (gethash (oid obj) (instance-cache sc)) obj)) + (setf (get-cache (oid obj) (instance-cache sc)) obj)) -(defmethod open-controller ((sc store-controller) &key recover) +(defmethod get-cached-instance ((sc store-controller) oid class-name) + (let ((obj (get-cache oid (instance-cache sc) nil))) + (if obj obj + ;; Should get cached since make-instance calls cache-instance + (make-instance class-name :from-oid oid)))) + +(defmethod open-controller ((sc store-controller)) "Opens the underlying environment and all the necessary -database tables. Initializes registered persistent-classes." - (let ((env (db-create-environment))) +database tables." + (let ((env (db-env-create))) ;; thread stuff? - (db-open-environment env (path sc) :create t :recover recover) (setf (environment sc) env) - (let ((root (make-instance 'p-btree :from-oid -1 - :store-controller sc))) - (setf (root sc) root) - (initialize-classes sc) - sc))) - -(defmethod initialize-classes ((sc store-controller)) - "Setup class slots which point to the tables which store -the persisted slots. This is hacky because i don't know how -to set the class-slots of a class without an instance" - (loop for pclass being the hash-key in (persistent-classes sc) using (hash-value slots) - for obj = (make-instance pclass :from-oid -1 :store-controller sc) - do - (remhash -1 (instance-cache sc)) - (loop for slot in slots - for db = (create-table sc (concatenate 'string "CLASS:" - (symbol-name pclass)) - (symbol-name slot) - :type :btree) - do (setf (slot-value obj slot) db)))) + (db-env-open env (path sc) :create t :init-txn t :init-lock t + :init-mpool t :init-log t :thread t :recover-fatal t) + (let ((db (db-create env))) + (setf (db sc) db) + (db-open db :auto-commit t :type DB-BTREE :create t :thread t) + (let ((root (make-instance 'btree :from-oid -1))) + (setf (root sc) root) + sc)))) (defmethod close-controller ((sc store-controller)) "Close the db handles and environment. Tries to wipe out references to the db handles." ; no root (setf (root sc) nil) - ; clean collections - (maphash #'(lambda (k v) (declare (ignore k)) - (setf (db v) nil)) - (collections sc)) - (setf (collections sc) (make-hash-table :test 'eql)) - ; clean classes - (deinitialize-classes sc) - ;(setf (persistent-classes sc) (make-hash-table)) - ; close dbs - (mapc #'(lambda (v) (db-close v)) (dbs sc)) - (setf (dbs sc) nil) ; clean instance cache - (setf (instance-cache sc) (make-hash-table :test 'eql)) + (setf (instance-cache sc) (make-cache-table :test 'eql)) ; close environment - (db-close (environment sc)) + (db-close (db sc)) + (setf (db sc) nil) + (db-env-close (environment sc)) (setf (environment sc) nil) - t) - -(defmethod deinitialize-classes ((sc store-controller)) - (loop for pclass being the hash-key in (persistent-classes sc) using (hash-value slots) - for obj = (make-instance pclass :from-oid -1) - do - (remhash -1 (instance-cache sc)))) - -;; diked out, since our new methodology doesn't allow this -;; (loop for slot in slots -;; do (setf obj slot nil)))) - -(defmethod create-table ((sc store-controller) file name &rest args) - (let ((db (db-create :environment (environment sc)))) - (apply #'db-open `(,db ,file ,name :create t :auto-commit t ,@args)) - (push db (dbs sc)) - db)) - -(defmethod get-instance ((sc store-controller) oid classname) - (let ((obj (gethash oid (instance-cache sc) nil))) - (if obj obj - (setf (gethash oid (instance-cache sc)) - (make-instance (find-class (intern classname)) - :from-oid oid))))) - -(defmethod get-collection ((sc store-controller) oid class) - (gethash oid (collections sc) - :default (make-instance class :from-oid oid))) - -(defconstant max-oid (- (expt 2 64) 1)) - -(defmethod next-oid ((sc store-controller)) - (random max-oid)) + nil) -(defmacro with-open-controller ((&optional (sc *store-controller*) - &key recover) +(defmacro with-open-controller ((&optional (sc *store-controller*)) &body body) `(unwind-protect (progn - (open-controller ,sc :recover ,recover) + (open-controller ,sc) ,@body) (close-controller ,sc))) + +;; This stuff is all a hack until sequences appear in Sleepycat 4.3 +(defconstant max-oid most-positive-fixnum) + +(defmethod next-oid ((sc store-controller)) + (random max-oid)) +

1 0

[elephant-cvs] CVS update: elephant/src/elephant.lisp
by blee＠common-lisp.net 27 Aug '04

27 Aug '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23879/src Modified Files: elephant.lisp Log Message: weak hashes Date: Thu Aug 26 19:57:52 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.1.1.1 elephant/src/elephant.lisp:1.2 --- elephant/src/elephant.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004 +++ elephant/src/elephant.lisp Thu Aug 26 19:57:52 2004 @@ -1,10 +1,80 @@ (defpackage elephant (:nicknames ele :ele) (:use common-lisp sleepycat) - #+cmu - (:shadowing-import-from PCL find-class class-name built-in-class class-of) - (:export *store-controller* store-controller - open-controller close-controller with-open-controller - persistent persistent-class def-persistent-class - serialize deserialize add-deserializer - *current-transaction* with-transaction with-transaction-retries)) + (:export *store-controller* *current-transaction* *auto-commit* + store-controller open-controller close-controller + with-open-controller + persistent persistent-object persistent-metaclass + with-transaction with-transaction-retry) + #+cmu + (:import-from :pcl + slot-definition-name + compute-slots) + ;; Hopefully SBCL = CMUCL except for package names (both using Gerd's PCL) + #+sbcl + (:import-from :sb-mop + slot-definition-name + compute-slots) + #+openmcl + (:import-from :openmcl-mop + slot-definition-name + compute-slots) + #+allegro + (:import-from :clos + slot-definition-name + compute-slots) + #+lispworks + (:import-from :clos + slot-definition-name + compute-slots) + + ) + +(in-package "ELEPHANT") + +;; Thread-local specials which control Elephant + +(defparameter *store-controller* nil + "The store controller which persistent objects talk to.") +(defvar *auto-commit* nil) + + +;; Portable value-weak hash-tables for the cache: when the +;; values are collected, the entries (keys) should be +;; flushed from the table too + +(defun make-cache-table (&rest args) + #+(or cmu sbcl scl) + (apply #'make-hash-table args) + #+allegro + (apply #'make-hash-table :values :weak args) + #+lispworks + (apply #'make-hash-table :weak-kind :value args) + #-(or cmu sbcl scl allegro lispworks) + (apply #'make-hash-table args) + ) + +(defun get-cache (key cache) + #+(or cmu sbcl scl) + (let ((val (gethash key cache))) + (if val (values (weak-pointer-value val) t) + (values nil nil))) + #-(or cmu sbcl scl) + (gethash key cache) + ) + +(defun setf-cache (key cache value) + #+(or cmu sbcl scl) + (let ((w (make-weak-pointer value))) + (finalize value #'(lambda () (remhash key cache))) + (setf (gethash key cache) w) + value) + #+allegro + (progn + (excl:schedule-finalization value #'(lambda () (remhash key cache))) + (setf (gethash key cache) value)) + #-(or cmu sbcl scl allegro) + (setf (gethash key cache) value) + ) + +(defsetf get-cache setf-cache)

1 0