From blee at common-lisp.net Thu Aug 19 17:01:25 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 19 Aug 2004 10:01:25 -0700 Subject: [elephant-cvs] CVS update: Module imported: src Message-ID: Update of /project/elephant/cvsroot//src In directory common-lisp.net:/home/blee/elephant/src Log Message: Start Status: Vendor Tag: elephant Release Tags: start N src/classes.lisp N src/collections.lisp N src/controller.lisp N src/elephant.lisp N src/serializer.lisp N src/sleepycat.lisp N src/libsleepycat.c No conflicts created by this import Date: Thu Aug 19 10:01:22 2004 Author: blee New module src added From blee at common-lisp.net Thu Aug 19 17:05:15 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 19 Aug 2004 10:05:15 -0700 Subject: [elephant-cvs] CVS update: Module imported: elephant Message-ID: Update of /project/elephant/cvsroot//elephant In directory common-lisp.net:/home/blee/test Log Message: Start Status: Vendor Tag: elephant Release Tags: start N elephant/src/classes.lisp N elephant/src/collections.lisp N elephant/src/controller.lisp N elephant/src/elephant.lisp N elephant/src/serializer.lisp N elephant/src/sleepycat.lisp N elephant/src/libsleepycat.c No conflicts created by this import Date: Thu Aug 19 10:05:15 2004 Author: blee New module elephant added From blee at common-lisp.net Fri Aug 27 02:53:53 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 26 Aug 2004 19:53:53 -0700 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23599/src Modified Files: classes.lisp Log Message: new MOP stuff Date: Thu Aug 26 19:53:52 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.1.1.1 elephant/src/classes.lisp:1.2 --- elephant/src/classes.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004 +++ elephant/src/classes.lisp Thu Aug 26 19:53:52 2004 @@ -1,35 +1,26 @@ +;; TODO: slot-bound-p (check the database) + (in-package "ELEPHANT") (defclass persistent () ((%oid :accessor oid - :initarg :from-oid) - (%oid-string :accessor oid-string) - (%store-controller :allocation :class - :accessor get-store-controller - :initform *store-controller* - :initarg :store-controller) - (%class-name :type string :accessor %class-name - :allocation :class) - (%persistent-slots)) + :initarg :from-oid)) (:documentation "Abstract superclass for all persistent classes (common -to user-defined classes and collections.)" )) +to user-defined classes and collections.)")) (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid) (declare (ignore initargs)) - "Sets the OID, OID-STRING and registers with the store controller." - (let ((sc (get-store-controller instance))) - (setf (%class-name instance) (string (class-name (class-of instance)))) - (if (not from-oid) - (setf (oid instance) (next-oid sc)) + "Sets the OID." + (if (not from-oid) + (setf (oid instance) (next-oid *store-controller*)) (setf (oid instance) from-oid)) - (setf (oid-string instance) - (prin1-to-string (oid instance))) - (register-instance sc instance))) + (cache-instance *store-controller* instance)) -(defclass persistent-class (persistent) () +(defclass persistent-object (persistent) + ((%persistent-slots)) (:documentation "Superclass of all user-defined persistent classes")) @@ -46,7 +37,7 @@ ()) (defmethod pcl::slot-definition-allocation ((slot-definition persistent-slot-definition)) - :class) + :instance) (defmethod (setf pcl::slot-definition-allocation) (value (slot-definition persistent-slot-definition)) (declare (ignore value)) @@ -55,10 +46,9 @@ (defmethod pcl::initialize-internal-slot-functions ((slot persistent-slot-definition)) nil) -(defmethod pcl::direct-slot-definition-class ((class persistent-metaclass) initargs) +(defmethod pcl::direct-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((allocation-key (getf initargs :allocation))) - (cond ((or (eq allocation-key :transient) - (eq allocation-key :class)) + (cond ((eq allocation-key :class) (call-next-method)) (t (find-class 'persistent-direct-slot-definition))))) @@ -66,12 +56,68 @@ (defmethod pcl:validate-superclass ((class elephant::persistent-metaclass) (super pcl::standard-class)) t) -(defmethod pcl::effective-slot-definition-class ((class persistent-metaclass) initargs) - (let ((allocation (getf initargs :allocation))) - (if (eq allocation :persistent) - (find-class 'persistent-effective-slot-definition) - (call-next-method)))) +(defmethod persistent-p ((class t)) + nil) + +(defmethod persistent-p ((class persistent-metaclass)) + t) + +(defmethod pcl::effective-slot-definition-class ((class persistent-metaclass) &rest initargs) + (let ((allocation-key (getf initargs :allocation)) + (allocation-class (getf initargs :allocation-class))) + (cond ((eq allocation-key :class) + (call-next-method)) + ((not (persistent-p allocation-class)) + (call-next-method)) + (t + (find-class 'persistent-effective-slot-definition))))) +(defmacro make-persistent-reader (name) + `(lambda (instance) + (declare (type persistent instance)) + (buffer-write-int (oid instance) *key-buf*) + (let ((key-length (serialize ,name *key-buf*))) + (handler-case + (deserialize (db-get-key-buffered (db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length)) + (db-error (err) + (if (= (db-error-errno err) DB_NOTFOUND) + (error 'unbound-slot :instance instance :slot ,name) + (error err))))))) + +(defmacro make-persistent-writer (name) + `(lambda (new-value instance) + (declare (type persistent instance)) + (buffer-write-int (oid instance) *key-buf*) + (let ((key-length (serialize ,name *key-buf*)) + (val-length (serialize new-value *out-buf*))) + (db-put-buffered (db *store-controller*) + (buffer-stream-buffer *key-buf*) key-length + (buffer-stream-buffer *out-buf*) val-length + :transaction *current-transaction* + :auto-commit *auto-commit*)))) + +#| +(defmethod pcl::compute-slots :around ((class persistent-metaclass)) + (call-next-method)) +|# + +(defmethod handle-optimized-accessors ((slot-def t)) + slot-def) + +(defmethod handle-optimized-accessors ((slot-def persistent-slot-definition)) + (let ((name (pcl::slot-definition-name slot-def))) + (setf (pcl::slot-definition-reader-function slot-def) + (make-persistent-reader name)) + (setf (pcl::slot-definition-writer-function slot-def) + (make-persistent-writer name))) + slot-def) + +(defmethod pcl::compute-effective-slot-definition ((class persistent-metaclass) name direct-slot-definitions) + (let ((object (call-next-method))) + (handle-optimized-accessors object))) + (defun persistent-slot-names (class) (let ((slot-definitions (pcl::class-slots class))) (loop for slot-definition in slot-definitions @@ -82,63 +128,16 @@ (let* ((persistent-metaclass (find-class 'persistent-metaclass)) (not-already-persistent (loop for superclass in direct-superclasses never (eq (class-of superclass) persistent-metaclass)))) - (prog1 - (if not-already-persistent - (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-class) direct-superclasses) args) - (call-next-method)) - (register-class-slots *store-controller* (class-name class) (persistent-slot-names class))))) + (if not-already-persistent + (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) + (call-next-method)))) -(defmethod pcl::slot-value-using-class :around (class (instance persistent-class) (slot-def persistent-slot-definition)) +(defmethod pcl::slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (let ((slot-name (pcl::slot-definition-name slot-def))) - (let ((db-slot-name (call-next-method))) - (if db-slot-name - (deserialize (db-get db-slot-name - (oid-string instance)) - *store-controller*) - nil)))) + (format *standard-output* "Deserializing ~A ~%" slot-name))) -(defmethod (setf pcl::slot-value-using-class) :around (new-value class (instance persistent-class) (slot-def persistent-slot-definition)) +(defmethod (setf pcl::slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) (let ((slot-name (pcl::slot-definition-name slot-def))) - (let ((db-slot-name (slot-value-using-class class instance slot-def))) - (if db-slot-name - (%db-put db-slot-name - (oid-string instance) (serialize new-value) - :transaction *transaction*) - (call-next-method))))) - -;;; Need a delete class method! here's a first cut. -;;; however this method begs the question as to what the -;;; right transaction API is! (this can't be right!) + (format *standard-output* "Serializing ~A into ~A ~%" new-value slot-name))) -#| -(defmethod delete ((obj persistent-class) &key transaction parent) - "Remove object from the database. Transaction protected." - (if transaction - (use-transaction (transaction) - (loop for slot in (%persistent-slots obj) - with slot-name = (if (listp slot) (first slot) - slot) - do (%db-remove (db-slot slot-name obj) (oid-string obj)))) - (with-transaction (parent :environment ???) - delete-stuff))) - -(defun db-slot (slotname obj) - (funcall (symbol-function (db-slot-from-slot slotname)) obj)) - -|# -;;; These need to be fixed, macro-fied? -;;; meant to check for a transaction, do auto-commit otherwise -;;; this is necessary for transaction protected DB handles - -(defun %db-put (db key value &rest args &key (transaction *transaction*) - &allow-other-keys) - (if transaction - (apply #'db-put db key value :transaction transaction args) - (apply #'db-put db key value :auto-commit t args))) - -(defun %db-remove (db key &rest args &key (transaction *transaction*) - &allow-other-keys) - (if transaction - (apply #'db-delete db key :transaction transaction args) - (apply #'db-delete db key :auto-commit t args))) \ No newline at end of file From blee at common-lisp.net Fri Aug 27 02:54:40 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 26 Aug 2004 19:54:40 -0700 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23640/src Modified Files: sleepycat.lisp Log Message: beginning of lock and cursor support Date: Thu Aug 26 19:54:39 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.1.1.1 elephant/src/sleepycat.lisp:1.2 --- elephant/src/sleepycat.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004 +++ elephant/src/sleepycat.lisp Thu Aug 26 19:54:38 2004 @@ -12,44 +12,83 @@ (defpackage sleepycat (:use common-lisp uffi) - (:export write-int write-unsigned-int write-double - read-int read-unsigned-int read-double copy-str-to-buf - *current-transaction* + (:export read-int read-uint read-float read-double + write-int write-uint write-float write-double + offset-char-pointer copy-str-to-buf copy-bufs byte-length pointer-int pointer-void array-or-pointer-char db-env-create db-env-close db-env-open db-env-dbremove - db-env-dbrename db-env-remove db-create db-close db-open + db-env-dbrename db-env-remove db-env-set-flags + db-env-get-flags + db-create db-close db-open db-remove db-rename db-sync db-truncate db-get-key-buffered db-get-buffered db-get db-put-buffered db-put db-delete-buffered db-delete + *current-transaction* db-transaction-begin db-transaction-abort db-transaction-commit with-transaction with-transaction-retry - db-error - DBTYPE#BTREE DBTYPE#HASH DBTYPE#QUEUE DBTYPE#RECNO - DBTYPE#UNKNOWN +NULL-VOID+ +NULL-CHAR+)) + db-transaction-id db-env-lock-id db-env-lock-id-free + db-env-set-timeout db-env-get-timeout + db-env-set-lock-detect db-env-get-lock-detect + DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN + +NULL-VOID+ +NULL-CHAR+ + db-error db-error-errno + DB_KEYEMPTY DB_LOCK_DEADLOCK DB_LOCK_NOTGRANTED DB_NOTFOUND + )) (in-package "SLEEPYCAT") (eval-when (:compile-toplevel :load-toplevel) (def-type pointer-int (* :int)) (def-type pointer-void :pointer-void) - (def-foreign-type array-or-pointer-char + (def-foreign-type array-or-pointer-char #+allegro (:array :char) - #-allegro (* :char)) + #+(or cmu sbcl scl) (* :char)) (def-type array-or-pointer-char array-or-pointer-char) + (def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN)) ) -(declaim (inline write-int write-unsigned-int write-double - read-int read-unsigned-int read-double copy-buf - %db-get-raw db-get-key-buffered db-get-buffered db-get - %db-put-raw db-put-buffered db-put +(declaim (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-bufs + %db-get-key-buffered db-get-key-buffered + %db-get-buffered db-get-buffered db-get + %db-put-buffered db-put-buffered + %db-put db-put %db-delete db-delete-buffered db-delete - %db-env-txn-begin db-transaction-begin - %db-env-txn-begin2 db-transaction-begin2 + %db-txn-begin db-transaction-begin %db-txn-abort db-transaction-abort %db-txn-commit db-transaction-commit flags)) -;; Pointer arithmetic utility functions +;; Buffer management / pointer arithmetic + +;; Notes: on CMUCL and Allegro: with-cast-pointer + +;; deref-array is faster than FFI + C pointer arithmetic. +;; however pointer arithmetic is usually consing. OpenMCL +;; supports non-consing pointer arithmentic though. + + +;; TODO: #+openmcl versions which do macptr arith. + +(def-function ("read_int" read-int) + ((buf array-or-pointer-char) + (offset :int)) + :returning :int) + +(def-function ("read_uint" read-uint) + ((buf array-or-pointer-char) + (offset :int)) + :returning :unsigned-int) + +(def-function ("read_float" read-float) + ((buf array-or-pointer-char) + (offset :int)) + :returning :float) + +(def-function ("read_double" read-double) + ((buf array-or-pointer-char) + (offset :int)) + :returning :double) (def-function ("write_int" write-int) ((buf array-or-pointer-char) @@ -57,33 +96,50 @@ (offset :int)) :returning :void) -(def-function ("write_uint" write-unsigned-int) +(def-function ("write_uint" write-uint) ((buf array-or-pointer-char) (num :unsigned-int) (offset :int)) :returning :void) -(def-function ("write_double" write-double) +(def-function ("write_float" write-float) ((buf array-or-pointer-char) - (num :double) + (num :float) (offset :int)) :returning :void) -(def-function ("read_int" read-int) +(def-function ("write_double" write-double) ((buf array-or-pointer-char) + (num :double) (offset :int)) - :returning :int) + :returning :void) -(def-function ("read_uint" read-uint) - ((buf array-or-pointer-char) +(def-function ("offset_charp" offset-char-pointer) + ((p array-or-pointer-char) (offset :int)) - :returning :unsigned-int) + :returning array-or-pointer-char) -(def-function ("read_double" read-double) - ((buf array-or-pointer-char) - (offset :int)) - :returning :double) +;; Allegro and Lispworks use 16-bit unicode characters +(defmacro byte-length (s) + #+(or lispworks (and allegro ics)) + `(let ((l (length ,s))) (+ l l)) + #-(or lispworks (and allegro ics)) + `(length ,s)) + +;; for copying the bytes of a string to a foreign buffer +;; memcpy is faster than looping! For Lispworks this causes +;; a string to array conversion, but I don't know how to do +;; any better (fli:replace-foreign-array is promising?) +#-(or cmu sbcl scl openmcl) +(def-function ("copy_buf" copy-str-to-buf) + ((dest array-or-pointer-char) + (dest-offset :int) + (src array-or-pointer-char) + (src-offset :int) + (length :int)) + :returning :void) +#+(or cmu sbcl scl) (def-function ("copy_buf" copy-str-to-buf) ((dest array-or-pointer-char) (dest-offset :int) @@ -92,6 +148,48 @@ (length :int)) :returning :void) +;; but OpenMCL can't directly pass string bytes. +#+openmcl +(defun copy-str-to-buf (dest dest-offset src src-offset length) + (declare (optimize (speed 3) (safety 0)) + (type string src) + (type array-or-pointer-char dest) + (type fixnum length src-offset dest-offset) + (dynamic-extent src dest length)) + (multiple-value-bind (ivector disp) + (ccl::array-data-and-offset src) + (ccl::%copy-ivector-to-ptr src (+ disp src-offset) + dest dest-offset length))) + +;; Lisp version, for kicks. this assumes 8-bit chars! +#+(not (or cmu sbcl scl allegro openmcl lispworks)) +(defun copy-str-to-buf (dest dest-offset src src-offset length) + (declare (optimize (speed 3) (safety 0)) + (type string src) + (type array-or-pointer-char dest) + (type fixnum length src-offset dest-offset) + (dynamic-extent src dest length)) + (typecase src + (simple-string + (loop for i fixnum from 0 below length + do + (setf (deref-array dest 'array-or-pointer-char (+ i dest-offset)) + (char-code (schar src (+ i src-offset)))))) + (string + (loop for i fixnum from 0 below length + do + (setf (deref-array dest 'array-or-pointer-char (+ i dest-offset)) + (char-code (char src (+ i src-offset)))))))) + +;; For copying two foreign buffers +(def-function ("copy_buf" copy-bufs) + ((dest array-or-pointer-char) + (dest-offset :int) + (src array-or-pointer-char) + (src-offset :int) + (length :int)) + :returning :void) + ;; Thread local storage (special variables) (defconstant +NULL-VOID+ (make-null-pointer :void)) @@ -101,16 +199,14 @@ (defvar *errno-buffer* (allocate-foreign-object :int 1)) -(declaim (type array-or-pointer-char *get-buffer* *key-buffer*) - (type fixnum *get-buffer-length* *key-buffer-length*)) +(declaim (type array-or-pointer-char *get-buffer*) + (type fixnum *get-buffer-length*)) -(defvar *get-buffer*) -(setq *get-buffer* (allocate-foreign-object :char 1)) +(defvar *get-buffer* (allocate-foreign-object :char 1)) (defvar *get-buffer-length* 0) -(defun resize-get-buffer (buf length) +(defun resize-get-buffer (length) (declare (optimize (speed 3) (safety 0) (space 0)) - (ignore buf) (type fixnum length)) (if (< length *get-buffer-length*) (values *get-buffer* *get-buffer-length*) @@ -121,32 +217,6 @@ (setq *get-buffer* (allocate-foreign-object :char newlen)) (values *get-buffer* *get-buffer-length*)))) -(defvar *key-buffer*) -(setq *key-buffer* (allocate-foreign-object :char 1)) -(defvar *key-buffer-length* 0) - -(defun resize-key-buffer (buf length) - (declare (optimize (speed 3) (safety 0) (space 0)) - (ignore buf) - (type fixnum length)) - (if (< length *key-buffer-length*) - (values *key-buffer* *key-buffer-length*) - (let ((newlen (max length (* *key-buffer-length* 2)))) - (declare (type fixnum newlen)) - (setq *key-buffer-length* newlen) - (free-foreign-object *key-buffer*) - (setq *key-buffer* (allocate-foreign-object :char newlen)) - (values *key-buffer* *key-buffer-length*)))) - -(defun fill-key-buffer (key &key (key-length (length key))) - (declare (optimize (speed 3) (safety 0) (space 0)) - (type string key) - (type fixnum key-length) - (dynamic-extent key-length)) - (when (< *key-buffer-length* key-length) (resize-key-buffer nil key-length)) - (with-cstring (k key) - (copy-str-to-buf *key-buffer* 0 k 0 key-length))) - ;; Wrapper macro -- handles errno return values ;; makes flags into keywords ;; makes keyword args, cstring wrappers @@ -245,10 +315,10 @@ :returning :int) (wrap-errno db-env-open (dbenvp home flags mode) - :flags (db-joinenv db-init-cdb db-init-lock db-init-log - db-init-mpool db-init-rep db-init-txn - db-recover db-recover-fatal db-create - db-lockdown db-private db-system-mem db-thread) + :flags (joinenv init-cdb init-lock init-log + init-mpool init-rep init-txn + recover recover-fatal create + lockdown private system-mem thread) :keys ((mode #o640)) :cstrings (home)) @@ -287,9 +357,26 @@ (flags :unsigned-int)) :returning :int) -(wrap-errno db-env-remove (env home flags) :flags (db-force) +(wrap-errno db-env-remove (env home flags) :flags (force) :cstrings (home)) +(def-function ("db_env_set_flags" %db-env-set-flags) + ((env :pointer-void) + (flags :unsigned-int) + (onoff :int)) + :returning :int) + +(wrap-errno db-env-set-flags (env flags onoff) + :flags (auto-commit nommap txn-nosync)) + +(def-function ("db_env_get_flags" %db-env-get-flags) + ((env :pointer-void) + (flags :unsigned-int :out)) + :returning :int) + +(wrap-errno db-env-get-flags (env) :outs 2) + + ;; Database (def-function ("db_cr" %db-create) @@ -313,8 +400,6 @@ (wrap-errno db-close (db flags)) -(def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN)) - (def-function ("db_open" %db-open) ((db :pointer-void) (txn :pointer-void) @@ -326,12 +411,12 @@ :returning :int) (wrap-errno db-open (db transaction file database type flags mode) - :flags (auto-commit db-create db-dirty-read db-excl db-nommap - db-rdonly db-thread db-truncate) + :flags (auto-commit create dirty-read excl nommap + rdonly thread truncate) :keys ((transaction *current-transaction*) (file +NULL-CHAR+) (database +NULL-CHAR+) - (type DBTYPE#UNKNOWN) + (type DB-UNKNOWN) (mode #o640)) :cstrings (file database)) @@ -388,36 +473,30 @@ (result-length :unsigned-int :out)) :returning :int) -(defun db-get-key-buffered (db &key - (key-buffer *key-buffer*) - (key-length *key-buffer-length*) - (buffer *get-buffer*) - (buffer-length *get-buffer-length*) - (resize-function #'resize-get-buffer) - (transaction *current-transaction*) - auto-commit db-get-both db-dirty-read) +(defun db-get-key-buffered (db key-buffer key-length &key + (transaction *current-transaction*) + auto-commit get-both dirty-read) (declare (optimize (speed 3) (safety 0) (space 0)) (type pointer-void db transaction) - (type array-or-pointer-char key-buffer buffer) - (type fixnum key-length buffer-length) - (type boolean auto-commit db-get-both db-dirty-read)) + (type array-or-pointer-char key-buffer) + (type fixnum key-length) + (type boolean auto-commit get-both dirty-read)) (loop do (multiple-value-bind (errno result-length) (%db-get-key-buffered db transaction key-buffer key-length - buffer buffer-length + *get-buffer* *get-buffer-length* (flags :auto-commit auto-commit - :db-get-both db-get-both - :db-dirty-read db-dirty-read)) + :get-both get-both + :dirty-read dirty-read)) (declare (type fixnum result-length errno)) - (if (<= result-length buffer-length) + (if (<= result-length *get-buffer-length*) (if (= errno 0) (return-from db-get-key-buffered (the (values array-or-pointer-char fixnum) - (values buffer result-length))) + (values *get-buffer* result-length))) (error 'db-error :errno errno)) - (multiple-value-setq (buffer buffer-length) - (funcall resize-function buffer result-length)))))) + (resize-get-buffer result-length))))) (def-function ("db_get_raw" %db-get-buffered) ((db :pointer-void) @@ -432,66 +511,57 @@ (defun db-get-buffered (db key &key (key-length (length key)) - (buffer *get-buffer*) - (buffer-length *get-buffer-length*) - (resize-function #'resize-get-buffer) (transaction *current-transaction*) - auto-commit db-get-both db-dirty-read) + auto-commit get-both dirty-read) (declare (optimize (speed 3) (safety 0) (space 0)) (type pointer-void db transaction) (type string key) - (type array-or-pointer-char buffer) - (type fixnum key-length buffer-length) - (type boolean auto-commit db-get-both db-dirty-read)) + (type fixnum key-length) + (type boolean auto-commit get-both dirty-read)) (with-cstring (k key) (loop do (multiple-value-bind (errno result-length) (%db-get-buffered db transaction k key-length - buffer buffer-length + *get-buffer* *get-buffer-length* (flags :auto-commit auto-commit - :db-get-both db-get-both - :db-dirty-read db-dirty-read)) + :get-both get-both + :dirty-read dirty-read)) (declare (type fixnum result-length errno)) - (if (<= result-length buffer-length) + (if (<= result-length *get-buffer-length*) (if (= errno 0) (return-from db-get-buffered (the (values array-or-pointer-char fixnum) - (values buffer result-length))) + (values *get-buffer* result-length))) (error 'db-error :errno errno)) - (multiple-value-setq (buffer buffer-length) - (funcall resize-function buffer result-length))))))) + (resize-get-buffer result-length)))))) (defun db-get (db key &key (key-length (length key)) - (buffer *get-buffer*) - (buffer-length *get-buffer-length*) - (resize-function #'resize-get-buffer) (transaction *current-transaction*) - auto-commit db-get-both db-dirty-read) + auto-commit get-both dirty-read) (declare (optimize (speed 3) (safety 0) (space 0)) (type pointer-void db transaction) (type string key) - (type array-or-pointer-char buffer) - (type fixnum key-length buffer-length) - (type boolean auto-commit db-get-both db-dirty-read)) + (type fixnum key-length) + (type boolean auto-commit get-both dirty-read)) (with-cstring (k key) (loop do (multiple-value-bind (errno result-length) (%db-get-buffered db transaction k key-length - buffer buffer-length + *get-buffer* *get-buffer-length* (flags :auto-commit auto-commit - :db-get-both db-get-both - :db-dirty-read db-dirty-read)) + :get-both get-both + :dirty-read dirty-read)) (declare (type fixnum result-length errno)) - (if (<= result-length buffer-length) + (if (<= result-length *get-buffer-length*) (if (= errno 0) (return-from db-get - (convert-from-foreign-string buffer :length result-length + (convert-from-foreign-string *get-buffer* + :length result-length :null-terminated-p nil)) (error 'db-error :errno errno)) - (multiple-value-setq (buffer buffer-length) - (funcall resize-function buffer result-length))))))) + (resize-get-buffer result-length)))))) (def-function ("db_put_raw" %db-put-buffered) ((db :pointer-void) @@ -573,7 +643,7 @@ ;; Transactions -(def-function ("db_env_txn_begin" %db-env-txn-begin) +(def-function ("db_txn_begin" %db-txn-begin) ((env :pointer-void) (parent :pointer-void) (flags :unsigned-int) @@ -581,20 +651,20 @@ :returning :pointer-void) (defun db-transaction-begin (env &key (parent *current-transaction*) - db-dirty-read db-txn-nosync db-txn-nowait - db-txn-sync) + dirty-read txn-nosync txn-nowait + txn-sync) (declare (optimize (speed 3) (safety 0) (space 0)) (type pointer-void env parent) - (type boolean db-dirty-read db-txn-nosync db-txn-nowait - db-txn-sync) + (type boolean dirty-read txn-nosync txn-nowait + txn-sync) (type pointer-int *errno-buffer*)) (let* ((txn - (%db-env-txn-begin env parent - (flags :db-dirty-read db-dirty-read - :db-txn-nosync db-txn-nosync - :db-txn-nowait db-txn-nowait - :db-txn-sync db-txn-sync) - *errno-buffer*)) + (%db-txn-begin env parent + (flags :dirty-read dirty-read + :txn-nosync txn-nosync + :txn-nowait txn-nowait + :txn-sync txn-sync) + *errno-buffer*)) (errno (deref-array *errno-buffer* '(:array :int) 0))) (declare (type pointer-void txn) (type fixnum errno)) @@ -618,51 +688,71 @@ (wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags) :keys ((transaction *current-transaction*)) - :flags (db-txn-nosync db-txn-sync) + :flags (txn-nosync txn-sync) :declarations (declare (optimize (speed 3) (safety 0) (space 0)) (type pointer-void transaction) - (type boolean db-txn-nosync db-txn-sync))) + (type boolean txn-nosync txn-sync))) (defmacro with-transaction ((&key transaction environment (globally t) (parent *current-transaction*) - db-dirty-read db-txn-nosync - db-txn-nowait db-txn-sync) + dirty-read txn-nosync + txn-nowait txn-sync) &body body) - (let ((last-transaction (gensym)) - (txn (if transaction transaction (gensym))) + (let ((txn (if transaction transaction (gensym))) (success (gensym))) - `(let (,@(if globally `(,last-transaction *current-transaction*) - (values)) - (,txn (db-transaction-begin ,environment - :parent ,parent - :db-dirty-read ,db-dirty-read - :db-txn-nosync ,db-txn-nosync - :db-txn-nowait ,db-txn-nowait - :db-txn-sync ,db-txn-sync)) - (,success nil)) + `(let* ((,txn (db-transaction-begin ,environment + :parent ,parent + :dirty-read ,dirty-read + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync)) + (,success nil) + ,@(if globally `((*current-transaction* ,txn)) + (values))) + (declare (dynamic-extent ,txn ,success) + (type pointer-void ,txn) + (type boolean ,success)) (unwind-protect - (progn - ,@(if globally `((setq *current-transaction* ,txn)) - (values)) - (prog1 - (progn , at body) - (setq ,success t) - (db-transaction-commit :transaction ,txn - :db-txn-nosync ,db-txn-nosync - :db-txn-sync ,db-txn-sync))) - (progn - ,@(if globally - `((setq *current-transaction* ,last-transaction)) - (values)) - (unless ,success (db-transaction-abort :transaction ,txn))))))) + (prog1 + (progn , at body) + (setq ,success t) + (db-transaction-commit :transaction ,txn + :txn-nosync ,txn-nosync + :txn-sync ,txn-sync)) + (unless ,success (db-transaction-abort :transaction ,txn)))))) + +;; this is code for a non-consing with-transaction. which +;; doesn't work in the (globally t) case (e.g. setting +;; *current-transaction*.) + +; #+cmu +; `(alien:with-alien ((,txn (* t) +; (%db-txn-begin +; ,environment ,parent +; (flags :dirty-read ,dirty-read +; :txn-nosync ,txn-nosync +; :txn-nowait ,txn-nowait +; :txn-sync ,txn-sync) +; *errno-buffer*))) +; (let ((,success nil) +; ,@(if globally `((*current-transaction* ,txn)) (values))) +; (declare (type pointer-void *current-transaction*) +; (dynamic-extent *current-transaction*)) +; (unwind-protect +; (prog1 (progn , at body) +; (setq ,success t) +; (%db-txn-commit ,txn +; (flags :txn-nosync ,txn-nosync +; :txn-sync ,txn-sync))) +; (unless ,success (%db-txn-abort ,txn))))))) (defmacro with-transaction-retry ((&key transaction environment (globally t) (parent *current-transaction*) (retries 100) - db-dirty-read db-txn-nosync - db-txn-nowait db-txn-sync) + dirty-read txn-nosync + txn-nowait txn-sync) &body body) (let ((ret-tag (gensym)) (retry-count (gensym))) @@ -673,17 +763,112 @@ :environment ,environment :globally ,globally :parent ,parent - :db-dirty-read ,db-dirty-read - :db-txn-nosync ,db-txn-nosync - :db-txn-nowait ,db-txn-nowait - :db-txn-sync ,db-txn-sync) + :dirty-read ,dirty-read + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync) ,body) (db-error (err) (if (< (incf ,retry-count) ,retries) (go ,ret-tag) (error err)))))))) +;; Locks and timeouts + +(def-enum lockop ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT + :PUT :PUT-ALL :PUT-OBJ :PUT-READ + :TIMEOUT :TRADE :UPGRADE-WRITE)) + +(def-enum lockmode ((:NG 0) :READ :WRITE :WAIT + :IWRITE :IREAD :IWR :DIRTY :WWRITE)) + +(def-struct db-lockreq + (op lockop) + (mode lockmode) + (timeout :unsigned-int) + (obj (:array :char)) + (lock :pointer-void)) + + +(def-function ("db_txn_id" db-transaction-id) + ((transaction :pointer-void)) + :returning :unsigned-int) + + +(def-function ("db_env_lock_id" %db-env-lock-id) + ((env :pointer-void) + (id :unsigned-int :out)) + :returning :int) + +(wrap-errno db-env-lock-id (env) :outs 2) + + +(def-function ("db_env_lock_id_free" %db-env-lock-id-free) + ((env :pointer-void) + (id :unsigned-int)) + :returning :int) + +(wrap-errno db-env-lock-id-free (env id)) + +(def-function ("db_env_set_timeout" %db-env-set-timeout) + ((env :pointer-void) + (timeout :unsigned-int) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-env-set-timeout (env timeout flags) + :flags (set-lock-timeout set-transaction-timeout)) + +(def-function ("db_env_get_timeout" %db-env-get-timeout) + ((env :pointer-void) + (timeout :unsigned-int :out) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-env-get-timeout (env flags) :outs 2 + :flags (set-lock-timeout set-transaction-timeout)) + +(defconstant DB_LOCK_DEFAULT 1) +(defconstant DB_LOCK_EXPIRE 2) +(defconstant DB_LOCK_MAXLOCKS 3) +(defconstant DB_LOCK_MINLOCKS 4) +(defconstant DB_LOCK_MINWRITE 5) +(defconstant DB_LOCK_OLDEST 6) +(defconstant DB_LOCK_RANDOM 7) +(defconstant DB_LOCK_YOUNGEST 8) + +(def-function ("db_env_set_lk_detect" %db-env-set-lock-detect) + ((env :pointer-void) + (detect :unsigned-int)) + :returning :int) + +(wrap-errno db-env-set-lock-detect (env detect)) + +(def-function ("db_env_get_lk_detect" %db-env-get-lock-detect) + ((env :pointer-void) + (detect :unsigned-int :out)) + :returning :int) + +(wrap-errno db-env-get-lock-detect (env) :outs 2) + +(def-function ("db_env_lock_detect" %db-env-lock-detect) + ((env :pointer-void) + (flags :unsigned-int) + (atype :unsigned-int) + (aborted :int :out)) + :returning :int) + +(wrap-errno db-env-lock-detect (env flags atype) :outs 2) + ;; Constants and Flags +;; eventually write a macro which generates a custom flag function. + +;I don't like the UFFI syntax for enumerations +(defconstant DB-BTREE 1) +(defconstant DB-HASH 2) +(defconstant DB-QUEUE 3) +(defconstant DB-RECNO 4) +(defconstant DB-UNKNOWN 5) (defconstant DB_AUTO_COMMIT #x1000000) (defconstant DB_JOINENV #x0040000) @@ -700,7 +885,6 @@ (defconstant DB_SYSTEM_MEM #x0400000) (defconstant DB_THREAD #x0000040) (defconstant DB_FORCE #x0000004) -(defconstant DB_GET_BOTH 10) (defconstant DB_DIRTY_READ #x2000000) (defconstant DB_CREATE #x0000001) (defconstant DB_EXCL #x0001000) @@ -711,69 +895,84 @@ (defconstant DB_TXN_NOWAIT #x0001000) (defconstant DB_TXN_SYNC #x0002000) +(defconstant DB_GET_BOTH 10) +(defconstant DB_SET_LOCK_TIMEOUT 29) +(defconstant DB_SET_TXN_TIMEOUT 33) + (defun flags (&key auto-commit - db-joinenv - db-init-cdb - db-init-lock - db-init-log - db-init-mpool - db-init-rep - db-init-txn - db-recover - db-recover-fatal - db-lockdown - db-private - db-system-mem - db-thread - db-force - db-get-both - db-dirty-read - db-create - db-excl - db-nommap - db-rdonly - db-truncate - db-txn-nosync - db-txn-nowait - db-txn-sync) + joinenv + init-cdb + init-lock + init-log + init-mpool + init-rep + init-txn + recover + recover-fatal + lockdown + private + system-mem + thread + force + get-both + dirty-read + create + excl + nommap + rdonly + truncate + txn-nosync + txn-nowait + txn-sync + set-lock-timeout + set-transaction-timeout) (let ((flags 0)) (declare (optimize (speed 3) (safety 0) (space 0)) (type (unsigned-byte 32) flags) - (type boolean auto-commit db-joinenv db-init-cdb db-init-lock - db-init-log db-init-mpool db-init-rep db-init-txn - db-recover db-recover-fatal db-lockdown db-private - db-system-mem db-thread db-force db-get-both - db-dirty-read db-create db-excl db-nommap db-rdonly - db-truncate db-txn-nosync db-txn-nowait)) + (type boolean auto-commit joinenv init-cdb init-lock + init-log init-mpool init-rep init-txn + recover recover-fatal lockdown private + system-mem thread force get-both + dirty-read create excl nommap rdonly + truncate txn-nosync txn-nowait + set-lock-timeout set-transaction-timeout)) (when auto-commit (setq flags (logior flags DB_AUTO_COMMIT))) - (when db-joinenv (setq flags (logior flags DB_JOINENV))) - (when db-init-cdb (setq flags (logior flags DB_INIT_CDB))) - (when db-init-lock (setq flags (logior flags DB_INIT_LOCK))) - (when db-init-log (setq flags (logior flags DB_INIT_LOG))) - (when db-init-mpool (setq flags (logior flags DB_INIT_MPOOL))) - (when db-init-rep (setq flags (logior flags DB_INIT_REP))) - (when db-init-txn (setq flags (logior flags DB_INIT_TXN))) - (when db-recover (setq flags (logior flags DB_RECOVER))) - (when db-recover-fatal (setq flags (logior flags DB_RECOVER_FATAL))) - (when db-lockdown (setq flags (logior flags DB_LOCKDOWN))) - (when db-private (setq flags (logior flags DB_PRIVATE))) - (when db-system-mem (setq flags (logior flags DB_SYSTEM_MEM))) - (when db-thread (setq flags (logior flags DB_THREAD))) - (when db-force (setq flags (logior flags DB_FORCE))) - (when db-get-both (setq flags (logior flags DB_GET_BOTH))) - (when db-dirty-read (setq flags (logior flags DB_DIRTY_READ))) - (when db-create (setq flags (logior flags DB_CREATE))) - (when db-excl (setq flags (logior flags DB_EXCL))) - (when db-nommap (setq flags (logior flags DB_NOMMAP))) - (when db-rdonly (setq flags (logior flags DB_RDONLY))) - (when db-truncate (setq flags (logior flags DB_TRUNCATE))) - (when db-txn-nosync (setq flags (logior flags DB_TXN_NOSYNC))) - (when db-txn-nowait (setq flags (logior flags DB_TXN_NOWAIT))) - (when db-txn-sync (setq flags (logior flags DB_TXN_SYNC))) + (when joinenv (setq flags (logior flags DB_JOINENV))) + (when init-cdb (setq flags (logior flags DB_INIT_CDB))) + (when init-lock (setq flags (logior flags DB_INIT_LOCK))) + (when init-log (setq flags (logior flags DB_INIT_LOG))) + (when init-mpool (setq flags (logior flags DB_INIT_MPOOL))) + (when init-rep (setq flags (logior flags DB_INIT_REP))) + (when init-txn (setq flags (logior flags DB_INIT_TXN))) + (when recover (setq flags (logior flags DB_RECOVER))) + (when recover-fatal (setq flags (logior flags DB_RECOVER_FATAL))) + (when lockdown (setq flags (logior flags DB_LOCKDOWN))) + (when private (setq flags (logior flags DB_PRIVATE))) + (when system-mem (setq flags (logior flags DB_SYSTEM_MEM))) + (when thread (setq flags (logior flags DB_THREAD))) + (when force (setq flags (logior flags DB_FORCE))) + (when get-both (setq flags (logior flags DB_GET_BOTH))) + (when dirty-read (setq flags (logior flags DB_DIRTY_READ))) + (when create (setq flags (logior flags DB_CREATE))) + (when excl (setq flags (logior flags DB_EXCL))) + (when nommap (setq flags (logior flags DB_NOMMAP))) + (when rdonly (setq flags (logior flags DB_RDONLY))) + (when truncate (setq flags (logior flags DB_TRUNCATE))) + (when txn-nosync (setq flags (logior flags DB_TXN_NOSYNC))) + (when txn-nowait (setq flags (logior flags DB_TXN_NOWAIT))) + (when txn-sync (setq flags (logior flags DB_TXN_SYNC))) + (when set-lock-timeout (setq flags (logior flags DB_SET_LOCK_TIMEOUT))) + (when set-transaction-timeout (setq flags (logior flags DB_SET_TXN_TIMEOUT))) flags)) ;; Errors + +(defconstant DB_KEYEMPTY -30997) +(defconstant DB_LOCK_DEADLOCK -30995) +(defconstant DB_LOCK_NOTGRANTED -30994) +(defconstant DB_NOTFOUND -30990) + (def-function ("db_strerr" %db-strerror) ((error :int)) :returning :cstring) @@ -788,11 +987,3 @@ (declare (type db-error condition) (type stream stream)) (format stream "Berkeley DB error: ~A" (db-strerror (db-error-errno condition)))))) - -(define-condition buffer-too-small-error (error) - ((length-needed :initarg :length :reader length-needed)) - (:report - (lambda (condition stream) - (declare (type buffer-too-small-error condition) (type stream stream)) - (format stream "buffer-too-small-error: needed ~D bytes!" - (length-needed condition))))) \ No newline at end of file From blee at common-lisp.net Fri Aug 27 02:54:45 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 26 Aug 2004 19:54:45 -0700 Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23659/src Modified Files: libsleepycat.c Log Message: beginning of lock and cursor support Date: Thu Aug 26 19:54:43 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.1.1.1 elephant/src/libsleepycat.c:1.2 --- elephant/src/libsleepycat.c:1.1.1.1 Thu Aug 19 10:05:15 2004 +++ elephant/src/libsleepycat.c Thu Aug 26 19:54:43 2004 @@ -1,6 +1,22 @@ /* Pointer arithmetic utility functions */ +int read_int(char *buf, int offset) { + return *(int*)(buf + offset); +} + +unsigned int read_uint(char *buf, int offset) { + return *(unsigned int*)(buf + offset); +} + +float read_float(char *buf, int offset) { + return *(float*)(buf + offset); +} + +double read_double(char *buf, int offset) { + return *(double*)(buf + offset); +} + void write_int(char *buf, int num, int offset) { *(int*)(buf + offset) = num; } @@ -9,20 +25,16 @@ *(unsigned int*)(buf + offset) = num; } -void write_double(char *buf, double num, int offset) { - *(double*)(buf + offset) = num; +void write_float(char *buf, float num, int offset) { + *(float*)(buf + offset) = num; } -int read_int(char *buf, int offset) { - return *(int*)(buf + offset); -} - -unsigned int read_uint(char *buf, int offset) { - return *(unsigned int*)(buf + offset); +void write_double(char *buf, double num, int offset) { + *(double*)(buf + offset) = num; } -double read_double(char *buf, int offset) { - return *(double*)(buf + offset); +char *offset_charp(char *p, int offset) { + return p + offset; } #include @@ -76,6 +88,13 @@ return env->remove(env, home, flags); } +int db_env_set_flags(DB_ENV *dbenv, u_int32_t flags, int onoff) { + return dbenv->set_flags(dbenv, flags, onoff); +} + +int db_env_get_flags(DB_ENV *dbenv, u_int32_t *flagsp) { + return dbenv->get_flags(dbenv, flagsp); +} /* Database */ @@ -111,9 +130,16 @@ return db->truncate(db, txnid, countp, flags); } +int db_set_pagesize(DB *db, u_int32_t pagesize) { + return db->set_pagesize(db, pagesize); +} + +int db_get_pagesize(DB *db, u_int32_t *pagesizep) { + return db->get_pagesize(db, pagesizep); +} /* Accessors */ -/* Should also make versions which support bulk retrieval */ +/* We manage our own buffers (DB_DBT_USERMEM). */ int db_get_raw(DB *db, DB_TXN *txnid, char *key, u_int32_t key_length, @@ -128,7 +154,6 @@ DBTKey.size = key_length; DBTDatum.data = buffer; DBTDatum.ulen = buffer_length; - /* Need this for threaded applications */ DBTDatum.flags |= DB_DBT_USERMEM; ret = db->get(db, txnid, &DBTKey, &DBTDatum, flags); @@ -165,10 +190,113 @@ } +/* Cursors */ + +DBC * db_cursor(DB *db, DB_TXN *txnid, u_int32_t flags, int *errno) { + DBC *cursor; + *errno = db->cursor(db, txnid, &cursor, flags); + return cursor; +} + +int db_cursor_close(DBC *cursor) { + return cursor->c_close(cursor); +} + +int db_cursor_del(DBC *cursor, u_int32_t flags) { + return cursor->c_del(cursor, flags); +} + +DBC * db_cursor_dup(DBC *cursor, u_int32_t flags, int *errno) { + DBC *dup; + *errno = cursor->c_dup(cursor, &dup, flags); + return dup; +} + +int db_cursor_get_raw(DBC *cursor, + char *keybuf, u_int32_t keybuf_length, + char *buffer, u_int32_t buffer_length, + u_int32_t flags, u_int32_t *key_length, + u_int32_t *result_length) { + DBT DBTKey, DBTDatum; + int ret; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTDatum, 0, sizeof(DBT)); + DBTKey.data = keybuf; + DBTKey.ulen = keybuf_length; + DBTKey.flags |= DB_DBT_USERMEM; + DBTDatum.data = buffer; + DBTDatum.ulen = buffer_length; + DBTDatum.flags |= DB_DBT_USERMEM; + + ret = cursor->c_get(cursor, &DBTKey, &DBTDatum, flags); + *key_length = DBTKey.size; + *result_length = DBTDatum.size; + + return ret; +} + +int db_cursor_put_raw(DBC *cursor, + char *key, u_int32_t key_length, + char *datum, u_int32_t datum_length, + u_int32_t flags) { + DBT DBTKey, DBTDatum; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTDatum, 0, sizeof(DBT)); + DBTKey.data = key; + DBTKey.size = key_length; + DBTDatum.data = datum; + DBTDatum.size = datum_length; + + return cursor->c_put(cursor, &DBTKey, &DBTDatum, flags); +} + + +/* Bulk retrieval */ + +int db_cursor_get_multiple_key(DBC *cursor, + char *keybuf, u_int32_t keybuf_length, + char *buffer, u_int32_t buffer_length, + u_int32_t flags, u_int32_t *key_length, + u_int32_t *result_length, + void **pointer, DBT **data) { + DBT DBTKey, DBTDatum; + int ret; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTDatum, 0, sizeof(DBT)); + DBTKey.data = keybuf; + DBTKey.ulen = keybuf_length; + DBTKey.flags |= DB_DBT_USERMEM; + DBTDatum.data = buffer; + DBTDatum.ulen = buffer_length; + DBTDatum.flags |= DB_DBT_USERMEM; + + flags |= DB_MULTIPLE_KEY; + ret = cursor->c_get(cursor, &DBTKey, &DBTDatum, flags); + *key_length = DBTKey.size; + *result_length = DBTDatum.size; + if ((DBTKey.size <= DBTKey.ulen) && (DBTDatum.size <= DBTDatum.ulen)) { + **data = DBTDatum; + DB_MULTIPLE_INIT(*pointer, *data); + } + + return ret; +} + +void db_multiple_key_next(void *pointer, DBT *data, + char **key, u_int32_t *key_length, + char **result, u_int32_t *result_length) { + DB_MULTIPLE_KEY_NEXT(pointer, data, + *key, *key_length, + *result, *result_length); +} + /* Transactions */ -DB_TXN * db_env_txn_begin(DB_ENV *env, DB_TXN *parent, - u_int32_t flags, int *errno) { +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); return p; @@ -182,14 +310,45 @@ return txnid->commit(txnid, flags); } -/* -int db_env_lock_detect(DB_ENV *env, u_int32_t flags, u_int32_t atype, - int *aborted) { - return env->lock_detect(env, flags, atype, aborted); + +int db_txnp_begin(DB_ENV *env, DB_TXN *parent, DB_TXN **txnp, + u_int32_t flags) { + return env->txn_begin(env, parent, txnp, flags); +} + +/* Locks and timeouts */ + +u_int32_t db_txn_id(DB_TXN *tid) { + return tid->id(tid); +} + +int db_env_lock_id(DB_ENV *env, u_int32_t *idp) { + return env->lock_id(env, idp); +} + +int db_env_lock_id_free(DB_ENV *env, u_int32_t id) { + return env->lock_id_free(env, id); +} + +/* db_timeout_t = u_int32_t */ +int db_env_set_timeout(DB_ENV *env, db_timeout_t timeout, u_int32_t flags) { + return env->set_timeout(env, timeout, flags); +} + +int db_env_get_timeout(DB_ENV *env, db_timeout_t *timeoutp, u_int32_t flags) { + return env->get_timeout(env, timeoutp, flags); } int db_env_set_lk_detect(DB_ENV *env, u_int32_t detect) { return env->set_lk_detect(env, detect); } -*/ +int db_env_get_lk_detect(DB_ENV *env, u_int32_t *detectp) { + return env->get_lk_detect(env, detectp); +} + +int db_env_lock_detect(DB_ENV *env, u_int32_t flags, u_int32_t atype, + int *aborted) { + return env->lock_detect(env, flags, atype, aborted); +} + From blee at common-lisp.net Fri Aug 27 02:57:37 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 26 Aug 2004 19:57:37 -0700 Subject: [elephant-cvs] CVS update: elephant/src/serializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv23860/src Modified Files: serializer.lisp Log Message: aggregate object support Date: Thu Aug 26 19:57:36 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.1.1.1 elephant/src/serializer.lisp:1.2 --- elephant/src/serializer.lisp:1.1.1.1 Thu Aug 19 10:05:14 2004 +++ elephant/src/serializer.lisp Thu Aug 26 19:57:36 2004 @@ -2,261 +2,555 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (use-package "UFFI")) -; f: fixnum <-> long -; i: integer <-> array of long -; r: rational <-> 2x array of long - -; l: long-float <-> double (punt on other floats? check -; *features* for :ieee-floating-point -- see -; http://www.common-lisp.net/project/ieeefp-tests/) - -; N: nil -; S: symbol -; c: character (hopefully a base-char) -; s: string -; p: pathname - -; o: CL-STORE stream - -; O: persistent object - - -(declaim (inline resize-write-buffer int-byte-spec copy-buf - deserialize-tail-string deserialize-bignum)) - -(declaim (type array-char *write-buffer* *write-buffer-rest* - *read-buffer* *read-buffer-rest*) - (type fixnum *write-buffer-length* *read-buffer-length*)) - -(defconstant +fixnum+ (char-code #\f)) -(defconstant +positive-bignum+ (char-code #\B)) -(defconstant +negative-bignum+ (char-code #\b)) -(defconstant +rational+ (char-code #\r)) -(defconstant +long-float+ (char-code #\l)) -(defconstant +nil+ (char-code #\N)) -(defconstant +symbol+ (char-code #\S)) -(defconstant +base-char+ (char-code #\c)) -(defconstant +string+ (char-code #\s)) -(defconstant +pathname+ (char-code #\p)) -(defconstant +cl-store+ (char-code #\O)) -(defconstant +persistent-object+ (char-code #\P)) +(declaim (inline int-byte-spec + ;resize-buffer-stream + finish-buffer + buffer-write-byte buffer-write-int buffer-write-uint + buffer-write-float buffer-write-double buffer-write-string + buffer-read-byte buffer-read-fixnum buffer-read-int + buffer-read-uint buffer-read-float buffer-read-double + buffer-read-string + ;serialize deserialize + deserialize-bignum)) -(defconstant +fixnum-width+ (integer-length most-positive-fixnum)) +(def-type foreign-char :char) -#+(or cmu scl sbcl allegro) -(defvar *resourced-byte-spec* (byte 32 0)) +;; Constants -(defun int-byte-spec (position) +(defconstant +fixnum+ (char-code #\f)) +(defconstant +symbol+ (char-code #\S)) +(defconstant +string+ (char-code #\s)) +(defconstant +nil+ (char-code #\N)) +(defconstant +persistent+ (char-code #\P)) +(defconstant +single-float+ (char-code #\F)) +(defconstant +double-float+ (char-code #\D)) +(defconstant +base-char+ (char-code #\c)) +(defconstant +pathname+ (char-code #\p)) +(defconstant +positive-bignum+ (char-code #\B)) +(defconstant +negative-bignum+ (char-code #\b)) +(defconstant +rational+ (char-code #\r)) +(defconstant +cons+ (char-code #\C)) +(defconstant +hash-table+ (char-code #\H)) +(defconstant +object+ (char-code #\O)) +(defconstant +array+ (char-code #\A)) + +(defconstant +fill-pointer-p+ #x40) +(defconstant +adjustable-p+ #x80) + +; a stream-like interface for our buffers. ultimately we +; might want a gray / simple -stream for real, for now who +; cares? + +(defstruct buffer-stream + (buffer (allocate-foreign-object :char 1) :type array-or-pointer-char) + (length 0 :type fixnum) + (position 0 :type fixnum)) + +;; Some thread-local storage + +(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*) + (type fixnum *lisp-obj-id*) + (type hash-table *circularity-hash*)) + +(defvar *out-buf* (make-buffer-stream)) +(defvar *key-buf* (make-buffer-stream)) +(defvar *in-buf* (make-buffer-stream)) +(defvar *lisp-obj-id* 0) +(defvar *circularity-hash* (make-hash-table :test 'eq)) + +(defun serialize (frob bs) + (declare (optimize (speed 3) (safety 0))) + (setq *lisp-obj-id* 0) + (clrhash *circularity-hash*) + (labels + ((%serialize (frob) + (declare (optimize (speed 3) (safety 0))) + (etypecase frob + (fixnum + (buffer-write-byte +fixnum+ bs) + (buffer-write-int frob bs)) + (symbol + (let ((s (symbol-name frob))) + (declare (type string s) (dynamic-extent s)) + (buffer-write-byte +symbol+ bs) + (buffer-write-int (byte-length s) bs) + (buffer-write-string s bs))) + (string + (buffer-write-byte +string+ bs) + (buffer-write-int (byte-length frob) bs) + (buffer-write-string frob bs)) + (null + (buffer-write-byte +nil+ bs)) + (persistent + (buffer-write-byte +persistent+ bs) + (buffer-write-int (oid frob) bs) + (%serialize (type-of frob))) + #-(and :lispworks (or :win32 :linux)) + (single-float + (buffer-write-byte +single-float+ bs) + (buffer-write-float frob bs)) + (double-float + (buffer-write-byte +double-float+ bs) + (buffer-write-double frob bs)) + (character + (buffer-write-byte +base-char+ bs) + ;; might be wide! + (buffer-write-int (char-code frob) bs)) + (pathname + (let ((s (namestring frob))) + (declare (type string s) (dynamic-extent s)) + (buffer-write-byte +pathname+ bs) + (buffer-write-int (byte-length s) bs) + (buffer-write-string s bs))) + (integer + (let* ((num (abs frob)) + (word-size (ceiling (/ (integer-length num) 32))) + (needed (* word-size 4))) + (declare (type fixnum word-size needed)) + (if (< frob 0) + (buffer-write-byte +negative-bignum+ bs) + (buffer-write-byte +positive-bignum+ bs)) + (buffer-write-int needed bs) + (loop for i fixnum from 0 below word-size + ;; shouldn't this be "below"? + for byte-spec = (int-byte-spec i) + ;; this ldb is consing! + ;; there is an OpenMCL function which should work + ;; and non-cons + for the-uint of-type (unsigned-byte 32) = (ldb byte-spec num) + do + (buffer-write-uint the-uint bs)))) + (rational + (buffer-write-byte +rational+ bs) + (%serialize (numerator frob)) + (%serialize (denominator frob))) + (cons + (buffer-write-byte +cons+ bs) + (let ((idp (gethash frob *circularity-hash*))) + (if idp (buffer-write-int idp bs) + (progn + (buffer-write-int (incf *lisp-obj-id*) bs) + (setf (gethash frob *circularity-hash*) *lisp-obj-id*) + (%serialize (car frob)) + (%serialize (cdr frob)))))) + (hash-table + (buffer-write-byte +hash-table+ bs) + (let ((idp (gethash frob *circularity-hash*))) + (if idp (buffer-write-int idp bs) + (progn + (buffer-write-int (incf *lisp-obj-id*) bs) + (setf (gethash frob *circularity-hash*) *lisp-obj-id*) + (%serialize (hash-table-test frob)) + (%serialize (hash-table-rehash-size frob)) + (%serialize (hash-table-rehash-threshold frob)) + (%serialize (hash-table-count frob)) + (loop for key being the hash-key of frob + using (hash-value value) + do + (%serialize key) + (%serialize value)))))) + (standard-object + (buffer-write-byte +object+ bs) + (let ((idp (gethash frob *circularity-hash*))) + (if idp (buffer-write-int idp bs) + (progn + (buffer-write-int (incf *lisp-obj-id*) bs) + (setf (gethash frob *circularity-hash*) *lisp-obj-id*) + (%serialize (type-of frob)) + (let ((svs (slots-and-values frob))) + (declare (dynamic-extent svs)) + (%serialize (/ (length svs) 2)) + (loop for item in svs + do (%serialize item))))))) + (array + (buffer-write-byte +array+ bs) + (let ((idp (gethash frob *circularity-hash*))) + (if idp (buffer-write-int idp bs) + (progn + (buffer-write-int (incf *lisp-obj-id*) bs) + (setf (gethash frob *circularity-hash*) *lisp-obj-id*) + (buffer-write-byte + (logior (byte-from-array-type (array-element-type frob)) + (if (array-has-fill-pointer-p frob) + +fill-pointer-p+ 0) + (if (adjustable-array-p frob) + +adjustable-p+ 0)) + bs) + (let ((rank (array-rank frob))) + (buffer-write-int rank bs) + (loop for i fixnum from 0 below rank + do (buffer-write-int (array-dimension frob i) + bs))) + (loop for i fixnum from 0 below (array-total-size frob) + do + (%serialize (row-major-aref frob i))))))) + ))) + (%serialize frob) + (finish-buffer bs))) + +(defun slots-and-values (o) + (loop for sd in (compute-slots (class-of o)) + for slot-name = (slot-definition-name sd) + with ret = () + do + (when (slot-boundp o slot-name) + (push (slot-value o slot-name) ret) + (push slot-name ret)) + finally (return ret))) + +(defun deserialize (buf) (declare (optimize (speed 3) (safety 0)) - (type fixnum position)) - #+(or cmu scl sbcl allegro) - (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) - *resourced-byte-spec*) - #-(or cmu scl sbcl allegro) - (byte 32 (* 32 position)) - ) + (type array-or-pointer-char buf)) + (setf (buffer-stream-buffer *in-buf*) buf) + (setf (buffer-stream-position *in-buf*) 0) + (setq *lisp-obj-id* 0) + (clrhash *circularity-hash*) + (labels + ((%deserialize (bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((tag (buffer-read-byte bs))) + (declare (type foreign-char tag)) + (cond + ((= tag +fixnum+) + (buffer-read-fixnum bs)) + ((= tag +symbol+) + (intern (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) + ((= tag +string+) + (buffer-read-string bs (buffer-read-fixnum bs))) + ((= tag +nil+) nil) + ((= tag +persistent+) + (get-cached-instance *store-controller* + (buffer-read-fixnum bs) + (%deserialize bs))) + ((= tag +single-float+) + (buffer-read-float bs)) + ((= tag +double-float+) + (buffer-read-double bs)) + ((= tag +base-char+) + (code-char (buffer-read-byte bs))) + ((= tag +pathname+) + (parse-namestring + (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) + ((= tag +positive-bignum+) + (deserialize-bignum bs (buffer-read-fixnum bs) t)) + ((= tag +negative-bignum+) + (deserialize-bignum bs (buffer-read-fixnum bs) nil)) + ((= tag +rational+) + (/ (the integer (%deserialize bs)) + (the integer (%deserialize bs)))) + ((= tag +cons+) + (let* ((id (buffer-read-fixnum bs)) + (maybe-cons (gethash id *circularity-hash*))) + (if maybe-cons maybe-cons + (let ((c (cons nil nil))) + (setf (gethash id *circularity-hash*) c) + (setf (car c) (%deserialize bs)) + (setf (cdr c) (%deserialize bs)) + c)))) + ((= tag +hash-table+) + (let* ((id (buffer-read-fixnum bs)) + (maybe-hash (gethash id *circularity-hash*))) + (if maybe-hash maybe-hash + (let ((h (make-hash-table :test (%deserialize bs) + :rehash-size (%deserialize bs) + :rehash-threshold + (%deserialize bs)))) + (loop for i fixnum from 0 below (%deserialize bs) + do + (setf (gethash (%deserialize bs) h) + (%deserialize bs))) + h)))) + ((= tag +object+) + (let* ((id (buffer-read-fixnum bs)) + (maybe-o (gethash id *circularity-hash*))) + (if maybe-o maybe-o + (let ((o (make-instance (%deserialize bs)))) + (loop for i fixnum from 0 below (%deserialize bs) + do + (setf (slot-value o (%deserialize bs)) + (%deserialize bs))) + o)))) + ((= tag +array+) + (let* ((id (buffer-read-fixnum bs)) + (maybe-array (gethash id *circularity-hash*))) + (if maybe-array maybe-array + (let* ((flags (buffer-read-byte bs)) + (a (make-array + (loop for i fixnum from 0 below + (buffer-read-int bs) + collect (buffer-read-int bs)) + :element-type (array-type-from-byte + (logand #x3f flags)) + :fill-pointer (/= 0 (logand +fill-pointer-p+ + flags)) + :adjustable (/= 0 (logand +adjustable-p+ + flags))))) + (loop for i fixnum from 0 below (array-total-size a) + do + (setf (row-major-aref a i) (%deserialize bs))) + a)))) + (t (error "deserialize fubar!")))))) + (%deserialize *in-buf*))) +(defun deserialize-bignum (bs length positive) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum length) + (type boolean positive)) + (loop for i from 0 upto (/ length 4) + for byte-spec = (int-byte-spec i) + with num integer = 0 + do + (setq num (dpb (buffer-read-uint bs) byte-spec num)) + finally (return (if positive num (- num))))) -(defvar *write-buffer* (allocate-foreign-object :char 2)) -(defvar *write-buffer-rest* - (make-pointer (+ (pointer-address *write-buffer*) 1) :char)) -(defvar *write-buffer-length* 0) -(defun resize-write-buffer (length) + +;; Stream-like buffer interface + +(eval-when (:compile-toplevel :load-toplevel) + (defun process-struct-slot-defs (slot-defs struct) + (loop for def in slot-defs + collect (list (first def) (list (second def) struct))))) + +(defmacro with-struct-slots (slot-defs struct &body body) + `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct) + , at body)) + +(declaim (type array-or-pointer-char *buffer* *key-buffer*) + (type fixnum *buffer-length* *buffer-position* + *key-buffer-length* *key-buffer-position*)) + +(defun resize-buffer-stream (bs length) (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) (type fixnum length)) - (if (< length *write-buffer-length*) - (values *write-buffer* *write-buffer-length*) - (let ((newlen (max length (* *write-buffer-length* 2)))) + (with-struct-slots ((buf buffer-stream-buffer) + (pos buffer-stream-position) + (len buffer-stream-length)) + bs + (when (> length len) + (let ((newlen (max length (* len 2)))) (declare (type fixnum newlen)) - (setq *write-buffer-length* newlen) - (free-foreign-object *write-buffer*) - (setq *write-buffer* (allocate-foreign-object :char newlen)) - (setq *write-buffer-rest* - (make-pointer (+ (pointer-address *write-buffer*) 1) :char)) - (values *write-buffer* *write-buffer-length*)))) - -(defvar *read-buffer* (allocate-foreign-object :char 2)) -(defvar *read-buffer-rest* - (make-pointer (+ (pointer-address *read-buffer*) 1) :char)) -(defvar *read-buffer-length* 0) + (let ((newbuf (allocate-foreign-object :char newlen))) + (copy-bufs newbuf 0 buf 0 len) + (free-foreign-object buf) + (setf buf newbuf) + (setf len newlen) + nil))))) -(defun resize-read-buffer (buf length) +(defun finish-buffer (bs) (declare (optimize (speed 3) (safety 0)) - (ignore buf) - (type fixnum length)) - (if (< length *read-buffer-length*) - (values *read-buffer* *read-buffer-length*) - (let ((newlen (max length (* *read-buffer-length* 2)))) - (declare (type fixnum newlen)) - (setq *read-buffer-length* newlen) - (free-foreign-object *read-buffer*) - (setq *read-buffer* (allocate-foreign-object :char newlen)) - (setq *read-buffer-rest* - (make-pointer (+ (pointer-address *read-buffer*) 1) :char)) - (values *read-buffer* *read-buffer-length*)))) - -(defun copy-buf (str buf len &key (src-offset 0) (buf-offset 0)) - (declare (optimize (speed 3) (safety 0)) - (type string str) - (type array-char buf) - (type fixnum len src-offset buf-offset) - (dynamic-extent str buf len)) - (typecase str - (simple-string - (loop for i fixnum from 0 below len - do - (setf (deref-array buf '(:array :char) (+ i buf-offset)) - (char-code (schar str (+ i src-offset)))))) - (string - (loop for i fixnum from 0 below len - do - (setf (deref-array buf '(:array :char) (+ i buf-offset)) - (char-code (char str (+ i src-offset)))))))) + (type buffer-stream bs)) + (with-struct-slots ((buf buffer-stream-buffer) + (pos buffer-stream-position)) + bs + (let ((length pos)) + (setf pos 0) + length))) -(def-type foreign-char :char) +(defun buffer-write-byte (b bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (unsigned-byte 8) b)) + (with-struct-slots ((buf buffer-stream-buffer) + (pos buffer-stream-position) + (len buffer-stream-length)) + bs + (let ((needed (+ pos 1))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (setf (deref-array buf '(:array :char) pos) b) + (setf pos needed)))) -(defmacro write-tag (tag) - `(setf (deref-pointer *write-buffer* :char) ,tag)) +(defun buffer-write-int (i bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (signed-byte 32) i)) + (with-struct-slots ((buf buffer-stream-buffer) + (pos buffer-stream-position) + (len buffer-stream-length)) + bs + (let ((needed (+ pos 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-int buf i pos) + (setf pos needed) + nil))) -(defgeneric serialize (frob)) +(defun buffer-write-uint (u bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type (unsigned-byte 32) u)) + (with-struct-slots ((buf buffer-stream-buffer) + (pos buffer-stream-position) + (len buffer-stream-length)) + bs + (let ((needed (+ pos 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-uint buf u pos) + (setf pos needed) + nil))) -(defmethod serialize ((frob integer)) - (declare (optimize (speed 3) (safety 0))) - (if (typep frob 'fixnum) - (progn - (write-tag +fixnum+) - (with-cast-pointer (p *write-buffer-rest* :int) - (setf (deref-pointer p :int) frob)) - (values *write-buffer* 5)) - (let* ((num (abs frob)) - (word-size (ceiling (/ (integer-length num) 32))) - (needed (+ (* word-size 4) 1))) - (declare (type fixnum word-size needed)) - (when (> needed *write-buffer-length*) - (resize-write-buffer needed)) - (if (> frob 0) (write-tag +positive-bignum+) - (write-tag +negative-bignum+)) - (with-cast-pointer - (p *write-buffer-rest* :unsigned-int) - (loop for i fixnum from 0 to word-size - for byte-spec = (int-byte-spec i) - ;; this ldb is consing! - for the-byte of-type (unsigned-byte 32) = (ldb byte-spec num) - do - (setf (deref-array p '(:array :unsigned-int) i) the-byte) - finally - (return (values *write-buffer* needed))))))) +(defun buffer-write-float (d bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type single-float d)) + (with-struct-slots ((buf buffer-stream-buffer) + (pos buffer-stream-position) + (len buffer-stream-length)) + bs + (let ((needed (+ pos 4))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-float buf d pos) + (setf pos needed) + nil))) -(defmethod serialize ((frob float)) - (declare (optimize (speed 3) (safety 0))) - (write-tag +long-float+) - (with-cast-pointer - (p *write-buffer-rest* :double) - (setf (deref-pointer p :double) (coerce frob 'long-float))) - (values *write-buffer* 9)) - -(defmethod serialize ((frob null)) - (declare (optimize (speed 3) (safety 0))) - (write-tag +nil+) - (values *write-buffer* 1)) +(defun buffer-write-double (d bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type double-float d)) + (with-struct-slots ((buf buffer-stream-buffer) + (pos buffer-stream-position) + (len buffer-stream-length)) + bs + (let ((needed (+ pos 8))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-double buf d pos) + (setf pos needed) + nil))) -(defmethod serialize ((frob character)) - (declare (optimize (speed 3) (safety 0))) - (write-tag +base-char+) - (setf (deref-array *write-buffer* '(:array :char) 1) (char-code frob)) - (values *write-buffer* 2)) +(defun buffer-write-string (s bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type string s)) + (with-struct-slots ((buf buffer-stream-buffer) + (pos buffer-stream-position) + (len buffer-stream-length)) + bs + (let* ((str-bytes (byte-length s)) + (needed (+ pos str-bytes))) + (declare (type fixnum str-bytes needed) + (dynamic-extent str-bytes needed)) + (when (> needed len) + (resize-buffer-stream bs needed)) + (copy-str-to-buf buf pos s 0 str-bytes) + (setf pos needed) + nil))) -(defmethod serialize ((frob symbol)) - (declare (optimize (speed 3) (safety 0))) - (let* ((s (symbol-name frob)) - (slen (length s)) - (needed (+ slen 1))) - (declare (type fixnum slen needed) - (dynamic-extent s)) - (when (> needed *write-buffer-length*) (resize-write-buffer needed)) - (write-tag +symbol+) - (copy-buf s *write-buffer-rest* slen) - (values *write-buffer* needed))) +(defun buffer-read-byte (bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((pos (buffer-stream-position bs))) + (incf (buffer-stream-position bs)) + (deref-array (buffer-stream-buffer bs) '(:array :char) pos))) -(defmethod serialize ((frob string)) - (declare (optimize (speed 3) (safety 0))) - (let* ((slen (length frob)) - (needed (+ slen 1))) - (declare (type fixnum slen needed)) - (when (> needed *write-buffer-length*) (resize-write-buffer needed)) - (write-tag +string+) - (copy-buf frob *write-buffer-rest* slen) - (values *write-buffer* needed))) +(defun buffer-read-fixnum (bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((pos (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ pos 4)) + (the fixnum (read-int (buffer-stream-buffer bs) pos)))) -(defmethod serialize ((frob pathname)) - (declare (optimize (speed 3) (safety 0))) - (let ((s (namestring frob))) - (declare (type string s) (dynamic-extent s)) - (let* ((slen (length s)) - (needed (+ slen 1))) - (declare (type fixnum slen needed)) - (when (> needed *write-buffer-length*) (resize-write-buffer needed)) - (write-tag +pathname+) - (copy-buf s *write-buffer-rest* slen) - (values *write-buffer* needed)))) - -;(defmethod serialize ((frob persistent)) -; (declare (optimize (speed 3) (safety 0))) -; (let ((s (%class-name frob))) -; (declare (type string s)) -; (let* ((slen (length s)) -; (needed (+ slen 2))) -; (declare (type fixnum slen needed)) -; (write-tag +persistent-object+) -; (copy-buf ( -; (concatenate 'string "O" (prin1-to-string (oid frob)) -; ":" (%class-name frob))) +(defun buffer-read-int (bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((pos (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ pos 4)) + (the (signed-byte 32) (read-int (buffer-stream-buffer bs) pos)))) +(defun buffer-read-uint (bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((pos (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ pos 4)) + (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) pos)))) +(defun buffer-read-float (bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((pos (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ pos 4)) + (read-float (buffer-stream-buffer bs) pos))) -(defun deserialize (buf buf-rest length) - (declare (optimize (speed 3) (safety 0)) - (type array-char buf buf-rest) - (fixnum length)) - (let ((tag (deref-pointer buf :char))) - (declare (type foreign-char tag)) - (cond - ((= tag +string+) - (convert-from-foreign-string buf-rest :length (- length 1) - :null-terminated-p nil)) - ((= tag +fixnum+) - (with-cast-pointer (p buf-rest :int) - (deref-pointer p :int))) - ((= tag +nil+) nil) - ((= tag +long-float+) - (with-cast-pointer - (p buf-rest :double) - (deref-pointer p :double))) - ((= tag +positive-bignum+) (deserialize-bignum buf-rest length t)) - ((= tag +negative-bignum+) (deserialize-bignum buf-rest length nil)) - ((= tag +symbol+) - (intern - (convert-from-foreign-string buf-rest :length (- length 1) - :null-terminated-p nil))) - ((= tag +base-char+) - (code-char (deref-array buf '(:array :char) 1))) - ((= tag +pathname+) - (parse-namestring - (convert-from-foreign-string buf-rest :length (- length 1) - :null-terminated-p nil))) - (t (error "deserialize fubar!"))))) +(defun buffer-read-double (bs) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let ((pos (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ pos 8)) + (read-double (buffer-stream-buffer bs) pos))) -(defun deserialize-bignum (buf-rest length positive) +(defun buffer-read-string (bs length) (declare (optimize (speed 3) (safety 0)) - (type array-char buf-rest) - (type fixnum length) - (type boolean positive)) - (with-cast-pointer (p buf-rest :unsigned-int) - (loop for i from 0 upto (/ (- length 1) 4) - for byte-spec = (int-byte-spec i) - with num integer = 0 - do - (setq num (dpb (deref-array p '(:array :unsigned-int) i) - byte-spec num)) - finally (return (if positive num (- num)))))) \ No newline at end of file + (type buffer-stream bs) + (type fixnum length)) + (let ((pos (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ pos length)) + ;; wide!!! + #+(and allegro ics) + (excl:native-to-string + (offset-char-pointer (buffer-stream-buffer bs) pos) + :length length + :external-format :unicode) + #+lispworks + (fli:convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) pos) + :length length :external-format :unicode :null-terminated-p nil) + #-(or lispworks (and allegro ics)) + (convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) pos) + :length length :null-terminated-p nil))) + +;; array type tags + +(declaim (type hash-table array-type-to-byte byte-to-array-type)) +(defvar array-type-to-byte (make-hash-table :test 'equalp)) +(defvar byte-to-array-type (make-hash-table :test 'equalp)) + +(setf (gethash 'T array-type-to-byte) #x00) +(setf (gethash 'bit array-type-to-byte) #x01) +(setf (gethash '(unsigned-byte 2) array-type-to-byte) #x02) +(setf (gethash '(unsigned-byte 4) array-type-to-byte) #x03) +(setf (gethash '(unsigned-byte 8) array-type-to-byte) #x04) +(setf (gethash '(unsigned-byte 16) array-type-to-byte) #x05) +(setf (gethash '(unsigned-byte 32) array-type-to-byte) #x06) +(setf (gethash '(unsigned-byte 64) array-type-to-byte) #x07) +(setf (gethash '(signed-byte 8) array-type-to-byte) #x08) +(setf (gethash '(signed-byte 16) array-type-to-byte) #x09) +(setf (gethash '(signed-byte 32) array-type-to-byte) #x0A) +(setf (gethash '(signed-byte 64) array-type-to-byte) #x0B) +(setf (gethash 'character array-type-to-byte) #x0C) +(setf (gethash 'single-float array-type-to-byte) #x0D) +(setf (gethash 'double-float array-type-to-byte) #x0E) +(setf (gethash '(complex single-float) array-type-to-byte) #x0F) +(setf (gethash '(complex double-float) array-type-to-byte) #x10) + +(loop for key being the hash-key of array-type-to-byte + using (hash-value value) + do + (setf (gethash value byte-to-array-type) key)) + +(defun array-type-from-byte (b) + (gethash b byte-to-array-type)) + +(defun byte-from-array-type (ty) + (the (unsigned-byte 8) (gethash ty array-type-to-byte))) + +;(defconstant +cl-store+ (char-code #\o)) + +#+(or cmu scl sbcl allegro) +(defvar *resourced-byte-spec* (byte 32 0)) + +(defun int-byte-spec (position) + (declare (optimize (speed 3) (safety 0)) + (type (unsigned-byte 24) position)) + #+(or cmu scl sbcl allegro) + (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) + *resourced-byte-spec*) + #-(or cmu scl sbcl allegro) + (byte 32 (* 32 position)) + ) From blee at common-lisp.net Fri Aug 27 02:57:53 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 26 Aug 2004 19:57:53 -0700 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: 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) From blee at common-lisp.net Fri Aug 27 02:58:09 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 26 Aug 2004 19:58:09 -0700 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: 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 , at 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) , at 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)) + From blee at common-lisp.net Fri Aug 27 02:58:28 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 26 Aug 2004 19:58:28 -0700 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: 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))) From blee at common-lisp.net Fri Aug 27 02:59:46 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 26 Aug 2004 19:59:46 -0700 Subject: [elephant-cvs] CVS update: elephant/NOTES Message-ID: 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 From blee at common-lisp.net Fri Aug 27 17:28:10 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:28:10 -0700 Subject: [elephant-cvs] CVS update: elephant/INSTALL Message-ID: 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 From blee at common-lisp.net Fri Aug 27 17:29:29 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:29:29 -0700 Subject: [elephant-cvs] CVS update: elephant/functions.lisp Message-ID: 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 From blee at common-lisp.net Fri Aug 27 17:30:12 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:30:12 -0700 Subject: [elephant-cvs] CVS update: elephant/elephant.asd Message-ID: 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 From blee at common-lisp.net Fri Aug 27 17:30:27 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:30:27 -0700 Subject: [elephant-cvs] CVS update: elephant/TUTORIAL Message-ID: 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 From blee at common-lisp.net Fri Aug 27 17:30:39 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:30:39 -0700 Subject: [elephant-cvs] CVS update: elephant/README Message-ID: 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 From blee at common-lisp.net Fri Aug 27 17:30:50 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:30:50 -0700 Subject: [elephant-cvs] CVS update: elephant/LICENSE Message-ID: 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 From blee at common-lisp.net Fri Aug 27 17:31:09 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:31:09 -0700 Subject: [elephant-cvs] CVS update: elephant/NOTES Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv13389 Modified Files: NOTES Log Message: more changes than i can count Date: Fri Aug 27 10:31:08 2004 Author: blee Index: elephant/NOTES diff -u elephant/NOTES:1.1 elephant/NOTES:1.2 --- elephant/NOTES:1.1 Thu Aug 26 19:59:46 2004 +++ elephant/NOTES Fri Aug 27 10:31:08 2004 @@ -6,7 +6,12 @@ this has been optimized for use with CMUCL. it has been tested and somewhat optimized for allegro. SBCL and OpenMCL are definitely also desired targets. Lispworks is a target -as well but less so; i can't test it. +as well but less so: i don't have access to it. + +Theoretically one can port this to any lisp with a decent +FFI and MOP. However since those are two of the less +standardized bits of Lisp, in practice this might be +difficult. From top to bottom, here are the implementation layers: @@ -24,6 +29,52 @@ database / serializer, specials are needed. The store controller (see below) is also a special. +----------------------- +CLASSES AND METACLASSES +----------------------- + +Persistent classes which the user defines are declared and +instrumented by using the persistent-metaclass. + +----------- +COLLECTIONS +----------- + +While we support serializing and persisting a wide class of +Lisp data types, there are problems with aggregate types +(conses, lists, arrays, objects, hash-tables...) + +1) not automatic: there's no way for elephant to know when +you've changed a value in an aggregate object, so you have +to manually restore it back into the slot to get it saved. + +slot-1 of obj A contains a cons. you change the car of the +cons. this is not reflected into the database unless you +re-set slot-1 of obj A with the cons. + +2) merge-conflicts: changing one value and saving an +aggregate will write out the whole aggregate, possibly +blowing away changes other threads have made behind your +back. this is not protected by transactions! + +3) consing, non-lazy and expensive (de)serialization: you +have to serialize/deserialize the entire aggregate every +time you save it or restore it. This is pretty fast all +things considered, but it's probably better to use +persistent collections. + +4) you have to store the entire collection in memory, +whereas one of the points of the database to store large +collections of objects..... + +For these and other reasons, we provide a hash-table-like +interface to Berkeley BTrees. These have many advantages +over ordinary hash-tables from the point of view of +persistence. + +TODO: programmatic way to create secondary indicies +(probably Lisp-level, since FFI callbacks are nasty.) + ---------- CONTROLLER ---------- @@ -57,6 +108,8 @@ determines liveness. The root object is a btree collection with a special OID 0. +TODO: write the garbage collector. + ------------ TABLE LAYOUT ------------ @@ -157,32 +210,6 @@ SERIALIZER: AGGREGATE TYPES --------------------------- -problems, or Do You REALLY Want to Persist Aggregates? - -0) not automatic: there's no way for elephant to know when -you've changed a value in an aggregate object, so you have -to manually restore it back into the slot to get it saved. - -1) merge-conflicts: changing one value in the aggregate will -write out the whole aggregate, possibly blowing away changes -other threads have made behind your back. this is not -protected by transactions! - -2) object identity / circularity: what are the right -semantics for things not tagged with OIDs? certainly can't -maintain identity across slots. - -obj A has slots slot-1 and slot-2. puts same cons in each -slot. no way to keep track that they are supposed to be the -same cons! - -3) consing, non-lazy and expensive (de)serialization - -"solution": in the FEW BIG TABLES schema, it is cheap to -create and use persistent collection types, which will -preserve identity et al. as with all persistent objects, -persistent collections are lazy-loading. - if you really must store non-persistent aggregates, we support: conses (lists): 1 + car + cdr @@ -238,6 +265,8 @@ default accessed through a special variable *current-transaction*. The special *auto-commit* (which defaults to nil!) is also a special. + +TODO: do transactions memory leak? UFFI is used as much as possible. Because some implementations can't call function pointers, and because we From blee at common-lisp.net Fri Aug 27 17:31:31 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:31:31 -0700 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv13481/src Modified Files: classes.lisp Log Message: license, name changes Date: Fri Aug 27 10:31:30 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.2 elephant/src/classes.lisp:1.3 --- elephant/src/classes.lisp:1.2 Thu Aug 26 19:53:52 2004 +++ elephant/src/classes.lisp Fri Aug 27 10:31:30 2004 @@ -1,3 +1,41 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; classes.lisp -- persistent objects via metaobjects +;;; +;;; Initial version 8/26/2004 by Andrew Blumberg +;;; +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; This program is free software; you can redistribute it +;;; and/or modify it under the terms of the GNU General +;;; Public License as published by the Free Software +;;; Foundation; either version 2 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the +;;; implied warranty of MERCHANTABILITY or FITNESS FOR A +;;; PARTICULAR PURPOSE. See the GNU General Public License +;;; for more details. +;;; +;;; The GNU General Public License can be found in the file +;;; LICENSE which should have been distributed with this +;;; code. It can also be found at +;;; +;;; http://www.opensource.org/licenses/gpl-license.php +;;; +;;; You should have received a copy of the GNU General +;;; Public License along with this program; if not, write +;;; to the Free Software Foundation, Inc., 59 Temple Place, +;;; Suite 330, Boston, MA 02111-1307 USA +;;; + ;; TODO: slot-bound-p (check the database) (in-package "ELEPHANT") @@ -78,9 +116,10 @@ (buffer-write-int (oid instance) *key-buf*) (let ((key-length (serialize ,name *key-buf*))) (handler-case - (deserialize (db-get-key-buffered (db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length)) + (deserialize (db-get-key-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length)) (db-error (err) (if (= (db-error-errno err) DB_NOTFOUND) (error 'unbound-slot :instance instance :slot ,name) @@ -92,7 +131,7 @@ (buffer-write-int (oid instance) *key-buf*) (let ((key-length (serialize ,name *key-buf*)) (val-length (serialize new-value *out-buf*))) - (db-put-buffered (db *store-controller*) + (db-put-buffered (controller-db *store-controller*) (buffer-stream-buffer *key-buf*) key-length (buffer-stream-buffer *out-buf*) val-length :transaction *current-transaction* From blee at common-lisp.net Fri Aug 27 17:31:59 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:31:59 -0700 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv13575/src Modified Files: controller.lisp Log Message: license, name changes, with-transaction* defaulters Date: Fri Aug 27 10:31:59 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.2 elephant/src/controller.lisp:1.3 --- elephant/src/controller.lisp:1.2 Thu Aug 26 19:58:09 2004 +++ elephant/src/controller.lisp Fri Aug 27 10:31:59 2004 @@ -1,12 +1,51 @@ +;;; -*- 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 +;;; +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; This program is free software; you can redistribute it +;;; and/or modify it under the terms of the GNU General +;;; Public License as published by the Free Software +;;; Foundation; either version 2 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the +;;; implied warranty of MERCHANTABILITY or FITNESS FOR A +;;; PARTICULAR PURPOSE. See the GNU General Public License +;;; for more details. +;;; +;;; The GNU General Public License can be found in the file +;;; LICENSE which should have been distributed with this +;;; code. It can also be found at +;;; +;;; http://www.opensource.org/licenses/gpl-license.php +;;; +;;; You should have received a copy of the GNU General +;;; Public License along with this program; if not, write +;;; to the Free Software Foundation, Inc., 59 Temple Place, +;;; Suite 330, Boston, MA 02111-1307 USA +;;; + (in-package "ELEPHANT") (defclass store-controller () ((path :type (or pathname string) - :reader path + :accessor controller-path :initarg :path) - (environment :type (or null pointer-void) :accessor environment) - (db :type (or null pointer-void) :accessor db) - (root :accessor root) + (environment :type (or null pointer-void) + :accessor controller-environment) + (db :type (or null pointer-void) :accessor controller-db) + (root :reader controller-root) (instance-cache :accessor instance-cache :initform (make-cache-table :test 'eql))) (:documentation "Class of objects responsible for handling @@ -20,11 +59,15 @@ persistables as well (though note collection key semantics!) N.B. this means it (and everything it points to) won't get gc'd." - (setf (get-value key (root sc)) value)) + (setf (get-value key (controller-root sc)) value)) (defmethod get-from-root ((sc store-controller) key) "Get a persistent thing from the root." - (get-value key (root sc))) + (get-value key (controller-root sc))) + +(defmethod remove-from-root ((sc store-controller) key) + "Get a persistent thing from the root." + (remove-kv key (controller-root sc))) (defmethod cache-instance ((sc store-controller) obj) "Register an instance of a user persistent-class with the @@ -32,38 +75,41 @@ (setf (get-cache (oid obj) (instance-cache sc)) obj)) (defmethod get-cached-instance ((sc store-controller) oid class-name) - (let ((obj (get-cache oid (instance-cache sc) nil))) + (let ((obj (get-cache oid (instance-cache sc)))) (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)) +(defmethod open-controller ((sc store-controller) &key (recover nil) + (recover-fatal nil) (thread t)) "Opens the underlying environment and all the necessary database tables." (let ((env (db-env-create))) ;; thread stuff? - (setf (environment sc) env) - (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) + (setf (controller-environment sc) env) + (db-env-open env (controller-path sc) :create t :init-txn t :init-lock t + :init-mpool t :init-log t :thread thread + :recover recover :recover-fatal recover-fatal) (let ((db (db-create env))) - (setf (db sc) db) - (db-open db :auto-commit t :type DB-BTREE :create t :thread t) + (setf (controller-db sc) db) + (db-open db :file "%ELEPHANT" :database "%ELEPHANTDB" + :auto-commit t :type DB-BTREE :create t :thread thread) (let ((root (make-instance 'btree :from-oid -1))) - (setf (root sc) root) + (setf (slot-value sc 'root) 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) + (setf (slot-value sc 'root) nil) ; clean instance cache (setf (instance-cache sc) (make-cache-table :test 'eql)) ; close environment - (db-close (db sc)) - (setf (db sc) nil) - (db-env-close (environment sc)) - (setf (environment sc) nil) + (db-close (controller-db sc)) + (setf (controller-db sc) nil) + (db-env-close (controller-environment sc)) + (setf (controller-environment sc) nil) nil) (defmacro with-open-controller ((&optional (sc *store-controller*)) @@ -73,6 +119,43 @@ (open-controller ,sc) , at body) (close-controller ,sc))) + +(defmacro with-transaction ((&key transaction + (environment (controller-environment + *store-controller*)) + (globally t) + (parent *current-transaction*) + dirty-read txn-nosync + txn-nowait txn-sync) + &body body) + `(sleepycat:with-transaction (:transaction ,transaction + :environment ,environment + :globally ,globally + :parent ,parent + :dirty-read ,dirty-read + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync) + , at body)) + +(defmacro with-transaction-retry ((&key transaction environment + (globally t) + (parent *current-transaction*) + (retries 100) + dirty-read txn-nosync + txn-nowait txn-sync) + &body body) + `(sleepycat:with-transaction-retry (:transaction ,transaction + :environment ,environment + :globally ,globally + :parent ,parent + :retries ,retries + :dirty-read ,dirty-read + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync) + , at body)) + ;; This stuff is all a hack until sequences appear in Sleepycat 4.3 (defconstant max-oid most-positive-fixnum) From blee at common-lisp.net Fri Aug 27 17:32:10 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:32:10 -0700 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv13592/src Modified Files: elephant.lisp Log Message: license, name changes, with-transaction* defaulters Date: Fri Aug 27 10:32:10 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.2 elephant/src/elephant.lisp:1.3 --- elephant/src/elephant.lisp:1.2 Thu Aug 26 19:57:52 2004 +++ elephant/src/elephant.lisp Fri Aug 27 10:32:10 2004 @@ -1,11 +1,58 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; elephant.lisp -- package definition and utilities +;;; +;;; Initial version 8/26/2004 by Ben Lee +;;; +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; This program is free software; you can redistribute it +;;; and/or modify it under the terms of the GNU General +;;; Public License as published by the Free Software +;;; Foundation; either version 2 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the +;;; implied warranty of MERCHANTABILITY or FITNESS FOR A +;;; PARTICULAR PURPOSE. See the GNU General Public License +;;; for more details. +;;; +;;; The GNU General Public License can be found in the file +;;; LICENSE which should have been distributed with this +;;; code. It can also be found at +;;; +;;; http://www.opensource.org/licenses/gpl-license.php +;;; +;;; You should have received a copy of the GNU General +;;; Public License along with this program; if not, write +;;; to the Free Software Foundation, Inc., 59 Temple Place, +;;; Suite 330, Boston, MA 02111-1307 USA +;;; + (defpackage elephant (:nicknames ele :ele) (:use common-lisp sleepycat) + (:shadow with-transaction with-transaction-retry) (:export *store-controller* *current-transaction* *auto-commit* store-controller open-controller close-controller - with-open-controller + with-open-controller controller-path controller-environment + controller-db controller-root + add-to-root get-from-root persistent persistent-object persistent-metaclass - with-transaction with-transaction-retry) + persistent-collection btree get-value remove-kv + db-transaction-begin db-transaction-abort db-transaction-commit + with-transaction with-transaction-retry + db-env-set-timeout db-env-get-timeout + db-env-set-flags db-env-get-flags + db-env-set-lock-detect db-env-get-lock-detect + ) #+cmu (:import-from :pcl slot-definition-name @@ -36,7 +83,7 @@ (defparameter *store-controller* nil "The store controller which persistent objects talk to.") -(defvar *auto-commit* nil) +(defvar *auto-commit* T) ;; Portable value-weak hash-tables for the cache: when the @@ -57,7 +104,7 @@ (defun get-cache (key cache) #+(or cmu sbcl scl) (let ((val (gethash key cache))) - (if val (values (weak-pointer-value val) t) + (if val (values (ext:weak-pointer-value val) t) (values nil nil))) #-(or cmu sbcl scl) (gethash key cache) @@ -65,8 +112,8 @@ (defun setf-cache (key cache value) #+(or cmu sbcl scl) - (let ((w (make-weak-pointer value))) - (finalize value #'(lambda () (remhash key cache))) + (let ((w (ext:make-weak-pointer value))) + (ext:finalize value #'(lambda () (remhash key cache))) (setf (gethash key cache) w) value) #+allegro From blee at common-lisp.net Fri Aug 27 17:32:33 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:32:33 -0700 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv13609/src Modified Files: collections.lisp Log Message: license, name changes Date: Fri Aug 27 10:32:32 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.2 elephant/src/collections.lisp:1.3 --- elephant/src/collections.lisp:1.2 Thu Aug 26 19:58:28 2004 +++ elephant/src/collections.lisp Fri Aug 27 10:32:32 2004 @@ -1,15 +1,53 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; collections.lisp -- view Berkeley DBs as Lisp collections +;;; +;;; Initial version 8/26/2004 by Ben Lee +;;; +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; This program is free software; you can redistribute it +;;; and/or modify it under the terms of the GNU General +;;; Public License as published by the Free Software +;;; Foundation; either version 2 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the +;;; implied warranty of MERCHANTABILITY or FITNESS FOR A +;;; PARTICULAR PURPOSE. See the GNU General Public License +;;; for more details. +;;; +;;; The GNU General Public License can be found in the file +;;; LICENSE which should have been distributed with this +;;; code. It can also be found at +;;; +;;; http://www.opensource.org/licenses/gpl-license.php +;;; +;;; You should have received a copy of the GNU General +;;; Public License along with this program; if not, write +;;; to the Free Software Foundation, Inc., 59 Temple Place, +;;; Suite 330, Boston, MA 02111-1307 USA +;;; + (in-package "ELEPHANT") ;;; collection types ;;; abstract hash-like collections ;;; equal hashing (except probably for array, hashe, instance keys!) -(defclass collection (persistent) ()) +(defclass persistent-collection (persistent) ()) (defgeneric get-value (key ht &rest args)) (defgeneric remove-kv (key ht &rest args)) ;;; btree access -(defclass btree (collection) ()) +(defclass btree (persistent-collection) ()) (defmethod get-value (key (ht btree) &rest args) (declare (ignore args)) @@ -17,9 +55,10 @@ (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)) + (deserialize (db-get-key-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length)) t) (db-error (err) (if (= (db-error-errno err) DB_NOTFOUND) @@ -34,7 +73,7 @@ (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*) + (db-put-buffered (controller-db *store-controller*) (buffer-stream-buffer *key-buf*) key-length (buffer-stream-buffer *out-buf*) val-length :transaction transaction @@ -47,7 +86,7 @@ (declare (ignore args)) (buffer-write-int (oid ht) *key-buf*) (let ((key-length (serialize key *key-buf*))) - (db-delete-buffered (db *store-controller*) + (db-delete-buffered (controller-db *store-controller*) (buffer-stream-buffer *key-buf*) key-length :transaction transaction :auto-commit auto-commit))) From blee at common-lisp.net Fri Aug 27 17:32:45 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:32:45 -0700 Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv13626/src Modified Files: libsleepycat.c Log Message: license Date: Fri Aug 27 10:32:44 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.2 elephant/src/libsleepycat.c:1.3 --- elephant/src/libsleepycat.c:1.2 Thu Aug 26 19:54:43 2004 +++ elephant/src/libsleepycat.c Fri Aug 27 10:32:44 2004 @@ -1,3 +1,41 @@ +/* +;;; +;;; libsleepycat.c -- C wrappers for Sleepycat for FFI +;;; +;;; Initial version 8/26/2004 by Ben Lee +;;; +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; This program is free software; you can redistribute it +;;; and/or modify it under the terms of the GNU General +;;; Public License as published by the Free Software +;;; Foundation; either version 2 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the +;;; implied warranty of MERCHANTABILITY or FITNESS FOR A +;;; PARTICULAR PURPOSE. See the GNU General Public License +;;; for more details. +;;; +;;; The GNU General Public License can be found in the file +;;; LICENSE which should have been distributed with this +;;; code. It can also be found at +;;; +;;; http://www.opensource.org/licenses/gpl-license.php +;;; +;;; You should have received a copy of the GNU General +;;; Public License along with this program; if not, write +;;; to the Free Software Foundation, Inc., 59 Temple Place, +;;; Suite 330, Boston, MA 02111-1307 USA +;;; +8? /* Pointer arithmetic utility functions */ From blee at common-lisp.net Fri Aug 27 17:32:51 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:32:51 -0700 Subject: [elephant-cvs] CVS update: elephant/src/serializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv13643/src Modified Files: serializer.lisp Log Message: license Date: Fri Aug 27 10:32:51 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.2 elephant/src/serializer.lisp:1.3 --- elephant/src/serializer.lisp:1.2 Thu Aug 26 19:57:36 2004 +++ elephant/src/serializer.lisp Fri Aug 27 10:32:51 2004 @@ -1,3 +1,41 @@ +;;; -*- 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 +;;; +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; This program is free software; you can redistribute it +;;; and/or modify it under the terms of the GNU General +;;; Public License as published by the Free Software +;;; Foundation; either version 2 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the +;;; implied warranty of MERCHANTABILITY or FITNESS FOR A +;;; PARTICULAR PURPOSE. See the GNU General Public License +;;; for more details. +;;; +;;; The GNU General Public License can be found in the file +;;; LICENSE which should have been distributed with this +;;; code. It can also be found at +;;; +;;; http://www.opensource.org/licenses/gpl-license.php +;;; +;;; You should have received a copy of the GNU General +;;; Public License along with this program; if not, write +;;; to the Free Software Foundation, Inc., 59 Temple Place, +;;; Suite 330, Boston, MA 02111-1307 USA +;;; + (in-package "ELEPHANT") (eval-when (:compile-toplevel :load-toplevel :execute) (use-package "UFFI")) From blee at common-lisp.net Fri Aug 27 17:32:56 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Fri, 27 Aug 2004 10:32:56 -0700 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv13660/src Modified Files: sleepycat.lisp Log Message: license Date: Fri Aug 27 10:32:56 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.2 elephant/src/sleepycat.lisp:1.3 --- elephant/src/sleepycat.lisp:1.2 Thu Aug 26 19:54:38 2004 +++ elephant/src/sleepycat.lisp Fri Aug 27 10:32:56 2004 @@ -1,13 +1,40 @@ -;; UFFI -;(asdf:operate 'asdf:load-op :uffi) - -;; DSO loading -;(defconstant +path-to-libsleepycat+ -; "/path/to/libsleepycat.so") -;(defconstant +path-to-sleepycat+ -; "/usr/local/lib/db42/libdb.so") -;(uffi:load-foreign-library +path-to-sleepycat+ :module "sleepycat") -;(uffi:load-foreign-library +path-to-libsleepycat+ :module "libsleepycat") +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; sleepycat.lisp -- FFI interface to Berkeley DB +;;; +;;; Initial version 8/26/2004 by Ben Lee +;;; +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; This program is free software; you can redistribute it +;;; and/or modify it under the terms of the GNU General +;;; Public License as published by the Free Software +;;; Foundation; either version 2 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the +;;; implied warranty of MERCHANTABILITY or FITNESS FOR A +;;; PARTICULAR PURPOSE. See the GNU General Public License +;;; for more details. +;;; +;;; The GNU General Public License can be found in the file +;;; LICENSE which should have been distributed with this +;;; code. It can also be found at +;;; +;;; http://www.opensource.org/licenses/gpl-license.php +;;; +;;; You should have received a copy of the GNU General +;;; Public License along with this program; if not, write +;;; to the Free Software Foundation, Inc., 59 Temple Place, +;;; Suite 330, Boston, MA 02111-1307 USA +;;; (defpackage sleepycat @@ -17,8 +44,8 @@ offset-char-pointer copy-str-to-buf copy-bufs byte-length pointer-int pointer-void array-or-pointer-char db-env-create db-env-close db-env-open db-env-dbremove - db-env-dbrename db-env-remove db-env-set-flags - db-env-get-flags + db-env-dbrename db-env-remove + db-env-set-flags db-env-get-flags db-create db-close db-open db-remove db-rename db-sync db-truncate db-get-key-buffered db-get-buffered db-get db-put-buffered db-put @@ -37,7 +64,71 @@ (in-package "SLEEPYCAT") +;; Constants and Flags +;; eventually write a macro which generates a custom flag function. + +;I don't like the UFFI syntax for enumerations +(defconstant DB-BTREE 1) +(defconstant DB-HASH 2) +(defconstant DB-QUEUE 3) +(defconstant DB-RECNO 4) +(defconstant DB-UNKNOWN 5) + +(defconstant DB_AUTO_COMMIT #x1000000) +(defconstant DB_JOINENV #x0040000) +(defconstant DB_INIT_CDB #x0001000) +(defconstant DB_INIT_LOCK #x0002000) +(defconstant DB_INIT_LOG #x0004000) +(defconstant DB_INIT_MPOOL #x0008000) +(defconstant DB_INIT_REP #x0010000) +(defconstant DB_INIT_TXN #x0020000) +(defconstant DB_RECOVER #x0000020) +(defconstant DB_RECOVER_FATAL #x0200000) +(defconstant DB_LOCKDOWN #x0080000) +(defconstant DB_PRIVATE #x0100000) +(defconstant DB_SYSTEM_MEM #x0400000) +(defconstant DB_THREAD #x0000040) +(defconstant DB_FORCE #x0000004) +(defconstant DB_DIRTY_READ #x2000000) +(defconstant DB_CREATE #x0000001) +(defconstant DB_EXCL #x0001000) +(defconstant DB_NOMMAP #x0000008) +(defconstant DB_RDONLY #x0000010) +(defconstant DB_TRUNCATE #x0000080) +(defconstant DB_TXN_NOSYNC #x0000100) +(defconstant DB_TXN_NOWAIT #x0001000) +(defconstant DB_TXN_SYNC #x0002000) + +(defconstant DB_GET_BOTH 10) +(defconstant DB_SET_LOCK_TIMEOUT 29) +(defconstant DB_SET_TXN_TIMEOUT 33) + +(def-enum lockop ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT + :PUT :PUT-ALL :PUT-OBJ :PUT-READ + :TIMEOUT :TRADE :UPGRADE-WRITE)) + +(def-enum lockmode ((:NG 0) :READ :WRITE :WAIT + :IWRITE :IREAD :IWR :DIRTY :WWRITE)) + +(def-struct db-lockreq + (op lockop) + (mode lockmode) + (timeout :unsigned-int) + (obj (:array :char)) + (lock :pointer-void)) + (eval-when (:compile-toplevel :load-toplevel) + ;; UFFI + ;;(asdf:operate 'asdf:load-op :uffi) + + ;; DSO loading + (defconstant +path-to-libsleepycat+ + "/home/ben/lisp/elephant/libsleepycat.so") + (defconstant +path-to-sleepycat+ + "/usr/local/lib/db42/libdb.so") + (uffi:load-foreign-library +path-to-sleepycat+ :module "sleepycat") + (uffi:load-foreign-library +path-to-libsleepycat+ :module "libsleepycat") + (def-type pointer-int (* :int)) (def-type pointer-void :pointer-void) (def-foreign-type array-or-pointer-char @@ -775,20 +866,6 @@ ;; Locks and timeouts -(def-enum lockop ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT - :PUT :PUT-ALL :PUT-OBJ :PUT-READ - :TIMEOUT :TRADE :UPGRADE-WRITE)) - -(def-enum lockmode ((:NG 0) :READ :WRITE :WAIT - :IWRITE :IREAD :IWR :DIRTY :WWRITE)) - -(def-struct db-lockreq - (op lockop) - (mode lockmode) - (timeout :unsigned-int) - (obj (:array :char)) - (lock :pointer-void)) - (def-function ("db_txn_id" db-transaction-id) ((transaction :pointer-void)) @@ -859,45 +936,6 @@ :returning :int) (wrap-errno db-env-lock-detect (env flags atype) :outs 2) - -;; Constants and Flags -;; eventually write a macro which generates a custom flag function. - -;I don't like the UFFI syntax for enumerations -(defconstant DB-BTREE 1) -(defconstant DB-HASH 2) -(defconstant DB-QUEUE 3) -(defconstant DB-RECNO 4) -(defconstant DB-UNKNOWN 5) - -(defconstant DB_AUTO_COMMIT #x1000000) -(defconstant DB_JOINENV #x0040000) -(defconstant DB_INIT_CDB #x0001000) -(defconstant DB_INIT_LOCK #x0002000) -(defconstant DB_INIT_LOG #x0004000) -(defconstant DB_INIT_MPOOL #x0008000) -(defconstant DB_INIT_REP #x0010000) -(defconstant DB_INIT_TXN #x0020000) -(defconstant DB_RECOVER #x0000020) -(defconstant DB_RECOVER_FATAL #x0200000) -(defconstant DB_LOCKDOWN #x0080000) -(defconstant DB_PRIVATE #x0100000) -(defconstant DB_SYSTEM_MEM #x0400000) -(defconstant DB_THREAD #x0000040) -(defconstant DB_FORCE #x0000004) -(defconstant DB_DIRTY_READ #x2000000) -(defconstant DB_CREATE #x0000001) -(defconstant DB_EXCL #x0001000) -(defconstant DB_NOMMAP #x0000008) -(defconstant DB_RDONLY #x0000010) -(defconstant DB_TRUNCATE #x0000080) -(defconstant DB_TXN_NOSYNC #x0000100) -(defconstant DB_TXN_NOWAIT #x0001000) -(defconstant DB_TXN_SYNC #x0002000) - -(defconstant DB_GET_BOTH 10) -(defconstant DB_SET_LOCK_TIMEOUT 29) -(defconstant DB_SET_TXN_TIMEOUT 33) (defun flags (&key auto-commit From blee at common-lisp.net Sat Aug 28 06:37:58 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 28 Aug 2004 08:37:58 +0200 Subject: [elephant-cvs] CVS update: elephant/elephant.asd Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv20476 Modified Files: elephant.asd Log Message: changed to serial compilation -- still getting weird performance issues with recompilation! Date: Sat Aug 28 08:37:57 2004 Author: blee Index: elephant/elephant.asd diff -u elephant/elephant.asd:1.1 elephant/elephant.asd:1.2 --- elephant/elephant.asd:1.1 Fri Aug 27 19:30:09 2004 +++ elephant/elephant.asd Sat Aug 28 08:37:57 2004 @@ -24,11 +24,12 @@ ((:module :src :components ((:file "sleepycat") - (:file "elephant" :depends-on ("sleepycat")) - (:file "serializer" :depends-on ("elephant")) - (:file "classes" :depends-on ("elephant")) - (:file "controller" :depends-on ("elephant")) - (:file "collections" :depends-on ("elephant"))))) + (:file "elephant") + (:file "classes") + (:file "collections") + (:file "controller") + (:file "serializer")) + :serial t)) :depends-on (:uffi)) From blee at common-lisp.net Sat Aug 28 06:39:31 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 28 Aug 2004 08:39:31 +0200 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv22059/src Modified Files: collections.lisp Log Message: performance tweaking Date: Sat Aug 28 08:39:31 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.3 elephant/src/collections.lisp:1.4 --- elephant/src/collections.lisp:1.3 Fri Aug 27 19:32:32 2004 +++ elephant/src/collections.lisp Sat Aug 28 08:39:30 2004 @@ -43,47 +43,37 @@ ;;; equal hashing (except probably for array, hashe, instance keys!) (defclass persistent-collection (persistent) ()) -(defgeneric get-value (key ht &rest args)) -(defgeneric remove-kv (key ht &rest args)) +;(defgeneric get-value (key ht &rest args)) +;(defgeneric remove-kv (key ht &rest args)) ;;; btree access (defclass btree (persistent-collection) ()) -(defmethod get-value (key (ht btree) &rest args) - (declare (ignore args)) +(defmethod get-value (key (ht btree)) + (declare (optimize (speed 3) (safety 0) (space 3))) (buffer-write-int (oid ht) *key-buf*) (let ((key-length (serialize key *key-buf*))) - (handler-case - (values - (deserialize (db-get-key-buffered - (controller-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)))))) + (declare (type fixnum key-length)) + (deserialize (db-get-key-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length)))) -(defmethod (setf get-value) (value key (ht btree) &rest args - &key (transaction *current-transaction*) - (auto-commit *auto-commit*) - &allow-other-keys) - (declare (ignore args)) +(defmethod (setf get-value) (value key (ht btree)) + (declare (optimize (speed 3) (safety 0))) (buffer-write-int (oid ht) *key-buf*) (let ((key-length (serialize key *key-buf*)) (val-length (serialize value *out-buf*))) (db-put-buffered (controller-db *store-controller*) (buffer-stream-buffer *key-buf*) key-length (buffer-stream-buffer *out-buf*) val-length - :transaction transaction - :auto-commit auto-commit))) + :transaction *current-transaction* + :auto-commit *auto-commit*))) -(defmethod remove-kv (key (ht btree) &rest args +(defmethod remove-kv (key (ht btree) &key (transaction *current-transaction*) - (auto-commit *auto-commit*) - &allow-other-keys) - (declare (ignore args)) + (auto-commit *auto-commit*)) + (declare (optimize (speed 3) (safety 0))) (buffer-write-int (oid ht) *key-buf*) (let ((key-length (serialize key *key-buf*))) (db-delete-buffered (controller-db *store-controller*) From blee at common-lisp.net Sat Aug 28 06:39:57 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 28 Aug 2004 08:39:57 +0200 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv22079/src Modified Files: controller.lisp Log Message: poor man's counters, performance tweaking Date: Sat Aug 28 08:39:56 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.3 elephant/src/controller.lisp:1.4 --- elephant/src/controller.lisp:1.3 Fri Aug 27 19:31:59 2004 +++ elephant/src/controller.lisp Sat Aug 28 08:39:56 2004 @@ -80,6 +80,33 @@ ;; Should get cached since make-instance calls cache-instance (make-instance class-name :from-oid oid)))) + +;; OID stuff +;; This stuff is all a hack until sequences appear in Sleepycat 4.3 +(defvar %oid-entry (uffi:allocate-foreign-object :char 12)) +(defvar %oid-lock (uffi:allocate-foreign-object :char 16)) + +(eval-when (:load-toplevel) + (loop for c across "%ELEPHANTOID" + for i from 0 to 11 + do (setf (uffi:deref-array %oid-entry '(:array :char) i) + (char-code c))) + (loop for c across "%ELEPHANTOIDLOCK" + for i from 0 to 15 + do (setf (uffi:deref-array %oid-lock '(:array :char) i) + (char-code c))) + ) + +(defvar %oid-entry-length 12) +(defvar %oid-lock-length 16) + +(defmethod next-oid ((sc store-controller)) + (sleepycat::next-counter (controller-environment sc) + (controller-db sc) + %oid-entry %oid-entry-length + %oid-lock %oid-lock-length)) + +;; Open/close (defmethod open-controller ((sc store-controller) &key (recover nil) (recover-fatal nil) (thread t)) "Opens the underlying environment and all the necessary @@ -96,6 +123,13 @@ :auto-commit t :type DB-BTREE :create t :thread thread) (let ((root (make-instance 'btree :from-oid -1))) (setf (slot-value sc 'root) root) + (let ((*auto-commit* t)) + (unless (db-get-key-buffered db %oid-entry %oid-entry-length) + (buffer-write-int 0 *out-buf*) + (db-put-buffered db %oid-entry %oid-entry-length + (buffer-stream-buffer *out-buf*) 4 + :auto-commit t) + (finish-buffer *out-buf*))) sc)))) (defmethod close-controller ((sc store-controller)) @@ -120,47 +154,3 @@ , at body) (close-controller ,sc))) -(defmacro with-transaction ((&key transaction - (environment (controller-environment - *store-controller*)) - (globally t) - (parent *current-transaction*) - dirty-read txn-nosync - txn-nowait txn-sync) - &body body) - `(sleepycat:with-transaction (:transaction ,transaction - :environment ,environment - :globally ,globally - :parent ,parent - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync) - , at body)) - -(defmacro with-transaction-retry ((&key transaction environment - (globally t) - (parent *current-transaction*) - (retries 100) - dirty-read txn-nosync - txn-nowait txn-sync) - &body body) - `(sleepycat:with-transaction-retry (:transaction ,transaction - :environment ,environment - :globally ,globally - :parent ,parent - :retries ,retries - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync) - , at body)) - - -;; 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)) - - \ No newline at end of file From blee at common-lisp.net Sat Aug 28 06:40:19 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 28 Aug 2004 08:40:19 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv22102/src Modified Files: elephant.lisp Log Message: no with-transaction-retry Date: Sat Aug 28 08:40:18 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.3 elephant/src/elephant.lisp:1.4 --- elephant/src/elephant.lisp:1.3 Fri Aug 27 19:32:10 2004 +++ elephant/src/elephant.lisp Sat Aug 28 08:40:18 2004 @@ -39,7 +39,7 @@ (defpackage elephant (:nicknames ele :ele) (:use common-lisp sleepycat) - (:shadow with-transaction with-transaction-retry) + (:shadow with-transaction) (:export *store-controller* *current-transaction* *auto-commit* store-controller open-controller close-controller with-open-controller controller-path controller-environment @@ -48,7 +48,7 @@ persistent persistent-object persistent-metaclass persistent-collection btree get-value remove-kv db-transaction-begin db-transaction-abort db-transaction-commit - with-transaction with-transaction-retry + with-transaction db-env-set-timeout db-env-get-timeout db-env-set-flags db-env-get-flags db-env-set-lock-detect db-env-get-lock-detect @@ -125,3 +125,20 @@ ) (defsetf get-cache setf-cache) + +;; Good defaults for elephant +(defmacro with-transaction ((&key transaction + (environment (controller-environment + *store-controller*)) + (parent '*current-transaction*) + dirty-read txn-nosync + txn-nowait txn-sync) + &body body) + `(sleepycat:with-transaction (:transaction ,transaction + :environment ,environment + :parent ,parent + :dirty-read ,dirty-read + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync) + , at body)) From blee at common-lisp.net Sat Aug 28 06:40:33 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 28 Aug 2004 08:40:33 +0200 Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv22122/src Modified Files: libsleepycat.c Log Message: poor man's counters Date: Sat Aug 28 08:40:33 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.3 elephant/src/libsleepycat.c:1.4 --- elephant/src/libsleepycat.c:1.3 Fri Aug 27 19:32:44 2004 +++ elephant/src/libsleepycat.c Sat Aug 28 08:40:33 2004 @@ -368,6 +368,26 @@ return env->lock_id_free(env, id); } +int db_env_lock_get(DB_ENV *env, u_int32_t locker, + u_int32_t flags, char *object, u_int32_t object_length, + const db_lockmode_t lock_mode, DB_LOCK *lock) { + DBT DBTObject; + memset(&DBTObject, 0, sizeof(DBT)); + DBTObject.data = object; + DBTObject.size = object_length; + + return env->lock_get(env, locker, flags, &DBTObject, lock_mode, lock); +} + +int db_env_lock_put(DB_ENV *env, DB_LOCK *lock) { + return env->lock_put(env, lock); +} + +int db_env_lock_vec(DB_ENV *env, u_int32_t locker, u_int32_t flags, + DB_LOCKREQ list[], int nlist, DB_LOCKREQ **elistp) { + return env->lock_vec(env, locker, flags, list, nlist, elistp); +} + /* db_timeout_t = u_int32_t */ int db_env_set_timeout(DB_ENV *env, db_timeout_t timeout, u_int32_t flags) { return env->set_timeout(env, timeout, flags); @@ -390,3 +410,72 @@ return env->lock_detect(env, flags, atype, aborted); } +/* Poor man's counters */ + +int next_counter(DB_ENV *env, DB *db, char *key, u_int32_t key_length, + char *lockid, u_int32_t lockid_length) { + DB_LOCK lock; + DBT DBTKey, DBTData; + DB_TXN *tid; + int counter, tries, ret, t_ret; + u_int32_t id; + + /* Initialization. */ + memset(&lock, 0, sizeof(lock)); + memset(&DBTKey, 0, sizeof(DBTKey)); + memset(&DBTData, 0, sizeof(DBTData)); + DBTKey.data = key; + DBTKey.size = key_length; + DBTData.data = lockid; + DBTData.size = lockid_length; + tries = 0; + + loop: + /* Begin the transaction. */ + if ((ret = env->txn_begin(env, NULL, &tid, 0)) != 0) { + env->err(env, ret, "DB_ENV->txn_begin"); + return (-1); + } + + id = tid->id(tid); + + if ((ret = env->lock_get(env, id, 0, &DBTData, DB_LOCK_WRITE, &lock)) != 0) + goto fail; + + memset(&DBTData, 0, sizeof(DBTData)); + DBTData.data = &counter; + DBTData.ulen = sizeof(counter); + DBTData.flags |= DB_DBT_USERMEM; + + if ((ret = db->get(db, tid, &DBTKey, &DBTData, 0)) != 0) + goto fail; + + ++counter; + + memset(&DBTData, 0, sizeof(DBTData)); + DBTData.data = &counter; + DBTData.size = sizeof(counter); + + if ((ret = db->put(db, tid, &DBTKey, &DBTData, 0)) != 0) + goto fail; + + if ((ret = env->lock_put(env, &lock)) != 0) + goto fail; + + if ((ret = tid->commit(tid, 0)) != 0) { + env->err(env, ret, "DB_TXN->commit"); + return (-2); + } + return (counter); + + + fail: + /* Abort and retry the operation. */ + if ((t_ret = tid->abort(tid)) != 0) { + env->err(env, t_ret, "DB_TXN->abort"); + return (-3); + } + if (tries++ == 100) + return (-4); + goto loop; +} From blee at common-lisp.net Sat Aug 28 06:41:00 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 28 Aug 2004 08:41:00 +0200 Subject: [elephant-cvs] CVS update: elephant/src/serializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv22143/src Modified Files: serializer.lisp Log Message: deserialize can take nil Date: Sat Aug 28 08:41:00 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.3 elephant/src/serializer.lisp:1.4 --- elephant/src/serializer.lisp:1.3 Fri Aug 27 19:32:51 2004 +++ elephant/src/serializer.lisp Sat Aug 28 08:41:00 2004 @@ -56,9 +56,9 @@ ;; Constants (defconstant +fixnum+ (char-code #\f)) +(defconstant +nil+ (char-code #\N)) (defconstant +symbol+ (char-code #\S)) (defconstant +string+ (char-code #\s)) -(defconstant +nil+ (char-code #\N)) (defconstant +persistent+ (char-code #\P)) (defconstant +single-float+ (char-code #\F)) (defconstant +double-float+ (char-code #\D)) @@ -107,6 +107,8 @@ (fixnum (buffer-write-byte +fixnum+ bs) (buffer-write-int frob bs)) + (null + (buffer-write-byte +nil+ bs)) (symbol (let ((s (symbol-name frob))) (declare (type string s) (dynamic-extent s)) @@ -117,8 +119,6 @@ (buffer-write-byte +string+ bs) (buffer-write-int (byte-length frob) bs) (buffer-write-string frob bs)) - (null - (buffer-write-byte +nil+ bs)) (persistent (buffer-write-byte +persistent+ bs) (buffer-write-int (oid frob) bs) @@ -238,7 +238,8 @@ (defun deserialize (buf) (declare (optimize (speed 3) (safety 0)) - (type array-or-pointer-char buf)) + (type (or null array-or-pointer-char) buf)) + (unless buf (return-from deserialize nil)) (setf (buffer-stream-buffer *in-buf*) buf) (setf (buffer-stream-position *in-buf*) 0) (setq *lisp-obj-id* 0) @@ -249,14 +250,14 @@ (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) (declare (type foreign-char tag)) - (cond + (cond ((= tag +fixnum+) (buffer-read-fixnum bs)) + ((= tag +nil+) nil) ((= tag +symbol+) (intern (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) ((= tag +string+) (buffer-read-string bs (buffer-read-fixnum bs))) - ((= tag +nil+) nil) ((= tag +persistent+) (get-cached-instance *store-controller* (buffer-read-fixnum bs) From blee at common-lisp.net Sat Aug 28 06:41:50 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sat, 28 Aug 2004 08:41:50 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv22194/src Modified Files: sleepycat.lisp Log Message: fixed with-transaction (no separate retry version) to use throw / catch (non-consing!). poor man's counters. Date: Sat Aug 28 08:41:49 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.3 elephant/src/sleepycat.lisp:1.4 --- elephant/src/sleepycat.lisp:1.3 Fri Aug 27 19:32:56 2004 +++ elephant/src/sleepycat.lisp Sat Aug 28 08:41:49 2004 @@ -50,16 +50,19 @@ db-remove db-rename db-sync db-truncate db-get-key-buffered db-get-buffered db-get db-put-buffered db-put db-delete-buffered db-delete - *current-transaction* - db-transaction-begin db-transaction-abort db-transaction-commit - with-transaction with-transaction-retry + *current-transaction* db-transaction-begin db-transaction-abort + db-transaction-commit with-transaction db-transaction-id db-env-lock-id db-env-lock-id-free + db-env-lock-get db-env-lock-put with-lock db-env-set-timeout db-env-get-timeout db-env-set-lock-detect db-env-get-lock-detect - DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN - +NULL-VOID+ +NULL-CHAR+ db-error db-error-errno + +NULL-VOID+ +NULL-CHAR+ + DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN DB_KEYEMPTY DB_LOCK_DEADLOCK DB_LOCK_NOTGRANTED DB_NOTFOUND + DB-LOCKMODE#NG DB-LOCKMODE#READ DB-LOCKMODE#WRITE + DB-LOCKMODE#wAIT DB-LOCKMODE#IWRITE DB-LOCKMODE#IREAD + DB-LOCKMODE#IWR DB-LOCKMODE#DIRTY DB-LOCKMODE#WWRITE )) (in-package "SLEEPYCAT") @@ -98,24 +101,17 @@ (defconstant DB_TXN_NOSYNC #x0000100) (defconstant DB_TXN_NOWAIT #x0001000) (defconstant DB_TXN_SYNC #x0002000) +(defconstant DB_LOCK_NOWAIT #x001) (defconstant DB_GET_BOTH 10) (defconstant DB_SET_LOCK_TIMEOUT 29) (defconstant DB_SET_TXN_TIMEOUT 33) -(def-enum lockop ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT - :PUT :PUT-ALL :PUT-OBJ :PUT-READ - :TIMEOUT :TRADE :UPGRADE-WRITE)) - -(def-enum lockmode ((:NG 0) :READ :WRITE :WAIT - :IWRITE :IREAD :IWR :DIRTY :WWRITE)) - -(def-struct db-lockreq - (op lockop) - (mode lockmode) - (timeout :unsigned-int) - (obj (:array :char)) - (lock :pointer-void)) +(defconstant DB_KEYEMPTY -30997) +(defconstant DB_LOCK_DEADLOCK -30995) +(defconstant DB_LOCK_NOTGRANTED -30994) +(defconstant DB_NOTFOUND -30990) + (eval-when (:compile-toplevel :load-toplevel) ;; UFFI @@ -149,6 +145,7 @@ %db-txn-begin db-transaction-begin %db-txn-abort db-transaction-abort %db-txn-commit db-transaction-commit + %db-transaction-id flags)) ;; Buffer management / pointer arithmetic @@ -348,7 +345,8 @@ ) (defmacro wrap-errno (names args &key (keys nil) (flags nil) - (cstrings nil) (outs 1) (declarations nil)) + (cstrings nil) (outs 1) (declarations nil) + (transaction nil)) (let ((wname (if (listp names) (first names) names)) (fname (if (listp names) (second names) (intern (concatenate 'string "%" (symbol-name names))))) @@ -364,16 +362,27 @@ (,fname , at fun-args) (let ((,errno ,(first out-args))) (declare (type fixnum ,errno)) - (if (= ,errno 0) - (values ,@(rest out-args)) - (error 'db-error :errno ,errno))))))) + (cond + ((= ,errno 0) (values ,@(rest out-args))) + ,@(if transaction + (list `((or (= ,errno DB_LOCK_DEADLOCK) + (= ,errno DB_LOCK_NOTGRANTED)) + (throw ,transaction ,transaction))) + (values)) + (t (error 'db-error :errno ,errno)))))))) `(defun ,wname ,wrapper-args ,@(if declarations (list declarations) (values)) (with-cstrings ,(symbols-to-pairs cstrings) (let ((,errno (,fname , at fun-args))) (declare (type fixnum ,errno)) - (unless (= ,errno 0) - (error 'db-error :errno ,errno)))))))) + (cond + ((= ,errno 0) nil) + ,@(if transaction + (list `((or (= ,errno DB_LOCK_DEADLOCK) + (= ,errno DB_LOCK_NOTGRANTED)) + (throw ,transaction ,transaction))) + (values)) + (t (error 'db-error :errno ,errno))))))))) ;; Environment @@ -425,7 +434,8 @@ :flags (auto-commit) :keys ((transaction *current-transaction*) (database +NULL-CHAR+)) - :cstrings (file database)) + :cstrings (file database) + :transaction transaction) (def-function ("db_env_dbrename" %db-env-dbrename) ((env :pointer-void) @@ -440,7 +450,8 @@ :flags (auto-commit) :keys ((transaction *current-transaction*) (database +NULL-CHAR+)) - :cstrings (file database newname)) + :cstrings (file database newname) + :transaction transaction) (def-function ("db_env_remove" %db-env-remove) ((env :pointer-void) @@ -509,7 +520,8 @@ (database +NULL-CHAR+) (type DB-UNKNOWN) (mode #o640)) - :cstrings (file database)) + :cstrings (file database) + :transaction transaction) (def-function ("db_remove" %db-remove) ((db :pointer-void) @@ -549,7 +561,8 @@ :returning :int) (wrap-errno db-truncate (db transaction flags) :flags (auto-commit) - :keys ((transaction *current-transaction*)) :outs 2) + :keys ((transaction *current-transaction*)) :outs 2 + :transaction transaction) ;; Accessors @@ -582,11 +595,17 @@ :dirty-read dirty-read)) (declare (type fixnum result-length errno)) (if (<= result-length *get-buffer-length*) - (if (= errno 0) - (return-from db-get-key-buffered - (the (values array-or-pointer-char fixnum) - (values *get-buffer* result-length))) - (error 'db-error :errno errno)) + (cond + ((= errno 0) + (return-from db-get-key-buffered + (the (values array-or-pointer-char fixnum) + (values *get-buffer* result-length)))) + ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) + (return-from db-get-key-buffered + (the (values null fixnum) (values nil 0)))) + ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) + (throw transaction transaction)) + (t (error 'db-error :errno errno))) (resize-get-buffer result-length))))) (def-function ("db_get_raw" %db-get-buffered) @@ -620,11 +639,17 @@ :dirty-read dirty-read)) (declare (type fixnum result-length errno)) (if (<= result-length *get-buffer-length*) - (if (= errno 0) - (return-from db-get-buffered - (the (values array-or-pointer-char fixnum) - (values *get-buffer* result-length))) - (error 'db-error :errno errno)) + (cond + ((= errno 0) + (return-from db-get-buffered + (the (values array-or-pointer-char fixnum) + (values *get-buffer* result-length)))) + ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) + (return-from db-get-buffered + (the (values null fixnum) (values nil 0)))) + ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) + (throw transaction transaction)) + (t (error 'db-error :errno errno))) (resize-get-buffer result-length)))))) (defun db-get (db key &key (key-length (length key)) @@ -646,12 +671,17 @@ :dirty-read dirty-read)) (declare (type fixnum result-length errno)) (if (<= result-length *get-buffer-length*) - (if (= errno 0) - (return-from db-get - (convert-from-foreign-string *get-buffer* - :length result-length - :null-terminated-p nil)) - (error 'db-error :errno errno)) + (cond + ((= errno 0) + (return-from db-get + (convert-from-foreign-string *get-buffer* + :length result-length + :null-terminated-p nil))) + ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY)) + (return-from db-get nil)) + ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED)) + (throw transaction transaction)) + (t (error 'db-error :errno errno))) (resize-get-buffer result-length)))))) (def-function ("db_put_raw" %db-put-buffered) @@ -672,7 +702,8 @@ (type pointer-void db transaction) (type array-or-pointer-char key datum) (type fixnum key-length datum-length) - (type boolean auto-commit))) + (type boolean auto-commit)) + :transaction transaction) (def-function ("db_put_raw" %db-put) ((db :pointer-void) @@ -694,7 +725,8 @@ (type pointer-void db transaction) (type string key datum) (type fixnum key-length datum-length) - (type boolean auto-commit))) + (type boolean auto-commit)) + :transaction transaction) (def-function ("db_del" %db-delete-buffered) ((db :pointer-void) @@ -711,7 +743,8 @@ (type pointer-void db transaction) (type array-or-pointer-char key) (type fixnum key-length) - (type boolean auto-commit))) + (type boolean auto-commit)) + :transaction transaction) (def-function ("db_del" %db-delete) ((db :pointer-void) @@ -730,7 +763,8 @@ (type pointer-void db transaction) (type string key) (type fixnum key-length) - (type boolean auto-commit))) + (type boolean auto-commit)) + :transaction transaction) ;; Transactions @@ -785,33 +819,39 @@ (type boolean txn-nosync txn-sync))) (defmacro with-transaction ((&key transaction environment - (globally t) - (parent *current-transaction*) + (parent '*current-transaction*) + (retries 100) dirty-read txn-nosync txn-nowait txn-sync) &body body) (let ((txn (if transaction transaction (gensym))) + (count (gensym)) + (result (gensym)) (success (gensym))) - `(let* ((,txn (db-transaction-begin ,environment - :parent ,parent - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync)) - (,success nil) - ,@(if globally `((*current-transaction* ,txn)) - (values))) - (declare (dynamic-extent ,txn ,success) - (type pointer-void ,txn) - (type boolean ,success)) - (unwind-protect - (prog1 - (progn , at body) - (setq ,success t) - (db-transaction-commit :transaction ,txn - :txn-nosync ,txn-nosync - :txn-sync ,txn-sync)) - (unless ,success (db-transaction-abort :transaction ,txn)))))) + `(loop for ,count fixnum from 1 to ,retries + for ,txn of-type pointer-void = + (db-transaction-begin ,environment + :parent ,parent + :dirty-read ,dirty-read + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync) + for ,success of-type boolean = nil + for ,result = + (let ((*current-transaction* ,txn)) + (catch ,txn + (unwind-protect + (prog1 (progn , at body) + (setq ,success t) + (db-transaction-commit :transaction ,txn + :txn-nosync ,txn-nosync + :txn-sync ,txn-sync)) + (unless ,success + (db-transaction-abort :transaction ,txn))))) + do + (unless (and (eq ,result ,txn) (not ,success)) + (return ,result)) + finally (error "Too many retries")))) ;; this is code for a non-consing with-transaction. which ;; doesn't work in the (globally t) case (e.g. setting @@ -838,39 +878,36 @@ ; :txn-sync ,txn-sync))) ; (unless ,success (%db-txn-abort ,txn))))))) -(defmacro with-transaction-retry ((&key transaction environment - (globally t) - (parent *current-transaction*) - (retries 100) - dirty-read txn-nosync - txn-nowait txn-sync) - &body body) - (let ((ret-tag (gensym)) - (retry-count (gensym))) - `(let ((,retry-count 0)) - (tagbody ,ret-tag - (handler-case - (with-transaction (:tranasction ,transaction - :environment ,environment - :globally ,globally - :parent ,parent - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync) - ,body) - (db-error (err) - (if (< (incf ,retry-count) ,retries) - (go ,ret-tag) - (error err)))))))) ;; Locks and timeouts -(def-function ("db_txn_id" db-transaction-id) +(def-enum DB-LOCKOP ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT + :PUT :PUT-ALL :PUT-OBJ :PUT-READ + :TIMEOUT :TRADE :UPGRADE-WRITE)) + +(def-enum DB-LOCKMODE ((:NG 0) :READ :WRITE :WAIT + :IWRITE :IREAD :IWR :DIRTY :WWRITE)) + +(def-struct DB-LOCK + (off :unsigned-int) + (ndx :unsigned-int) + (gen :unsigned-int) + (mode DB-LOCKMODE)) + +(def-struct DB-LOCKREQ + (op DB-LOCKOP) + (mode DB-LOCKMODE) + (timeout :unsigned-int) + (obj (:array :char)) + (lock (* DB-LOCK))) + +(def-function ("db_txn_id" %db-transaction-id) ((transaction :pointer-void)) :returning :unsigned-int) +(defun db-transaction-id (&optional (transaction *current-transaction*)) + (%db-transaction-id transaction)) (def-function ("db_env_lock_id" %db-env-lock-id) ((env :pointer-void) @@ -887,6 +924,52 @@ (wrap-errno db-env-lock-id-free (env id)) +(def-function ("db_env_lock_get" %db-env-lock-get) + ((env :pointer-void) + (locker :unsigned-int) + (flags :unsigned-int) + (object array-or-pointer-char) + (object-length :unsigned-int) + (lock-mode DB-LOCKMODE) + (lock (* DB-LOCK))) + :returning :int) + +(wrap-errno db-env-lock-get (env locker flags object object-length + lock-mode lock) + :flags (lock-nowait)) + +(def-function ("db_env_lock_put" %db-env-lock-put) + ((env :pointer-void) + (lock (* DB-LOCK))) + :returning :int) + +(wrap-errno db-env-lock-put (env lock)) + +(defmacro with-lock ((env locker object object-length + &key (lock-mode DB-LOCKMODE#WRITE) + lock-nowait) + &body body) + (let ((lock (gensym)) + (locked (gensym))) + `(with-foreign-object (,lock 'DB-LOCK) + (let ((,locked nil)) + (unwind-protect + (progn + (db-env-lock-get ,env ,locker ,object ,object-length ,lock-mode + ,lock :lock-nowait ,lock-nowait) + (setq ,locked T) + , at body) + (when ,locked (db-env-lock-put ,env ,lock))))))) + +(def-function ("db_env_lock_vec" %db-env-lock-vec) + ((env :pointer-void) + (locker :unsigned-int) + (flags :unsigned-int) + (list (:array DB-LOCKREQ)) + (nlist :int) + (elistp (* (* DB-LOCKREQ)))) + :returning :int) + (def-function ("db_env_set_timeout" %db-env-set-timeout) ((env :pointer-void) (timeout :unsigned-int) @@ -937,6 +1020,25 @@ (wrap-errno db-env-lock-detect (env flags atype) :outs 2) +;; Poor man's counters + +(def-function ("next_counter" %next-counter) + ((env :pointer-void) + (db :pointer-void) + (key array-or-pointer-char) + (key-length :unsigned-int) + (lockid array-or-pointer-char) + (lockid-length :unsigned-int)) + :returning :int) + +(defun next-counter (env db key key-length lockid lockid-length) + (let ((ret (%next-counter env db key key-length lockid lockid-length))) + (if (< ret 0) + (error 'db-error :errno ret) + ret)))) + +;; Misc + (defun flags (&key auto-commit joinenv @@ -964,7 +1066,8 @@ txn-nowait txn-sync set-lock-timeout - set-transaction-timeout) + set-transaction-timeout + lock-nowait) (let ((flags 0)) (declare (optimize (speed 3) (safety 0) (space 0)) (type (unsigned-byte 32) flags) @@ -1002,14 +1105,10 @@ (when txn-sync (setq flags (logior flags DB_TXN_SYNC))) (when set-lock-timeout (setq flags (logior flags DB_SET_LOCK_TIMEOUT))) (when set-transaction-timeout (setq flags (logior flags DB_SET_TXN_TIMEOUT))) + (when lock-nowait (setq flags (logior flags DB_LOCK_NOWAIT))) flags)) ;; Errors - -(defconstant DB_KEYEMPTY -30997) -(defconstant DB_LOCK_DEADLOCK -30995) -(defconstant DB_LOCK_NOTGRANTED -30994) -(defconstant DB_NOTFOUND -30990) (def-function ("db_strerr" %db-strerror) ((error :int)) From blee at common-lisp.net Sun Aug 29 07:43:20 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:43:20 +0200 Subject: [elephant-cvs] CVS update: elephant/INSTALL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv29548 Modified Files: INSTALL Log Message: linux / sbcl Date: Sun Aug 29 09:43:19 2004 Author: blee Index: elephant/INSTALL diff -u elephant/INSTALL:1.1 elephant/INSTALL:1.2 --- elephant/INSTALL:1.1 Fri Aug 27 19:28:09 2004 +++ elephant/INSTALL Sun Aug 29 09:43:19 2004 @@ -37,14 +37,16 @@ /usr/local/lib/db42/libdb.so and /usr/local/include/db42/db.h.) -3) Compile src/libsleepycat.c. I'm no gcc master but under -FreeBSD I did +3) Compile src/libsleepycat.c. I'm no gcc master but under +FreeBSD this worked for me: -gcc -L/usr/local/lib/db42 -I/usr/local/include -fPIC -shared -O3 -o libsleepycat.so src/libsleepycat.c -ldb +gcc -L/usr/local/lib/db42 -I/usr/local/include/db42 -fPIC -shared -O3 -o libsleepycat.so src/libsleepycat.c -ldb you may or may not need a trailing -ldb at the end. Put -libsleepycat.so somewhere you can get at it, like -/usr/local/lib/. +libsleepycat.so somewhere you can get at it, like in your +common-lisp elephant system dir + +/usr/local/share/common-lisp/elephant/ 4) Compile and load Elephant. @@ -59,10 +61,16 @@ (asdf:operate 'asdf:load-op :elephant) This will load and compile Elephant. This will also -automatically load UFFI. +automatically load UFFI. You will get some errors about +redefining constants probably. Go ahead and redefine them, +they are safe to bash, and won't happen again once you've +compiled. At this point I advise quitting lisp before using Elephant. -I get symbol conflicts otherwise. (Help?) +I get symbol conflicts otherwise. (Help?) I also (under +CMUCL) get strange behavior which indicates you might get +better performance if you compile everything again with +everything loaded. ----------- Quick Start @@ -147,4 +155,4 @@ "my string" T -CL-USER> \ No newline at end of file +CL-USER> From blee at common-lisp.net Sun Aug 29 07:44:47 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:44:47 +0200 Subject: [elephant-cvs] CVS update: elephant/NOTES Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv29590 Modified Files: NOTES Log Message: updates Date: Sun Aug 29 09:44:47 2004 Author: blee Index: elephant/NOTES diff -u elephant/NOTES:1.2 elephant/NOTES:1.3 --- elephant/NOTES:1.2 Fri Aug 27 19:31:08 2004 +++ elephant/NOTES Sun Aug 29 09:44:47 2004 @@ -26,13 +26,15 @@ While I loath specials, since you can't change the signature of slot accessors, in order to pass parameters to the -database / serializer, specials are needed. The store -controller (see below) is also a special. +database / serializer, specials are needed. Also specials +will probably play nice with threaded lisps. ----------------------- CLASSES AND METACLASSES ----------------------- +***Andrew write your stuff here*** + Persistent classes which the user defines are declared and instrumented by using the persistent-metaclass. @@ -41,16 +43,21 @@ ----------- While we support serializing and persisting a wide class of -Lisp data types, there are problems with aggregate types -(conses, lists, arrays, objects, hash-tables...) +Lisp data types, there are problems with persisting +aggregate types (conses, lists, arrays, objects, +hash-tables...) 1) not automatic: there's no way for elephant to know when you've changed a value in an aggregate object, so you have to manually restore it back into the slot to get it saved. -slot-1 of obj A contains a cons. you change the car of the -cons. this is not reflected into the database unless you -re-set slot-1 of obj A with the cons. +example 1: you put a cons into the database. you change +it's car. this is not saved unless you resave the cons into +the database. + +example 2: slot-1 of obj A (saved in the database) contains +a cons. you change the car of the cons. this is not +reflected into the database unless you resave A. 2) merge-conflicts: changing one value and saving an aggregate will write out the whole aggregate, possibly @@ -91,6 +98,10 @@ exposed. Eventually they should be, so that tuning flags can be set on them. +OIDs are generated by a bit of C code, which isn't great, +nor that safe (to get acceptable performance i use +DB_TXN_NOSYNC.) Waiting for Sleepycat 4.3. + The instance cache is implemented as a values-weak hash-table. This is a hash-table where the values can be collected, and when they are, the entire key-value entry is @@ -134,9 +145,6 @@ 1) Split object table by slots or classes? 2) Separate or same btree for collections? -OIDs are currently randomly generated (waiting for Sleepycat -sequences.) - ------------------- SERIALIZER: GENERAL ------------------- @@ -153,8 +161,6 @@ CMUCL this appears to be better than generic functions, though i don't know why. -TODO: reorder the etypecase / cond. - --------------------------- SERIALIZER: PRIMITIVE TYPES --------------------------- @@ -315,5 +321,5 @@ hopefully. Waiting for Berkeley DB 4.3 to get counters (sequences.) -ETA Summer 2004. +ETA October 2004. From blee at common-lisp.net Sun Aug 29 07:45:12 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:45:12 +0200 Subject: [elephant-cvs] CVS update: elephant/TUTORIAL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv29766 Modified Files: TUTORIAL Log Message: typos Date: Sun Aug 29 09:45:10 2004 Author: blee Index: elephant/TUTORIAL diff -u elephant/TUTORIAL:1.1 elephant/TUTORIAL:1.2 --- elephant/TUTORIAL:1.1 Fri Aug 27 19:30:25 2004 +++ elephant/TUTORIAL Sun Aug 29 09:45:09 2004 @@ -38,7 +38,7 @@ symbol conflicts, which are safe to ignore. -------------------- -The Store controller +The Store Controller -------------------- To create a store controller, try @@ -117,7 +117,7 @@ Unfortunately Berekely DB doesn't understand Lisp, so Lisp data needs to be serialized to enter the database, -(e.g. converted to byte arrays), and deserialize on the way +(e.g. converted to byte arrays), and deserialized on the way out. This introduces some caveats: 1) Lisp identity can't be preserved. Since this is a store From blee at common-lisp.net Sun Aug 29 07:45:51 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:45:51 +0200 Subject: [elephant-cvs] CVS update: elephant/elephant.asd Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv30116 Modified Files: elephant.asd Log Message: license, new metaclass / util files Date: Sun Aug 29 09:45:50 2004 Author: blee Index: elephant/elephant.asd diff -u elephant/elephant.asd:1.2 elephant/elephant.asd:1.3 --- elephant/elephant.asd:1.2 Sat Aug 28 08:37:57 2004 +++ elephant/elephant.asd Sun Aug 29 09:45:49 2004 @@ -1,15 +1,40 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; Name: elephant.asd -;;;; Author: Ben Lee -;;;; Created: Aug 2004 -;;;; -;;;; This file, part of Elephant, is Copyright (c) 2004 by Ben Lee -;;;; -;;;; 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. -;;;; ************************************************************************* +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; elephant.asd -- ASDF system definition for elephant +;;; +;;; Initial version 8/26/2004 by Ben Lee +;;; +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; This program is free software; you can redistribute it +;;; and/or modify it under the terms of the GNU General +;;; Public License as published by the Free Software +;;; Foundation; either version 2 of the License, or (at +;;; your option) any later version. +;;; +;;; This program is distributed in the hope that it will be +;;; useful, but WITHOUT ANY WARRANTY; without even the +;;; implied warranty of MERCHANTABILITY or FITNESS FOR A +;;; PARTICULAR PURPOSE. See the GNU General Public License +;;; for more details. +;;; +;;; The GNU General Public License can be found in the file +;;; LICENSE which should have been distributed with this +;;; code. It can also be found at +;;; +;;; http://www.opensource.org/licenses/gpl-license.php +;;; +;;; You should have received a copy of the GNU General +;;; Public License along with this program; if not, write +;;; to the Free Software Foundation, Inc., 59 Temple Place, +;;; Suite 330, Boston, MA 02111-1307 USA +;;; (defsystem elephant :name "elephant" @@ -25,6 +50,8 @@ :components ((:file "sleepycat") (:file "elephant") + (:file "utils") + (:file "metaclasses") (:file "classes") (:file "collections") (:file "controller") From blee at common-lisp.net Sun Aug 29 07:46:36 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:46:36 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30377/src Modified Files: classes.lisp Log Message: andrew's new stuff, work for sbcl Date: Sun Aug 29 09:46:34 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.3 elephant/src/classes.lisp:1.4 --- elephant/src/classes.lisp:1.3 Fri Aug 27 19:31:30 2004 +++ elephant/src/classes.lisp Sun Aug 29 09:46:34 2004 @@ -40,13 +40,6 @@ (in-package "ELEPHANT") -(defclass persistent () - ((%oid :accessor oid - :initarg :from-oid)) - (:documentation - "Abstract superclass for all persistent classes (common -to user-defined classes and collections.)")) - (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid) @@ -54,114 +47,13 @@ "Sets the OID." (if (not from-oid) (setf (oid instance) (next-oid *store-controller*)) - (setf (oid instance) from-oid)) - (cache-instance *store-controller* instance)) + (setf (oid instance) from-oid))) (defclass persistent-object (persistent) - ((%persistent-slots)) + ((%persistent-slots :transient t)) (:documentation "Superclass of all user-defined persistent -classes")) - -(defclass persistent-metaclass (pcl::standard-class) - ()) - -(defclass persistent-slot-definition (pcl::standard-slot-definition) - ()) - -(defclass persistent-direct-slot-definition (pcl::standard-direct-slot-definition persistent-slot-definition) - ()) - -(defclass persistent-effective-slot-definition (pcl::standard-effective-slot-definition persistent-slot-definition) - ()) - -(defmethod pcl::slot-definition-allocation ((slot-definition persistent-slot-definition)) - :instance) - -(defmethod (setf pcl::slot-definition-allocation) (value (slot-definition persistent-slot-definition)) - (declare (ignore value)) - (error "Cannot change the allocation of a persistent slot")) - -(defmethod pcl::initialize-internal-slot-functions ((slot persistent-slot-definition)) - nil) - -(defmethod pcl::direct-slot-definition-class ((class persistent-metaclass) &rest initargs) - (let ((allocation-key (getf initargs :allocation))) - (cond ((eq allocation-key :class) - (call-next-method)) - (t - (find-class 'persistent-direct-slot-definition))))) - -(defmethod pcl:validate-superclass ((class elephant::persistent-metaclass) (super pcl::standard-class)) - t) - -(defmethod persistent-p ((class t)) - nil) - -(defmethod persistent-p ((class persistent-metaclass)) - t) - -(defmethod pcl::effective-slot-definition-class ((class persistent-metaclass) &rest initargs) - (let ((allocation-key (getf initargs :allocation)) - (allocation-class (getf initargs :allocation-class))) - (cond ((eq allocation-key :class) - (call-next-method)) - ((not (persistent-p allocation-class)) - (call-next-method)) - (t - (find-class 'persistent-effective-slot-definition))))) - -(defmacro make-persistent-reader (name) - `(lambda (instance) - (declare (type persistent instance)) - (buffer-write-int (oid instance) *key-buf*) - (let ((key-length (serialize ,name *key-buf*))) - (handler-case - (deserialize (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length)) - (db-error (err) - (if (= (db-error-errno err) DB_NOTFOUND) - (error 'unbound-slot :instance instance :slot ,name) - (error err))))))) - -(defmacro make-persistent-writer (name) - `(lambda (new-value instance) - (declare (type persistent instance)) - (buffer-write-int (oid instance) *key-buf*) - (let ((key-length (serialize ,name *key-buf*)) - (val-length (serialize new-value *out-buf*))) - (db-put-buffered (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) key-length - (buffer-stream-buffer *out-buf*) val-length - :transaction *current-transaction* - :auto-commit *auto-commit*)))) - -#| -(defmethod pcl::compute-slots :around ((class persistent-metaclass)) - (call-next-method)) -|# - -(defmethod handle-optimized-accessors ((slot-def t)) - slot-def) - -(defmethod handle-optimized-accessors ((slot-def persistent-slot-definition)) - (let ((name (pcl::slot-definition-name slot-def))) - (setf (pcl::slot-definition-reader-function slot-def) - (make-persistent-reader name)) - (setf (pcl::slot-definition-writer-function slot-def) - (make-persistent-writer name))) - slot-def) - -(defmethod pcl::compute-effective-slot-definition ((class persistent-metaclass) name direct-slot-definitions) - (let ((object (call-next-method))) - (handle-optimized-accessors object))) - -(defun persistent-slot-names (class) - (let ((slot-definitions (pcl::class-slots class))) - (loop for slot-definition in slot-definitions - when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition)) - collect (pcl::slot-definition-name slot-definition)))) +classes") + (:metaclass persistent-metaclass)) (defmethod initialize-instance :around ((class persistent-metaclass) &rest args &key direct-superclasses) (let* ((persistent-metaclass (find-class 'persistent-metaclass)) @@ -171,12 +63,13 @@ (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) (call-next-method)))) -(defmethod pcl::slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) - (let ((slot-name (pcl::slot-definition-name slot-def))) - (format *standard-output* "Deserializing ~A ~%" slot-name))) - -(defmethod (setf pcl::slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) - (let ((slot-name (pcl::slot-definition-name slot-def))) - (format *standard-output* "Serializing ~A into ~A ~%" new-value slot-name))) - +(defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-reader instance name))) + +(defmethod (setf slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-writer new-value instance name))) From blee at common-lisp.net Sun Aug 29 07:47:01 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:47:01 +0200 Subject: [elephant-cvs] CVS update: elephant/src/metaclasses.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30485/src Added Files: metaclasses.lisp Log Message: andrew's new stuff, work for sbcl Date: Sun Aug 29 09:47:00 2004 Author: blee From blee at common-lisp.net Sun Aug 29 07:47:34 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:47:34 +0200 Subject: [elephant-cvs] CVS update: elephant/src/utils.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30549/src Added Files: utils.lisp Log Message: initial version Date: Sun Aug 29 09:47:33 2004 Author: blee From blee at common-lisp.net Sun Aug 29 07:48:05 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:48:05 +0200 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30576/src Modified Files: collections.lisp Log Message: missing generic warnings Date: Sun Aug 29 09:48:04 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.4 elephant/src/collections.lisp:1.5 --- elephant/src/collections.lisp:1.4 Sat Aug 28 08:39:30 2004 +++ elephant/src/collections.lisp Sun Aug 29 09:48:04 2004 @@ -39,15 +39,16 @@ (in-package "ELEPHANT") ;;; collection types -;;; abstract hash-like collections -;;; equal hashing (except probably for array, hashe, instance keys!) -(defclass persistent-collection (persistent) ()) - -;(defgeneric get-value (key ht &rest args)) -;(defgeneric remove-kv (key ht &rest args)) +;;; we're slot-less +(defclass persistent-collection (persistent) + ()) ;;; btree access (defclass btree (persistent-collection) ()) + +(defgeneric get-value (key ht)) +(defgeneric (setf get-value) (value key ht)) +(defgeneric remove-kv (key ht &key transaction auto-commit)) (defmethod get-value (key (ht btree)) (declare (optimize (speed 3) (safety 0) (space 3))) From blee at common-lisp.net Sun Aug 29 07:48:35 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:48:35 +0200 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30603/src Modified Files: controller.lisp Log Message: missing generic warnings, open/close-store Date: Sun Aug 29 09:48:34 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.4 elephant/src/controller.lisp:1.5 --- elephant/src/controller.lisp:1.4 Sat Aug 28 08:39:56 2004 +++ elephant/src/controller.lisp Sun Aug 29 09:48:34 2004 @@ -53,6 +53,15 @@ creation, counters, locks, the root and garbage collection, et cetera.")) +(defgeneric add-to-root (sc key value)) +(defgeneric get-from-root (sc key)) +(defgeneric remove-from-root (sc key)) +(defgeneric cache-instance (sc obj)) +(defgeneric get-cached-instance (sc oid class-name)) +(defgeneric next-oid (sc)) +(defgeneric open-controller (sc &key recover recover-fatal thread)) +(defgeneric close-controller (sc)) + (defmethod add-to-root ((sc store-controller) key value) "Add an arbitrary persistent thing to the root, so you can retrieve it in a later session. Keys may be arbitrary @@ -154,3 +163,9 @@ , at body) (close-controller ,sc))) +(defun open-store (path) + (setq *store-controller* (make-instance 'store-controller :path path)) + (open-controller *store-controller*)) + +(defun close-store () + (close-controller *store-controller*)) \ No newline at end of file From blee at common-lisp.net Sun Aug 29 07:51:02 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:51:02 +0200 Subject: [elephant-cvs] CVS update: elephant/TUTORIAL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv30637 Modified Files: TUTORIAL Log Message: open/close-store Date: Sun Aug 29 09:51:02 2004 Author: blee Index: elephant/TUTORIAL diff -u elephant/TUTORIAL:1.2 elephant/TUTORIAL:1.3 --- elephant/TUTORIAL:1.2 Sun Aug 29 09:45:09 2004 +++ elephant/TUTORIAL Sun Aug 29 09:51:02 2004 @@ -43,33 +43,37 @@ To create a store controller, try -* (setq *store-controller* (make-instance 'store-controller :path "testdb")) +* (open-controller "testdb") => # The store controller holds the handles to the database -environment and tables, and some other bookkeeping. +environment and tables, and some other bookkeeping. If for +some reason you need to run recovery on the database (see +sleepycat docs) you can specify that with the :recover and +:recover-fatal keys. + +Alternatively, + +* (setq *store-controller* (make-instance 'store-controller :path "testdb")) +=> # * (open-controller *store-controller*) => # -opens the environment and database. If for some reason you -need to run recovery on the database (see sleepycat docs) -you can specify that with the :recover and :recover-fatal -keys. - -"close-controller" closes the handles. Don't forget to do -this or else you may need to run recovery later. There is a -"with-open-controller" macro. In practice, since opening -and closing a controller is very expensive, it's probably -not all that practical. - -*store-controller* is a special which is exported from the -elephant package. The persistent-* objects (see below) use -the *store-controller* special. (This is in part because -slot accessors can't take additional arguments.) If for -some reason you want to operate on 2 store controllers, -you'll have to do that by flipping the *store-controller* -special. +opens the environment and database. *store-controller* is a +special which is exported from the elephant package. The +persistent-* objects (see below) use the *store-controller* +special. (This is in part because slot accessors can't take +additional arguments.) If for some reason you want to +operate on 2 store controllers, you'll have to do that by +flipping the *store-controller* special. + +"close-store" closes the store controller. Alternatively +"close-controller" can be called on a handle. Don't forget +to do this or else you may need to run recovery later. +There is a "with-open-controller" macro. In practice, since +opening and closing a controller is very expensive, it's +probably not all that practical. Store controllers are by default thread-safe (set by the :thread key). Recovery should only be run when there are no From blee at common-lisp.net Sun Aug 29 07:52:34 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:52:34 +0200 Subject: [elephant-cvs] CVS update: elephant/INSTALL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv30665 Modified Files: INSTALL Log Message: open/close-store Date: Sun Aug 29 09:52:34 2004 Author: blee Index: elephant/INSTALL diff -u elephant/INSTALL:1.2 elephant/INSTALL:1.3 --- elephant/INSTALL:1.2 Sun Aug 29 09:43:19 2004 +++ elephant/INSTALL Sun Aug 29 09:52:34 2004 @@ -101,10 +101,7 @@ CL-USER> (use-package "ELE") T -CL-USER> (setq *store-controller* (make-instance 'store-controller :path "/home/ben/testdb")) -# - -CL-USER> (open-controller *store-controller*) +CL-USER> (open-store "/home/ben/testdb") # CL-USER> (setq *auto-commit* T) @@ -121,7 +118,7 @@ NIL NIL -CL-USER> (close-controller *store-controller*) +CL-USER> (close-store) NIL CL-USER> (quit) @@ -145,14 +142,13 @@ CL-USER> (use-package "ELE") T -CL-USER> (setq *store-controller* (make-instance 'store-controller :path "/home/ben/testdb")) -# - -CL-USER> (open-controller *store-controller*) -# +CL-USER> (open-store "/home/ben/testdb") CL-USER> (get-from-root *store-controller* "my key") "my string" T + +CL-USER> (close-store) +NIL CL-USER> From blee at common-lisp.net Sun Aug 29 07:53:28 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:53:28 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32168/src Modified Files: elephant.lisp Log Message: updates, split off utils.lisp, sbcl imports for MOP Date: Sun Aug 29 09:53:27 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.4 elephant/src/elephant.lisp:1.5 --- elephant/src/elephant.lisp:1.4 Sat Aug 28 08:40:18 2004 +++ elephant/src/elephant.lisp Sun Aug 29 09:53:27 2004 @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; elephant.lisp -- package definition and utilities +;;; elephant.lisp -- package definition ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; @@ -41,33 +41,90 @@ (:use common-lisp sleepycat) (:shadow with-transaction) (:export *store-controller* *current-transaction* *auto-commit* + open-store close-store store-controller open-controller close-controller with-open-controller controller-path controller-environment - controller-db controller-root - add-to-root get-from-root + controller-db controller-root add-to-root get-from-root persistent persistent-object persistent-metaclass persistent-collection btree get-value remove-kv db-transaction-begin db-transaction-abort db-transaction-commit with-transaction + db-env-set-lock-detect db-env-get-lock-detect + db-transaction-id db-env-lock-id db-env-lock-id-free + db-env-lock-get db-env-lock-put with-lock db-env-set-timeout db-env-get-timeout db-env-set-flags db-env-get-flags - db-env-set-lock-detect db-env-get-lock-detect + run-elephant-thread ) #+cmu (:import-from :pcl + validate-superclass slot-definition-name + standard-slot-definition + standard-direct-slot-definition + standard-effective-slot-definition + initialize-internal-slot-functions + direct-slot-definition-class + compute-effective-slot-definition-initargs + effective-slot-definition-class + slot-definition-name + slot-definition-reader-function + slot-definition-writer-function + compute-effective-slot-definition + class-slots + slot-value-using-class + slot-definition-allocation compute-slots) - ;; Hopefully SBCL = CMUCL except for package names (both using Gerd's PCL) + #+cmu + (:import-from :ext + make-weak-pointer weak-pointer-value finalize) + #+sbcl (:import-from :sb-mop + validate-superclass slot-definition-name - compute-slots) - #+openmcl - (:import-from :openmcl-mop + standard-slot-definition + standard-direct-slot-definition + standard-effective-slot-definition + direct-slot-definition-class + effective-slot-definition-class slot-definition-name - compute-slots) + compute-effective-slot-definition + class-slots + slot-value-using-class + slot-definition-allocation + compute-slots) + #+sbcl + (:import-from :sb-pcl + initialize-internal-slot-functions + compute-effective-slot-definition-initargs + slot-definition-reader-function + slot-definition-writer-function) + #+sbcl + (:import-from :sb-ext + make-weak-pointer weak-pointer-value finalize) + #+allegro (:import-from :clos + validate-superclass + slot-definition-name + standard-slot-definition + slot-definition-initargs + standard-direct-slot-definition + standard-effective-slot-definition + direct-slot-definition-class + effective-slot-definition-class + slot-definition-name + compute-effective-slot-definition + class-slots + slot-value-using-class + slot-definition-allocation + compute-slots) + #+allegro + (:import-from :excl + compute-effective-slot-definition-initargs) + #+openmcl + (:import-from :openmcl-mop slot-definition-name compute-slots) #+lispworks @@ -77,68 +134,4 @@ ) -(in-package "ELEPHANT") - -;; Thread-local specials which control Elephant - -(defparameter *store-controller* nil - "The store controller which persistent objects talk to.") -(defvar *auto-commit* T) - - -;; 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 (ext: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 (ext:make-weak-pointer value))) - (ext: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) - -;; Good defaults for elephant -(defmacro with-transaction ((&key transaction - (environment (controller-environment - *store-controller*)) - (parent '*current-transaction*) - dirty-read txn-nosync - txn-nowait txn-sync) - &body body) - `(sleepycat:with-transaction (:transaction ,transaction - :environment ,environment - :parent ,parent - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync) - , at body)) +(in-package "ELE") \ No newline at end of file From blee at common-lisp.net Sun Aug 29 07:54:13 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:54:13 +0200 Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32393/src Modified Files: libsleepycat.c Log Message: next_counter: release lock on error, DB_TXN_NOSYNC (speed!) Date: Sun Aug 29 09:54:13 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.4 elephant/src/libsleepycat.c:1.5 --- elephant/src/libsleepycat.c:1.4 Sat Aug 28 08:40:33 2004 +++ elephant/src/libsleepycat.c Sun Aug 29 09:54:13 2004 @@ -85,7 +85,7 @@ /* Sleepycat stuff */ -#include +#include /* Environment */ @@ -417,7 +417,7 @@ DB_LOCK lock; DBT DBTKey, DBTData; DB_TXN *tid; - int counter, tries, ret, t_ret; + int counter, tries, ret, t_ret, lockheld; u_int32_t id; /* Initialization. */ @@ -428,9 +428,12 @@ DBTKey.size = key_length; DBTData.data = lockid; DBTData.size = lockid_length; + tries = 0; loop: + lockheld = 0; + /* Begin the transaction. */ if ((ret = env->txn_begin(env, NULL, &tid, 0)) != 0) { env->err(env, ret, "DB_ENV->txn_begin"); @@ -442,6 +445,8 @@ if ((ret = env->lock_get(env, id, 0, &DBTData, DB_LOCK_WRITE, &lock)) != 0) goto fail; + lockheld = 1; + memset(&DBTData, 0, sizeof(DBTData)); DBTData.data = &counter; DBTData.ulen = sizeof(counter); @@ -462,7 +467,7 @@ if ((ret = env->lock_put(env, &lock)) != 0) goto fail; - if ((ret = tid->commit(tid, 0)) != 0) { + if ((ret = tid->commit(tid, DB_TXN_NOSYNC)) != 0) { env->err(env, ret, "DB_TXN->commit"); return (-2); } @@ -470,12 +475,16 @@ fail: + if (lockheld) + if ((ret = env->lock_put(env, &lock)) != 0) + return (-3); + /* Abort and retry the operation. */ if ((t_ret = tid->abort(tid)) != 0) { env->err(env, t_ret, "DB_TXN->abort"); - return (-3); + return (-4); } if (tries++ == 100) - return (-4); + return (-5); goto loop; } From blee at common-lisp.net Sun Aug 29 07:54:47 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:54:47 +0200 Subject: [elephant-cvs] CVS update: elephant/src/serializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32420/src Modified Files: serializer.lisp Log Message: split off utils.lisp, cleanup Date: Sun Aug 29 09:54:46 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.4 elephant/src/serializer.lisp:1.5 --- elephant/src/serializer.lisp:1.4 Sat Aug 28 08:41:00 2004 +++ elephant/src/serializer.lisp Sun Aug 29 09:54:46 2004 @@ -37,18 +37,10 @@ ;;; (in-package "ELEPHANT") -(eval-when (:compile-toplevel :load-toplevel :execute) - (use-package "UFFI")) (declaim (inline int-byte-spec - ;resize-buffer-stream - finish-buffer - buffer-write-byte buffer-write-int buffer-write-uint - buffer-write-float buffer-write-double buffer-write-string - buffer-read-byte buffer-read-fixnum buffer-read-int - buffer-read-uint buffer-read-float buffer-read-double - buffer-read-string ;serialize deserialize + slots-and-values deserialize-bignum)) (def-type foreign-char :char) @@ -75,26 +67,6 @@ (defconstant +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80) -; a stream-like interface for our buffers. ultimately we -; might want a gray / simple -stream for real, for now who -; cares? - -(defstruct buffer-stream - (buffer (allocate-foreign-object :char 1) :type array-or-pointer-char) - (length 0 :type fixnum) - (position 0 :type fixnum)) - -;; Some thread-local storage - -(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*) - (type fixnum *lisp-obj-id*) - (type hash-table *circularity-hash*)) - -(defvar *out-buf* (make-buffer-stream)) -(defvar *key-buf* (make-buffer-stream)) -(defvar *in-buf* (make-buffer-stream)) -(defvar *lisp-obj-id* 0) -(defvar *circularity-hash* (make-hash-table :test 'eq)) (defun serialize (frob bs) (declare (optimize (speed 3) (safety 0))) @@ -227,6 +199,7 @@ (finish-buffer bs))) (defun slots-and-values (o) + (declare (optimize (speed 3) (safety 0))) (loop for sd in (compute-slots (class-of o)) for slot-name = (slot-definition-name sd) with ret = () @@ -345,205 +318,6 @@ finally (return (if positive num (- num))))) - -;; Stream-like buffer interface - -(eval-when (:compile-toplevel :load-toplevel) - (defun process-struct-slot-defs (slot-defs struct) - (loop for def in slot-defs - collect (list (first def) (list (second def) struct))))) - -(defmacro with-struct-slots (slot-defs struct &body body) - `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct) - , at body)) - -(declaim (type array-or-pointer-char *buffer* *key-buffer*) - (type fixnum *buffer-length* *buffer-position* - *key-buffer-length* *key-buffer-position*)) - -(defun resize-buffer-stream (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (when (> length len) - (let ((newlen (max length (* len 2)))) - (declare (type fixnum newlen)) - (let ((newbuf (allocate-foreign-object :char newlen))) - (copy-bufs newbuf 0 buf 0 len) - (free-foreign-object buf) - (setf buf newbuf) - (setf len newlen) - nil))))) - -(defun finish-buffer (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position)) - bs - (let ((length pos)) - (setf pos 0) - length))) - -(defun buffer-write-byte (b bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 8) b)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 1))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (setf (deref-array buf '(:array :char) pos) b) - (setf pos needed)))) - -(defun buffer-write-int (i bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (signed-byte 32) i)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-int buf i pos) - (setf pos needed) - nil))) - -(defun buffer-write-uint (u bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 32) u)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-uint buf u pos) - (setf pos needed) - nil))) - -(defun buffer-write-float (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type single-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-float buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-double (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type double-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 8))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-double buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-string (s bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type string s)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let* ((str-bytes (byte-length s)) - (needed (+ pos str-bytes))) - (declare (type fixnum str-bytes needed) - (dynamic-extent str-bytes needed)) - (when (> needed len) - (resize-buffer-stream bs needed)) - (copy-str-to-buf buf pos s 0 str-bytes) - (setf pos needed) - nil))) - -(defun buffer-read-byte (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (incf (buffer-stream-position bs)) - (deref-array (buffer-stream-buffer bs) '(:array :char) pos))) - -(defun buffer-read-fixnum (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the fixnum (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-int (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (signed-byte 32) (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-uint (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-float (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (read-float (buffer-stream-buffer bs) pos))) - -(defun buffer-read-double (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 8)) - (read-double (buffer-stream-buffer bs) pos))) - -(defun buffer-read-string (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos length)) - ;; wide!!! - #+(and allegro ics) - (excl:native-to-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length - :external-format :unicode) - #+lispworks - (fli:convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length :external-format :unicode :null-terminated-p nil) - #-(or lispworks (and allegro ics)) - (convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length :null-terminated-p nil))) - ;; array type tags (declaim (type hash-table array-type-to-byte byte-to-array-type)) @@ -578,11 +352,6 @@ (defun byte-from-array-type (ty) (the (unsigned-byte 8) (gethash ty array-type-to-byte))) - -;(defconstant +cl-store+ (char-code #\o)) - -#+(or cmu scl sbcl allegro) -(defvar *resourced-byte-spec* (byte 32 0)) (defun int-byte-spec (position) (declare (optimize (speed 3) (safety 0)) From blee at common-lisp.net Sun Aug 29 07:55:30 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 09:55:30 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32447/src Modified Files: sleepycat.lisp Log Message: linux / sbcl, reorg Date: Sun Aug 29 09:55:29 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.4 elephant/src/sleepycat.lisp:1.5 --- elephant/src/sleepycat.lisp:1.4 Sat Aug 28 08:41:49 2004 +++ elephant/src/sleepycat.lisp Sun Aug 29 09:55:29 2004 @@ -67,6 +67,49 @@ (in-package "SLEEPYCAT") +(eval-when (:compile-toplevel :load-toplevel) + ;; UFFI + ;;(asdf:operate 'asdf:load-op :uffi) + + ;; DSO loading + + ;; Under linux you need to load some kind of pthread + ;; library. I can't figure out which is the right one. + ;; This one worked for me. There are known issues with + ;; Red Hat and Berkeley DB, search google. + #+linux + (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") + + (uffi:load-foreign-library "/usr/local/lib/db42/libdb.so" + :module "sleepycat") + (uffi:load-foreign-library + "/home/ben/lisp/elephant/libsleepycat.so" +;; "/usr/local/share/common-lisp/elephant/libsleepycat.so" + :module "libsleepycat") + + (def-type pointer-int (* :int)) + (def-type pointer-void :pointer-void) + (def-foreign-type array-or-pointer-char + #+allegro (:array :char) + #+(or cmu sbcl scl) (* :char)) + (def-type array-or-pointer-char array-or-pointer-char) + (def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN)) +) + +(declaim (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-bufs + %db-get-key-buffered db-get-key-buffered + %db-get-buffered db-get-buffered db-get + %db-put-buffered db-put-buffered + %db-put db-put + %db-delete db-delete-buffered db-delete + %db-txn-begin db-transaction-begin + %db-txn-abort db-transaction-abort + %db-txn-commit db-transaction-commit + %db-transaction-id + flags)) + ;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -112,41 +155,9 @@ (defconstant DB_LOCK_NOTGRANTED -30994) (defconstant DB_NOTFOUND -30990) +(defconstant +NULL-VOID+ (make-null-pointer :void)) +(defconstant +NULL-CHAR+ (make-null-pointer :char)) -(eval-when (:compile-toplevel :load-toplevel) - ;; UFFI - ;;(asdf:operate 'asdf:load-op :uffi) - - ;; DSO loading - (defconstant +path-to-libsleepycat+ - "/home/ben/lisp/elephant/libsleepycat.so") - (defconstant +path-to-sleepycat+ - "/usr/local/lib/db42/libdb.so") - (uffi:load-foreign-library +path-to-sleepycat+ :module "sleepycat") - (uffi:load-foreign-library +path-to-libsleepycat+ :module "libsleepycat") - - (def-type pointer-int (* :int)) - (def-type pointer-void :pointer-void) - (def-foreign-type array-or-pointer-char - #+allegro (:array :char) - #+(or cmu sbcl scl) (* :char)) - (def-type array-or-pointer-char array-or-pointer-char) - (def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN)) -) - -(declaim (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-bufs - %db-get-key-buffered db-get-key-buffered - %db-get-buffered db-get-buffered db-get - %db-put-buffered db-put-buffered - %db-put db-put - %db-delete db-delete-buffered db-delete - %db-txn-begin db-transaction-begin - %db-txn-abort db-transaction-abort - %db-txn-commit db-transaction-commit - %db-transaction-id - flags)) ;; Buffer management / pointer arithmetic @@ -280,16 +291,13 @@ ;; Thread local storage (special variables) -(defconstant +NULL-VOID+ (make-null-pointer :void)) -(defconstant +NULL-CHAR+ (make-null-pointer :char)) +(declaim (type array-or-pointer-char *get-buffer*) + (type fixnum *get-buffer-length*)) (defvar *current-transaction* +NULL-VOID+) (defvar *errno-buffer* (allocate-foreign-object :int 1)) -(declaim (type array-or-pointer-char *get-buffer*) - (type fixnum *get-buffer-length*)) - (defvar *get-buffer* (allocate-foreign-object :char 1)) (defvar *get-buffer-length* 0) @@ -1035,7 +1043,7 @@ (let ((ret (%next-counter env db key key-length lockid lockid-length))) (if (< ret 0) (error 'db-error :errno ret) - ret)))) + ret))) ;; Misc From blee at common-lisp.net Sun Aug 29 20:31:27 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:31:27 +0200 Subject: [elephant-cvs] CVS update: elephant/INSTALL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv7408 Modified Files: INSTALL Log Message: updates Date: Sun Aug 29 22:31:27 2004 Author: blee Index: elephant/INSTALL diff -u elephant/INSTALL:1.3 elephant/INSTALL:1.4 --- elephant/INSTALL:1.3 Sun Aug 29 09:52:34 2004 +++ elephant/INSTALL Sun Aug 29 22:31:26 2004 @@ -3,9 +3,9 @@ Requirements ------------ -CMUCL 19a, Allegro CL 6.2 or OpenMCL 0.14.2. Recent -versions of SBCL and Lispworks should be supported / easy to -make work. +CMUCL 19a, SBCL 0.8.13, or Allegro CL 6.2. I've tested +under FreeBSD and Linux. OpenMCL and Lispworks versions +will come soon. ASDF - http://www.cliki.net/asdf @@ -14,7 +14,7 @@ I've patched src/functions.lisp to support some kinds of :out arguments. it is backwards-compatible so shouldn't interfere with your existing work. I've contacted Kevin -Rosenberg about this. +Rosenberg about this, it will appear in a future release. Sleepycat Berkeley DB 4.2 - http://www.sleepycat.com @@ -25,7 +25,13 @@ Instructions ------------ -1) Install your lisp, asdf, and UFFI. Replace +I assume you have a supported lisp with asdf. + +0) Unpack Elephant. I put mine in the directory + +/usr/local/share/common-lisp/elephant/ + +1) Install UFFI 1.4.24. Replace path-to-uffi/src/functions.lisp @@ -34,25 +40,25 @@ 2) Install Berkeley DB 4.2. FreeBSD has a port for this, as I'm sure other BSDs (including Darwin.) Take note of where libdb.so and db.h are installed (usually +/usr/local/BerekleyDB.4.2/lib/libdb.so and +/usr/local/BerekleyDB.4.2/include/db.h, or /usr/local/lib/db42/libdb.so and /usr/local/include/db42/db.h.) -3) Compile src/libsleepycat.c. I'm no gcc master but under -FreeBSD this worked for me: +3) Edit Makefile and run (using GNU make, gmake on BSD) -gcc -L/usr/local/lib/db42 -I/usr/local/include/db42 -fPIC -shared -O3 -o libsleepycat.so src/libsleepycat.c -ldb +make install -you may or may not need a trailing -ldb at the end. Put -libsleepycat.so somewhere you can get at it, like in your -common-lisp elephant system dir +This compiles src/libsleepycat.c and installs it into /usr/local/share/common-lisp/elephant/ -4) Compile and load Elephant. +or where you specified. -First, edit src/sleepycat.lisp so that +path-to-sleepycat+ -and +path-to-libsleepycat+ are correct. (If I were better -at ASDF there'd be a better way of doing this....) +4) Compile and load Elephant: + +First, edit src/sleepycat.lisp so that it points to the +correct libraries. Symlink elephant.asd to your asdf systems directory (mine is /usr/local/share/common-lisp/systems). Fire up lisp and @@ -61,22 +67,20 @@ (asdf:operate 'asdf:load-op :elephant) This will load and compile Elephant. This will also -automatically load UFFI. You will get some errors about -redefining constants probably. Go ahead and redefine them, -they are safe to bash, and won't happen again once you've -compiled. - -At this point I advise quitting lisp before using Elephant. -I get symbol conflicts otherwise. (Help?) I also (under -CMUCL) get strange behavior which indicates you might get -better performance if you compile everything again with -everything loaded. +automatically load UFFI. You may get "constant redefinition +errors", especially on SBCL. They are not issues, go ahead +and redefine the constants. + +Under CMUCL I sporadically get strange behavior which +indicates you might get better performance if you compile +everything again with everything loaded. ----------- Quick Start ----------- -A REPL session is worth a thousand words, so ... +For more complete documentation see TUTORIAL and NOTES. But +a REPL session is worth a thousand words, so ... -bash-2.05b$ pwd /home/ben @@ -104,17 +108,14 @@ CL-USER> (open-store "/home/ben/testdb") # -CL-USER> (setq *auto-commit* T) -T - -CL-USER> (add-to-root *store-controller* "my key" "my string") +CL-USER> (add-to-root "my key" "my string") NIL -CL-USER> (get-from-root *store-controller* "my key") +CL-USER> (get-from-root "my key") "my string" T -CL-USER> (get-from-root *store-controller* "my key2") +CL-USER> (get-from-root "my key2") NIL NIL @@ -144,7 +145,7 @@ CL-USER> (open-store "/home/ben/testdb") -CL-USER> (get-from-root *store-controller* "my key") +CL-USER> (get-from-root "my key") "my string" T From blee at common-lisp.net Sun Aug 29 20:32:18 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:32:18 +0200 Subject: [elephant-cvs] CVS update: elephant/LICENSE Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv7590 Modified Files: LICENSE Log Message: new license Date: Sun Aug 29 22:32:18 2004 Author: blee Index: elephant/LICENSE diff -u elephant/LICENSE:1.1 elephant/LICENSE:1.2 --- elephant/LICENSE:1.1 Fri Aug 27 19:30:48 2004 +++ elephant/LICENSE Sun Aug 29 22:32:18 2004 @@ -1,3 +1,13 @@ +Elephant: an object-oriented database for Common Lisp + +Copyright (c) 2004 by Andrew Blumberg and Ben Lee + + +This program is released under the following license +("GPL"). For differenct licensing terms, contact the +copyright holders. + + The GNU General Public License (GPL) Version 2, June 1991 From blee at common-lisp.net Sun Aug 29 20:34:10 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:34:10 +0200 Subject: [elephant-cvs] CVS update: elephant/Makefile Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv7618 Added Files: Makefile Log Message: first version, thank you Rafal Strzalinski Date: Sun Aug 29 22:34:10 2004 Author: blee From blee at common-lisp.net Sun Aug 29 20:35:38 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:35:38 +0200 Subject: [elephant-cvs] CVS update: elephant/TUTORIAL Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv7649 Modified Files: TUTORIAL Log Message: updates, persistent classes, collections, threading, performance Date: Sun Aug 29 22:35:37 2004 Author: blee Index: elephant/TUTORIAL diff -u elephant/TUTORIAL:1.3 elephant/TUTORIAL:1.4 --- elephant/TUTORIAL:1.3 Sun Aug 29 09:51:02 2004 +++ elephant/TUTORIAL Sun Aug 29 22:35:37 2004 @@ -90,12 +90,12 @@ You can put something into the root object by -* (add-to-root *store-controller* "my key" "my value") +* (add-to-root "my key" "my value") => NIL and get things out via -* (get-from-root *store-controller* "my key") +* (get-from-root "my key") => "my value" => T @@ -115,14 +115,14 @@ things: numbers (except for complexes, which will be easy to support), symbols, strings, nil, characters, pathnames, conses, hash-tables, arrays, CLOS objects. Nested and -circular structures are allowed. Basically everything -except lambdas, closures, structures, packages and streams. -(These may eventually get supported too.) +circular things are allowed. You can serialize basically +anything except lambdas, closures, structures, packages and +streams. (These may eventually get supported too.) Unfortunately Berekely DB doesn't understand Lisp, so Lisp data needs to be serialized to enter the database, (e.g. converted to byte arrays), and deserialized on the way -out. This introduces some caveats: +out. This introduces some caveats (not unique to Elephant): 1) Lisp identity can't be preserved. Since this is a store which persists across invocations of Lisp, this probably @@ -130,12 +130,12 @@ * (setq foo (cons nil nil)) => (NIL) -* (add-to-root *store-controller* "my key" foo) +* (add-to-root "my key" foo) => NIL -* (add-to-root *store-controller* "my other key" foo) +* (add-to-root "my other key" foo) => NIL -* (eq (get-from-root *store-controller* "my key") - (get-from-root *store-controller* "my other key")) +* (eq (get-from-root "my key") + (get-from-root "my other key")) => NIL As a consequence, btrees have a sort of mishmash eql / @@ -145,7 +145,7 @@ * (setf (car foo) T) => T -* (get-from-root *store-controller* "my key") +* (get-from-root "my key") => (NIL) You can of course manually re-input objects. @@ -175,12 +175,12 @@ * (setq foo (make-instance 'my-persistent-class)) => # -* (add-to-root *store-controller* "foo" foo) +* (add-to-root "foo" foo) => NIL -* (add-to-root *store-controller* "bar" foo) +* (add-to-root "bar" foo) => NIL -* (eq (get-from-root *store-controller* "foo") - (get-from-root *store-controller* "bar")) +* (eq (get-from-root "foo") + (get-from-root "bar")) => T What's going on here? Persistent classes, that is, classes @@ -190,7 +190,7 @@ are stored in separate entries, keyed by OID and slot. Loading (deserializing) a persistent class -* (get-from-root *store-controller* "foo") +* (get-from-root "foo") => # instantiates the object or finds it from the cache, if it @@ -211,7 +211,7 @@ * (setf (slot1 foo) "three") => "three" -* (slot1 (get-from-root *store-controller* "bar")) +* (slot1 (get-from-root "bar")) => "three" Although it is hard to see here, serialization / @@ -219,6 +219,37 @@ than ordinary CLOS objects. Finally, they do not suffer from merge-conflicts (more on this later.) +------------------------------ +Rules about Persistent Classes +------------------------------ + +Using the persistent-metaclass metaclass declares all slots +to be persistent by default. To make a non-persistent slot +use the :transient t flag. Class slots are never persisted, +for either persistent or ordinary classes. (Is this the +right behavior?) + +Readers, writers, accessors, and slot-value-using-class are +instrumented. Because slot-value is not a generic function, +it is not guaranteed to work properly with persistent slots +-- don't use it! + +Persistent classes may inherit from other classes. slots +inherited from persistent classes remain persistent. +transient slots and slots inherited from ordinary classes +remain transient. + +Ordinary classes cannot inherit from persistent classes -- +slots need to get stored! Likewise, once a slot is declared +persistent, it cannot later be changed to a transient slot. + +Note that the database is read every time you access a slot. +In particular, if your slot value is not an immediate value, +this will cons the value. Gets are not an expensive +operation (I can do a million reads in 30 seconds), but if +you're concerned, cache values. (In the future we will +provide automatic value caching.) + ------------ Transactions ------------ @@ -258,12 +289,102 @@ If for some reason (like db error) you decide to abort, you can do so via (db-transaction-abort). -All of this is packaged up in two macros: with-transaction -and with-transaction-retry. The first starts a new -transaction, executes the body, then tries to commit the +All of this is packaged up in with-transaction. It starts a +new transaction, executes the body, then tries to commit the transaction. If anywhere along the way there is a database -error, the transaction is aborted. +error, the transaction is aborted, and it attempts to retry +(a fixed number of times) by re-executing the whole body. + +----------- +Collections +----------- + +The btrees class are to hash-tables as persistent-objects +are to ordinary objects. btrees have a hash-table-like +interface, but store their keys and values directy in a +Sleepycat btree. Btrees may be persisted simply by their +OID. Hence they have all the nice properties of persistent +objects: identity, fast serialization / deserialization, no +merge conflicts..... + +* (defvar friends-birthdays (make-instance 'btree)) +=> FRIENDS-BIRTHDAYS + +* (add-to-root "friends-birthdays" friends-birthdays) +=> # + +* (setf (get-value "Andrew" friends-birthdays) "12/22/1976") +=> "12/22/1976" + +* (get-value "Andrew" friends-birthdays) +=> "12/22/1976" +=> T -with-transaction-retry does the same thing, except on a -failure, after aborting it attempts to automatically retry a -few times: it re-runs the body, and again tries to commit. +Because of serialization semantics, btrees hash on a value, +not identity. This is probably ok for strings, numbers, and +persistent things, but not for ordinary aggregates. + +In the future there will be support for automatically +generating secondary indicies to search or index into btrees +with. + +--------- +Threading +--------- + +Sleepycat plays well with threads and processes. The store +controller is thread-safe by default, that is, can be shared +amongst threads. Transactions may not be shared amongst +threads except serially. One thing which is NOT thread and +process safe is recovery, which should be run when no one is +else is talking to the database environment. Consult the +Sleepycat docs for more information. + +Elephant uses some specials to hold parameters and buffers. +If you're using a natively threaded lisp, you can initialize +these specials to thread-local storage by using the +"run-elephant-thread" function, assuming your lisp creates +thread-local storage for let-bound specials. + +Persisting ordinary aggregate types suffers from something +called "merge-conflicts." Since updating one value of an +aggregate object requires the entire object to be written to +the database, in heavily threaded situations you may +overwrite changes another thread or process has committed. +This is not protected by transactions. + +Consider two processes operating on the same cons: + +-----start--read--update-car--write--commit----------------- +-start------read--update-cdr-----------------write--commit-- + +Although the first process successfully committed their +transaction, their work (writing to the car) will be erased +by the second process's transaction (which writes both the +car and cdr.) + +Persistent classes and persistent collections do not suffer +from merge-conflicts, since each slot / entry is a separate +database entry. + +----------- +Performance +----------- + +Performance is usually measured in transactions per second. +Database reads are cheap. To get more transactions +throughput, consider setting + +* (db-env-set-flags (controller-environment *store-controller*) 1 + :txn-nosync t) + +or look at other flags in the sleepycat docs. This will +greatly increase your throughput at the cost of some +durability; I get around a 100x improvement. This can be +recovered with judicious use of checkpointing and +replication, though this is currently not supported by +Elephant -- see the sleepycat docs. + +The serializer is definitely fast on fixnums, strings, and +persistent things. It is fairly fast but consing with +floats and doubles. YMMV with other values. From blee at common-lisp.net Sun Aug 29 20:35:53 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:35:53 +0200 Subject: [elephant-cvs] CVS update: elephant/elephant.asd Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv7674 Modified Files: elephant.asd Log Message: new license Date: Sun Aug 29 22:35:52 2004 Author: blee Index: elephant/elephant.asd diff -u elephant/elephant.asd:1.3 elephant/elephant.asd:1.4 --- elephant/elephant.asd:1.3 Sun Aug 29 09:45:49 2004 +++ elephant/elephant.asd Sun Aug 29 22:35:52 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software From blee at common-lisp.net Sun Aug 29 20:36:18 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:36:18 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7699/src Modified Files: classes.lisp Log Message: new license Date: Sun Aug 29 22:36:18 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.4 elephant/src/classes.lisp:1.5 --- elephant/src/classes.lisp:1.4 Sun Aug 29 09:46:34 2004 +++ elephant/src/classes.lisp Sun Aug 29 22:36:18 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software From blee at common-lisp.net Sun Aug 29 20:36:49 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:36:49 +0200 Subject: [elephant-cvs] CVS update: elephant/src/collections.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7729/src Modified Files: collections.lisp Log Message: new license, should return values on setf Date: Sun Aug 29 22:36:49 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.5 elephant/src/collections.lisp:1.6 --- elephant/src/collections.lisp:1.5 Sun Aug 29 09:48:04 2004 +++ elephant/src/collections.lisp Sun Aug 29 22:36:48 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software @@ -53,12 +57,14 @@ (defmethod get-value (key (ht btree)) (declare (optimize (speed 3) (safety 0) (space 3))) (buffer-write-int (oid ht) *key-buf*) - (let ((key-length (serialize key *key-buf*))) + (let* ((key-length (serialize key *key-buf*)) + (buf (db-get-key-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length))) (declare (type fixnum key-length)) - (deserialize (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length)))) + (if buf (values (deserialize buf) T) + (values nil nil)))) (defmethod (setf get-value) (value key (ht btree)) (declare (optimize (speed 3) (safety 0))) @@ -69,7 +75,8 @@ (buffer-stream-buffer *key-buf*) key-length (buffer-stream-buffer *out-buf*) val-length :transaction *current-transaction* - :auto-commit *auto-commit*))) + :auto-commit *auto-commit*) + value)) (defmethod remove-kv (key (ht btree) &key (transaction *current-transaction*) From blee at common-lisp.net Sun Aug 29 20:37:59 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:37:59 +0200 Subject: [elephant-cvs] CVS update: elephant/src/controller.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7763/src Modified Files: controller.lisp Log Message: new license, better defaults for root methods Date: Sun Aug 29 22:37:58 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.5 elephant/src/controller.lisp:1.6 --- elephant/src/controller.lisp:1.5 Sun Aug 29 09:48:34 2004 +++ elephant/src/controller.lisp Sun Aug 29 22:37:58 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software @@ -53,30 +57,27 @@ creation, counters, locks, the root and garbage collection, et cetera.")) -(defgeneric add-to-root (sc key value)) -(defgeneric get-from-root (sc key)) -(defgeneric remove-from-root (sc key)) (defgeneric cache-instance (sc obj)) (defgeneric get-cached-instance (sc oid class-name)) (defgeneric next-oid (sc)) (defgeneric open-controller (sc &key recover recover-fatal thread)) (defgeneric close-controller (sc)) -(defmethod add-to-root ((sc store-controller) key value) +(defun add-to-root (key value &key (store-controller *store-controller*)) "Add an arbitrary persistent thing to the root, so you can retrieve it in a later session. Keys may be arbitrary persistables as well (though note collection key semantics!) N.B. this means it (and everything it points to) won't get gc'd." - (setf (get-value key (controller-root sc)) value)) + (setf (get-value key (controller-root store-controller)) value)) -(defmethod get-from-root ((sc store-controller) key) +(defmethod get-from-root (key &key (store-controller *store-controller*)) "Get a persistent thing from the root." - (get-value key (controller-root sc))) + (get-value key (controller-root store-controller))) -(defmethod remove-from-root ((sc store-controller) key) +(defmethod remove-from-root (key &key (store-controller *store-controller*)) "Get a persistent thing from the root." - (remove-kv key (controller-root sc))) + (remove-kv key (controller-root store-controller))) (defmethod cache-instance ((sc store-controller) obj) "Register an instance of a user persistent-class with the From blee at common-lisp.net Sun Aug 29 20:38:44 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:38:44 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7815/src Modified Files: elephant.lisp Log Message: new license, non-interned exports Date: Sun Aug 29 22:38:43 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.5 elephant/src/elephant.lisp:1.6 --- elephant/src/elephant.lisp:1.5 Sun Aug 29 09:53:27 2004 +++ elephant/src/elephant.lisp Sun Aug 29 22:38:43 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software @@ -39,22 +43,22 @@ (defpackage elephant (:nicknames ele :ele) (:use common-lisp sleepycat) - (:shadow with-transaction) - (:export *store-controller* *current-transaction* *auto-commit* - open-store close-store - store-controller open-controller close-controller - with-open-controller controller-path controller-environment - controller-db controller-root add-to-root get-from-root - persistent persistent-object persistent-metaclass - persistent-collection btree get-value remove-kv - db-transaction-begin db-transaction-abort db-transaction-commit - with-transaction - db-env-set-lock-detect db-env-get-lock-detect - db-transaction-id db-env-lock-id db-env-lock-id-free - db-env-lock-get db-env-lock-put with-lock - db-env-set-timeout db-env-get-timeout - db-env-set-flags db-env-get-flags - run-elephant-thread + (:shadow #:with-transaction) + (:export #:*store-controller* #:*current-transaction* #:*auto-commit* + #:open-store #:close-store + #:store-controller #:open-controller #:close-controller + #:with-open-controller #:controller-path #:controller-environment + #:controller-db #:controller-root #:add-to-root #:get-from-root + #:persistent #:persistent-object #:persistent-metaclass + #:persistent-collection #:btree #:get-value #:remove-kv + #:db-transaction-begin #:db-transaction-abort + #:db-transaction-commit #:with-transaction + #:db-env-set-lock-detect #:db-env-get-lock-detect + #:db-transaction-id #:db-env-lock-id #:db-env-lock-id-free + #:db-env-lock-get #:db-env-lock-put #:with-lock + #:db-env-set-timeout #:db-env-get-timeout + #:db-env-set-flags #:db-env-get-flags + #:run-elephant-thread ) #+cmu (:import-from :pcl From blee at common-lisp.net Sun Aug 29 20:39:30 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:39:30 +0200 Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7840/src Modified Files: libsleepycat.c Log Message: new license Date: Sun Aug 29 22:39:30 2004 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.5 elephant/src/libsleepycat.c:1.6 --- elephant/src/libsleepycat.c:1.5 Sun Aug 29 09:54:13 2004 +++ elephant/src/libsleepycat.c Sun Aug 29 22:39:29 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software From blee at common-lisp.net Sun Aug 29 20:40:06 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:40:06 +0200 Subject: [elephant-cvs] CVS update: elephant/src/metaclasses.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7868/src Modified Files: metaclasses.lisp Log Message: new license, declare optimize Date: Sun Aug 29 22:40:06 2004 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.1 elephant/src/metaclasses.lisp:1.2 --- elephant/src/metaclasses.lisp:1.1 Sun Aug 29 09:47:00 2004 +++ elephant/src/metaclasses.lisp Sun Aug 29 22:40:06 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software @@ -137,7 +141,8 @@ (defun make-persistent-reader (name) (lambda (instance) - (declare (type persistent instance)) + (declare (optimize (speed 3)) + (type persistent instance)) (persistent-slot-reader instance name))) (defmacro persistent-slot-writer (new-value instance name) @@ -154,7 +159,8 @@ (defun make-persistent-writer (name) (lambda (new-value instance) - (declare (type persistent instance)) + (declare (optimize (speed 3)) + (type persistent instance)) (persistent-slot-writer new-value instance name))) (defgeneric handle-optimized-accessors (slot-def)) From blee at common-lisp.net Sun Aug 29 20:40:49 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:40:49 +0200 Subject: [elephant-cvs] CVS update: elephant/src/serializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv7895/src Modified Files: serializer.lisp Log Message: new license, bignum bugfix, don't save class slots Date: Sun Aug 29 22:40:49 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.5 elephant/src/serializer.lisp:1.6 --- elephant/src/serializer.lisp:1.5 Sun Aug 29 09:54:46 2004 +++ elephant/src/serializer.lisp Sun Aug 29 22:40:49 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software @@ -121,10 +125,9 @@ (buffer-write-byte +negative-bignum+ bs) (buffer-write-byte +positive-bignum+ bs)) (buffer-write-int needed bs) - (loop for i fixnum from 0 below word-size - ;; shouldn't this be "below"? + (loop for i fixnum from 0 to word-size for byte-spec = (int-byte-spec i) - ;; this ldb is consing! + ;; this ldb is consing on CMUCL! ;; there is an OpenMCL function which should work ;; and non-cons for the-uint of-type (unsigned-byte 32) = (ldb byte-spec num) @@ -204,7 +207,9 @@ for slot-name = (slot-definition-name sd) with ret = () do - (when (slot-boundp o slot-name) + (when (and (slot-boundp o slot-name) + (eq :instance + (slot-definition-allocation sd))) (push (slot-value o slot-name) ret) (push slot-name ret)) finally (return ret))) From blee at common-lisp.net Sun Aug 29 20:41:32 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:41:32 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv9047/src Modified Files: sleepycat.lisp Log Message: new license, non-interned exports (thanks Rafal Strzalinski) Date: Sun Aug 29 22:41:31 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.5 elephant/src/sleepycat.lisp:1.6 --- elephant/src/sleepycat.lisp:1.5 Sun Aug 29 09:55:29 2004 +++ elephant/src/sleepycat.lisp Sun Aug 29 22:41:30 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software @@ -39,30 +43,33 @@ (defpackage sleepycat (:use common-lisp uffi) - (:export read-int read-uint read-float read-double - write-int write-uint write-float write-double - offset-char-pointer copy-str-to-buf copy-bufs byte-length - pointer-int pointer-void array-or-pointer-char - db-env-create db-env-close db-env-open db-env-dbremove - db-env-dbrename db-env-remove - db-env-set-flags db-env-get-flags - db-create db-close db-open - db-remove db-rename db-sync db-truncate - db-get-key-buffered db-get-buffered db-get db-put-buffered db-put - db-delete-buffered db-delete - *current-transaction* db-transaction-begin db-transaction-abort - db-transaction-commit with-transaction - db-transaction-id db-env-lock-id db-env-lock-id-free - db-env-lock-get db-env-lock-put with-lock - db-env-set-timeout db-env-get-timeout - db-env-set-lock-detect db-env-get-lock-detect - db-error db-error-errno - +NULL-VOID+ +NULL-CHAR+ - DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN - DB_KEYEMPTY DB_LOCK_DEADLOCK DB_LOCK_NOTGRANTED DB_NOTFOUND - DB-LOCKMODE#NG DB-LOCKMODE#READ DB-LOCKMODE#WRITE - DB-LOCKMODE#wAIT DB-LOCKMODE#IWRITE DB-LOCKMODE#IREAD - DB-LOCKMODE#IWR DB-LOCKMODE#DIRTY DB-LOCKMODE#WWRITE + (:export #:*current-transaction* + #:read-int #:read-uint #:read-float #:read-double + #:write-int #:write-uint #:write-float #:write-double + #:offset-char-pointer #:copy-str-to-buf #:copy-bufs #:byte-length + #:pointer-int #:pointer-void #:array-or-pointer-char + #:db-env-create #:db-env-close #:db-env-open #:db-env-dbremove + #:db-env-dbrename #:db-env-remove + #:db-env-set-flags #:db-env-get-flags + #:db-create #:db-close #:db-open + #:db-remove #:db-rename #:db-sync #:db-truncate + #:db-get-key-buffered #:db-get-buffered #:db-get + #:db-put-buffered #:db-put + #:db-delete-buffered #:db-delete + #:db-transaction-begin #:db-transaction-abort + #:db-transaction-commit #:with-transaction + #:db-transaction-id #:db-env-lock-id #:db-env-lock-id-free + #:db-env-lock-get #:db-env-lock-put #:with-lock + #:db-env-set-timeout #:db-env-get-timeout + #:db-env-set-lock-detect #:db-env-get-lock-detect + #:db-error #:db-error-errno + #:+NULL-VOID+ #:+NULL-CHAR+ + #:DB-BTREE #:DB-HASH #:DB-QUEUE #:DB-RECNO #:DB-UNKNOWN + #:DB_KEYEMPTY #:DB_LOCK_DEADLOCK #:DB_LOCK_NOTGRANTED + #:DB_NOTFOUND + #:DB-LOCKMODE#NG #:DB-LOCKMODE#READ #:DB-LOCKMODE#WRITE + #:DB-LOCKMODE#wAIT #:DB-LOCKMODE#IWRITE #:DB-LOCKMODE#IREAD + #:DB-LOCKMODE#IWR #:DB-LOCKMODE#DIRTY #:DB-LOCKMODE#WWRITE )) (in-package "SLEEPYCAT") @@ -71,21 +78,30 @@ ;; UFFI ;;(asdf:operate 'asdf:load-op :uffi) - ;; DSO loading + ;; DSO loading - Edit these for your system! - ;; Under linux you need to load some kind of pthread + ;; Under linux you may need to load some kind of pthread ;; library. I can't figure out which is the right one. ;; This one worked for me. There are known issues with ;; Red Hat and Berkeley DB, search google. #+linux (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") + ;; Sleepycat: this works on linux + #-bsd + (uffi:load-foreign-library "/usr/local/BerkeleyDB.4.2/lib/libdb.so" + :module "sleepycat") + ;; this works on FreeBSD + #+bsd (uffi:load-foreign-library "/usr/local/lib/db42/libdb.so" :module "sleepycat") + + ;; Libsleepycat.so: edit this (uffi:load-foreign-library - "/home/ben/lisp/elephant/libsleepycat.so" -;; "/usr/local/share/common-lisp/elephant/libsleepycat.so" + "/usr/local/share/common-lisp/elephant/libsleepycat.so" :module "libsleepycat") + + ;; fini on user editable part (def-type pointer-int (* :int)) (def-type pointer-void :pointer-void) From blee at common-lisp.net Sun Aug 29 20:41:55 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Sun, 29 Aug 2004 22:41:55 +0200 Subject: [elephant-cvs] CVS update: elephant/src/utils.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv9597/src Modified Files: utils.lisp Log Message: new license Date: Sun Aug 29 22:41:55 2004 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.1 elephant/src/utils.lisp:1.2 --- elephant/src/utils.lisp:1.1 Sun Aug 29 09:47:33 2004 +++ elephant/src/utils.lisp Sun Aug 29 22:41:55 2004 @@ -12,6 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; +;;; This program is released under the following license +;;; ("GPL"). For differenct licensing terms, contact the +;;; copyright holders. +;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software From blee at common-lisp.net Mon Aug 30 21:14:29 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:14:29 +0200 Subject: [elephant-cvs] CVS update: elephant/src/classes.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32223/src Modified Files: classes.lisp Log Message: merged in andrew's fixes: class slots, inheritence. added slot-boundp, slot-makunbound. Date: Mon Aug 30 23:14:25 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.5 elephant/src/classes.lisp:1.6 --- elephant/src/classes.lisp:1.5 Sun Aug 29 22:36:18 2004 +++ elephant/src/classes.lisp Mon Aug 30 23:14:25 2004 @@ -40,7 +40,6 @@ ;;; Suite 330, Boston, MA 02111-1307 USA ;;; -;; TODO: slot-bound-p (check the database) (in-package "ELEPHANT") @@ -67,6 +66,29 @@ (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) (call-next-method)))) +(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) + (let* ((class (class-of 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) + (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)))) + (loop for slot-def in (class-slots class) + when (member (slot-definition-name slot-def) + persistent-slot-inits) + 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))))) + (apply #'call-next-method instance transient-slot-inits initargs))))) + (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (declare (ignore class)) (let ((name (slot-definition-name slot-def))) @@ -77,3 +99,19 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name))) +(defmethod slot-boundp-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-boundp instance name))) + +(defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (buffer-write-int (oid instance) *key-buf*) + (let* ((key-length (serialize (slot-definition-name slot-def) *key-buf*)) + (buf (db-delete-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length + :transaction *current-transaction* + :auto-commit *auto-commit*))))) + \ No newline at end of file From blee at common-lisp.net Mon Aug 30 21:14:49 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:14:49 +0200 Subject: [elephant-cvs] CVS update: elephant/src/elephant.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32243/src Modified Files: elephant.lisp Log Message: merged in andrew's fixes: class slots, inheritence. Date: Mon Aug 30 23:14:49 2004 Author: blee Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.6 elephant/src/elephant.lisp:1.7 --- elephant/src/elephant.lisp:1.6 Sun Aug 29 22:38:43 2004 +++ elephant/src/elephant.lisp Mon Aug 30 23:14:49 2004 @@ -63,22 +63,29 @@ #+cmu (:import-from :pcl validate-superclass - slot-definition-name standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition - initialize-internal-slot-functions direct-slot-definition-class - compute-effective-slot-definition-initargs effective-slot-definition-class slot-definition-name - slot-definition-reader-function - slot-definition-writer-function + slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class + slot-boundp-using-class slot-definition-allocation - compute-slots) + compute-slots + + initialize-internal-slot-functions + compute-effective-slot-definition-initargs + slot-definition-reader-function + slot-definition-writer-function + slot-definition-boundp-function + slot-definition-allocation-class + class-slot-cells + plist-value + +slot-unbound+) #+cmu (:import-from :ext make-weak-pointer weak-pointer-value finalize) @@ -86,16 +93,17 @@ #+sbcl (:import-from :sb-mop validate-superclass - slot-definition-name standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class + slot-boundp-using-class slot-definition-allocation compute-slots) #+sbcl @@ -103,7 +111,12 @@ initialize-internal-slot-functions compute-effective-slot-definition-initargs slot-definition-reader-function - slot-definition-writer-function) + slot-definition-writer-function + slot-definition-boundp-function + slot-definition-allocation-class + class-slot-cells + plist-value + +slot-unbound+) #+sbcl (:import-from :sb-ext make-weak-pointer weak-pointer-value finalize) @@ -111,17 +124,17 @@ #+allegro (:import-from :clos validate-superclass - slot-definition-name standard-slot-definition - slot-definition-initargs standard-direct-slot-definition standard-effective-slot-definition direct-slot-definition-class effective-slot-definition-class slot-definition-name + slot-definition-initfunction compute-effective-slot-definition class-slots slot-value-using-class + slot-boundp-using-class slot-definition-allocation compute-slots) #+allegro From blee at common-lisp.net Mon Aug 30 21:15:19 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:15:19 +0200 Subject: [elephant-cvs] CVS update: elephant/src/metaclasses.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32303/src Modified Files: metaclasses.lisp Log Message: merged in andrew's fixes: class slots, inheritence. added slot-boundp, slot-makunbound. Date: Mon Aug 30 23:15:13 2004 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.2 elephant/src/metaclasses.lisp:1.3 --- elephant/src/metaclasses.lisp:1.2 Sun Aug 29 22:40:06 2004 +++ elephant/src/metaclasses.lisp Mon Aug 30 23:15:12 2004 @@ -80,14 +80,14 @@ (defmethod slot-definition-allocation ((slot-definition persistent-slot-definition)) :class) -#+(or cmu sbcl) -(defmethod initialize-internal-slot-functions ((slot persistent-slot-definition)) - (handle-optimized-accessors slot)) - (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient))) - (cond ((or (eq allocation-key :class) transient-p) + (cond ((and (eq allocation-key :class) transient-p) + (find-class 'transient-direct-slot-definition)) + ((and (eq allocation-key :class) (not transient-p)) + (error "Persistent class slots are not supported, try :transient t.")) + (transient-p (find-class 'transient-direct-slot-definition)) (t (find-class 'persistent-direct-slot-definition))))) @@ -95,6 +95,9 @@ (defmethod validate-superclass ((class persistent-metaclass) (super standard-class)) t) +(defmethod validate-superclass ((class standard-class) (super persistent-metaclass)) + nil) + (defgeneric persistent-p (class)) (defmethod persistent-p ((class t)) @@ -103,6 +106,9 @@ (defmethod persistent-p ((class persistent-metaclass)) t) +(defmethod persistent-p ((class persistent-slot-definition)) + t) + (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((transient-p (getf initargs :transient))) (cond (transient-p @@ -110,6 +116,29 @@ (t (find-class 'persistent-effective-slot-definition))))) +#+(or cmu sbcl) +(defgeneric ensure-storage-exists (class slot-definition slot-name)) + +#+(or cmu sbcl) +(defmethod ensure-storage-exists (class slot-definition slot-name) + nil) + +#+(or cmu sbcl) +(defmethod ensure-storage-exists (class (slot-definition persistent-slot-definition) slot-name) + (let ((use-class (or (slot-definition-allocation-class slot-definition) + class))) + (when (not (assoc slot-name (class-slot-cells use-class))) + (setf (plist-value use-class 'class-slot-cells) + (append + (plist-value use-class 'class-slot-cells) + (list (cons slot-name +slot-unbound+))))))) + +#+(or cmu sbcl) +(defmethod compute-effective-slot-definition :around ((class persistent-metaclass) slot-name direct-slot-definitions) + (let ((slot-definition (call-next-method))) + (ensure-storage-exists class slot-definition slot-name) + slot-definition)) + (defun ensure-transient-chain (slot-definitions initargs) (declare (ignore initargs)) (loop for slot-definition in slot-definitions @@ -123,8 +152,6 @@ (setf (getf initargs :allocation) :class) initargs)))) -(defparameter *buffer* (make-array 1000)) - (defmacro persistent-slot-reader (instance name) `(progn (buffer-write-int (oid ,instance) *key-buf*) @@ -139,10 +166,11 @@ #-cmu (error 'unbound-slot :instance ,instance :name ,name))))) +#+(or cmu sbcl) (defun make-persistent-reader (name) (lambda (instance) (declare (optimize (speed 3)) - (type persistent instance)) + (type persistent-object instance)) (persistent-slot-reader instance name))) (defmacro persistent-slot-writer (new-value instance name) @@ -157,23 +185,39 @@ :auto-commit *auto-commit*) ,new-value))) +#+(or cmu sbcl) (defun make-persistent-writer (name) (lambda (new-value instance) (declare (optimize (speed 3)) - (type persistent instance)) + (type persistent-object instance)) (persistent-slot-writer new-value instance name))) -(defgeneric handle-optimized-accessors (slot-def)) +(defmacro persistent-slot-boundp (instance name) + `(progn + (buffer-write-int (oid ,instance) *key-buf*) + (let* ((key-length (serialize ,name *key-buf*)) + (buf (db-get-key-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length))) + (if buf T nil)))) -(defmethod handle-optimized-accessors ((slot-def t)) - slot-def) +#+(or cmu sbcl) +(defun make-persistent-slot-boundp (name) + (lambda (instance) + (declare (optimize (speed 3)) + (type persistent-object instance)) + (persistent-slot-boundp instance name))) -(defmethod handle-optimized-accessors ((slot-def persistent-slot-definition)) +#+(or cmu sbcl) +(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition)) (let ((name (slot-definition-name slot-def))) (setf (slot-definition-reader-function slot-def) (make-persistent-reader name)) (setf (slot-definition-writer-function slot-def) - (make-persistent-writer name))) + (make-persistent-writer name)) + (setf (slot-definition-boundp-function slot-def) + (make-persistent-slot-boundp name))) slot-def) (defun persistent-slot-names (class) @@ -181,3 +225,9 @@ (loop for slot-definition in slot-definitions when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition)) collect (slot-definition-name slot-definition)))) + +(defun transient-slot-names (class) + (let ((slot-definitions (class-slots class))) + (loop for slot-definition in slot-definitions + unless (persistent-p slot-definition) + collect (slot-definition-name slot-definition)))) \ No newline at end of file From blee at common-lisp.net Mon Aug 30 21:36:55 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:36:55 +0200 Subject: [elephant-cvs] CVS update: elephant/src/sleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv5168/src Modified Files: sleepycat.lisp Log Message: db-delete-* returns T on success, Nil if it couldn't find the record Date: Mon Aug 30 23:36:55 2004 Author: blee Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.6 elephant/src/sleepycat.lisp:1.7 --- elephant/src/sleepycat.lisp:1.6 Sun Aug 29 22:41:30 2004 +++ elephant/src/sleepycat.lisp Mon Aug 30 23:36:54 2004 @@ -760,15 +760,23 @@ (flags :unsigned-int)) :returning :int) -(wrap-errno db-delete-buffered (db transaction key key-length flags) - :flags (auto-commit) - :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type array-or-pointer-char key) - (type fixnum key-length) - (type boolean auto-commit)) - :transaction transaction) +(defun db-delete-buffered (db key key-length &key auto-commit + (transaction *current-transaction*)) + (declare (optimize (speed 3) (safety 0) (space 0)) + (type pointer-void db transaction) (type array-or-pointer-char key) + (type fixnum key-length) (type boolean auto-commit)) + (let ((errno (%db-delete-buffered db transaction + key key-length + (flags :auto-commit auto-commit)))) + (declare (type fixnum errno)) + (cond ((= errno 0) t) + ((or (= errno DB_NOTFOUND) + (= errno DB_KEYEMPTY)) + nil) + ((or (= errno DB_LOCK_DEADLOCK) + (= errno DB_LOCK_NOTGRANTED)) + (throw transaction transaction)) + (t (error 'db-error :errno errno))))) (def-function ("db_del" %db-delete) ((db :pointer-void) @@ -778,17 +786,24 @@ (flags :unsigned-int)) :returning :int) -(wrap-errno db-delete (db transaction key key-length flags) - :flags (auto-commit) - :keys ((key-length (length key)) - (transaction *current-transaction*)) - :cstrings (key) - :declarations (declare (optimize (speed 3) (safety 0) (space 0)) - (type pointer-void db transaction) - (type string key) - (type fixnum key-length) - (type boolean auto-commit)) - :transaction transaction) +(defun db-delete (db key &key auto-commit (key-length (length key)) + (transaction *current-transaction*)) + (declare (optimize (speed 3) (safety 0) (space 0)) + (type pointer-void db transaction) (type string key) + (type fixnum key-length) (type boolean auto-commit)) + (with-cstrings ((key key)) + (let ((errno + (%db-delete db transaction key + key-length (flags :auto-commit auto-commit)))) + (declare (type fixnum errno)) + (cond ((= errno 0) nil) + ((or (= errno DB_NOTFOUND) + (= errno DB_KEYEMPTY)) + nil) + ((or (= errno DB_LOCK_DEADLOCK) + (= errno DB_LOCK_NOTGRANTED)) + (throw transaction transaction)) + (t (error 'db-error :errno errno)))))) ;; Transactions From blee at common-lisp.net Mon Aug 30 21:37:37 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:37:37 +0200 Subject: [elephant-cvs] CVS update: elephant/NOTES Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv5190 Modified Files: NOTES Log Message: added preliminary notes on the metaclass stuff Date: Mon Aug 30 23:37:37 2004 Author: blee Index: elephant/NOTES diff -u elephant/NOTES:1.3 elephant/NOTES:1.4 --- elephant/NOTES:1.3 Sun Aug 29 09:44:47 2004 +++ elephant/NOTES Mon Aug 30 23:37:36 2004 @@ -33,10 +33,20 @@ CLASSES AND METACLASSES ----------------------- -***Andrew write your stuff here*** - Persistent classes which the user defines are declared and -instrumented by using the persistent-metaclass. +instrumented by using the persistent-metaclass. Ideally +creating persistent versions of class, slot-defintion, et al +would be enough, but in reality various implementations do +things in different ways. + +CMUCL / SBCL: their's a bit of work to make class slot +allocation and reader / writer / slot-boundp work right. + +Allegro: is using slot-boundp instead of +slot-boundp-using-class inside of shared-initialize, which +necessitates some work. + +Andrew will add some notes here in the future. ----------- COLLECTIONS From blee at common-lisp.net Mon Aug 30 21:37:52 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:37:52 +0200 Subject: [elephant-cvs] CVS update: Directory change: elephant/tests Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv5247/tests Log Message: Directory /project/elephant/cvsroot/elephant/tests added to the repository Date: Mon Aug 30 23:37:52 2004 Author: blee New directory elephant/tests added From blee at common-lisp.net Mon Aug 30 21:39:10 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:39:10 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/mop-tests.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv7086/tests Added Files: mop-tests.lisp Log Message: initial version Date: Mon Aug 30 23:39:09 2004 Author: blee From blee at common-lisp.net Mon Aug 30 21:40:00 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:40:00 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testserializer.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv7111/tests Added Files: testserializer.lisp Log Message: initial version Date: Mon Aug 30 23:39:59 2004 Author: blee From blee at common-lisp.net Mon Aug 30 21:40:38 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:40:38 +0200 Subject: [elephant-cvs] CVS update: elephant/tests/testsleepycat.lisp Message-ID: Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv7156/tests Added Files: testsleepycat.lisp Log Message: initial version Date: Mon Aug 30 23:40:38 2004 Author: blee From blee at common-lisp.net Mon Aug 30 21:41:35 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Mon, 30 Aug 2004 23:41:35 +0200 Subject: [elephant-cvs] CVS update: elephant/TODO Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv7183 Added Files: TODO Log Message: initial version Date: Mon Aug 30 23:41:34 2004 Author: blee From blee at common-lisp.net Mon Aug 30 22:05:33 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 31 Aug 2004 00:05:33 +0200 Subject: [elephant-cvs] CVS update: elephant/CREDITS Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv12366 Added Files: CREDITS Log Message: initial version Date: Tue Aug 31 00:05:32 2004 Author: blee From blee at common-lisp.net Mon Aug 30 22:05:44 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 31 Aug 2004 00:05:44 +0200 Subject: [elephant-cvs] CVS update: elephant/ChangeLog Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv12645 Added Files: ChangeLog Log Message: initial version Date: Tue Aug 31 00:05:41 2004 Author: blee From blee at common-lisp.net Mon Aug 30 22:05:51 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 31 Aug 2004 00:05:51 +0200 Subject: [elephant-cvs] CVS update: elephant/NEWS Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv12829 Added Files: NEWS Log Message: initial version Date: Tue Aug 31 00:05:48 2004 Author: blee From blee at common-lisp.net Mon Aug 30 22:05:59 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 31 Aug 2004 00:05:59 +0200 Subject: [elephant-cvs] CVS update: elephant/README Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv12906 Modified Files: README Log Message: reorg Date: Tue Aug 31 00:05:59 2004 Author: blee Index: elephant/README diff -u elephant/README:1.1 elephant/README:1.2 --- elephant/README:1.1 Fri Aug 27 19:30:34 2004 +++ elephant/README Tue Aug 31 00:05:58 2004 @@ -37,7 +37,6 @@ License + Warrenty ------------------ -Elephant is licensed under the GPL without any warrenty. See LICENSE. ---------------------- @@ -47,32 +46,13 @@ See INSTALL and TUTORIAL. ------ -Status +Design ------ -An alpha release is planned by the end of August 2004. If -you're desparate to use it / help, contact me (blee (at) -thisdomain) for sources. Since Elephant is alpha, claims -about correctness, performance and safety should be taken -with a grain of salt. Eventually it will be portable but is -developed on CMUCL, and tested on Allegro; we're also -targeting OpenMCL, SBCL and Lispworks. +See NOTES. -We are only part-time hackers and would appreciate any -support we can get, in feedback, testing, and development -help. - -Design: - -* Metaclasses declare CLOS persistence. Store controller -object provides interface to underlying DB. - -* One big BTree. Automatically serialize / deserialize -values. Persistent objects stored by OID. - -* Access to BTrees via hash-table-like Lisp objects. - -* Liveness determined by reachability from a root Btree. - -* Delegate as much as possible to Berkeley DB. +------- +Authors +------- +See CREDITS. \ No newline at end of file From blee at common-lisp.net Mon Aug 30 23:46:17 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 31 Aug 2004 01:46:17 +0200 Subject: [elephant-cvs] CVS update: elephant/README elephant/NEWS elephant/INSTALL elephant/CREDITS Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv5417 Modified Files: README NEWS INSTALL CREDITS Log Message: edits Date: Tue Aug 31 01:46:12 2004 Author: blee Index: elephant/README diff -u elephant/README:1.2 elephant/README:1.3 --- elephant/README:1.2 Tue Aug 31 00:05:58 2004 +++ elephant/README Tue Aug 31 01:46:12 2004 @@ -8,17 +8,18 @@ Elephant is an object database for Common Lisp. It supports storing CLOS objects and most lisp primitives, and access to -BTrees. It uses Sleepycat / Berkeley DB (via UFFI) as it's -underlying store, which is server-less, ACID compliant, -transactional, process and thread safe, and fast relative to -relational databases; hopefully Elephant inherits these -properties. +BTrees. It uses Sleepycat / Berkeley DB, a +widely-distributed embedded database; many unix systems have +it installed by default. Sleepycat is server-less, ACID +compliant, transactional, process and thread safe, and fast +relative to relational databases; hopefully Elephant +inherits these properties. Goals: -* Transparency: arbitrary CLOS objects are easy to persist -without much effort or special syntax. Talk to the DB with -Lisp code, not SQL or another domain-specific language. No +* Transparency: most Lisp values are easy to persist without +much effort or special syntax. Talk to the DB with Lisp +code, not SQL or another domain-specific language. No additional server to run. * Safety: ACID, transactions. Concurrent with good @@ -29,10 +30,16 @@ programmer. Lisp and Berkeley DB together are an excellent substrate, try to use their features as much as possible. -* Performance: in addition to concurrent / transactional +* Performance: leverage Sleepycat performance and +reliability. In addition to fast concurrent / transactional modes, elephant will (eventually) offer an accellerated single-user mode. +Join the Elephant mailing lists to ask your questions and +receive updates. They're on the Elephant website + +http://www.common-lisp.net/project/elephant + ------------------ License + Warrenty ------------------ @@ -55,4 +62,10 @@ Authors ------- -See CREDITS. \ No newline at end of file +See CREDITS. + +---- +News +---- + +See NEWS and ChangeLog. \ No newline at end of file Index: elephant/NEWS diff -u elephant/NEWS:1.1 elephant/NEWS:1.2 --- elephant/NEWS:1.1 Tue Aug 31 00:05:48 2004 +++ elephant/NEWS Tue Aug 31 01:46:12 2004 @@ -1,9 +1,13 @@ -August 30, 2004 - Alpha version 0.1 is released. Elephant -works on CMUCL, SBCL, and Allegro on Linux and FreeBSD. As -a proof of concept I've compiled and run CL-IRC +August 30, 2004 - -http:://www.common-lisp.net/project/cl-irc - -making all the objects persistent. It runs, and saves -everything except for the socket-streams. +Elephant 0.1 was released August 30th, 2004. This is an +ALPHA quality release, so claims about correctness, +performance and safety should be taken with a grain of salt. +This release has been tested on CMUCL, SBCL and Allegro on +x86 Linux and FreeBSD. OpenMCL and Lispworks versions will +come soon. As a proof of concept I've compiled and run CL-IRC +making all objects and slots persistent, except for the +socket-streams. It runs, and saves everything except for +the socket-streams. Index: elephant/INSTALL diff -u elephant/INSTALL:1.4 elephant/INSTALL:1.5 --- elephant/INSTALL:1.4 Sun Aug 29 22:31:26 2004 +++ elephant/INSTALL Tue Aug 31 01:46:12 2004 @@ -37,11 +37,12 @@ with the provided file. -2) Install Berkeley DB 4.2. FreeBSD has a port for this, as -I'm sure other BSDs (including Darwin.) Take note of where -libdb.so and db.h are installed (usually -/usr/local/BerekleyDB.4.2/lib/libdb.so and -/usr/local/BerekleyDB.4.2/include/db.h, or +2) Install Berkeley DB 4.2. You may actually already have +this installed. The version number is important. FreeBSD +has a port for this, as I'm sure do other BSDs (including +Darwin/Fink.) Take note of where libdb.so and db.h are +installed (usually /usr/local/BerekleyDB.4.2/lib/libdb.so +and /usr/local/BerekleyDB.4.2/include/db.h, or /usr/local/lib/db42/libdb.so and /usr/local/include/db42/db.h.) Index: elephant/CREDITS diff -u elephant/CREDITS:1.1 elephant/CREDITS:1.2 --- elephant/CREDITS:1.1 Tue Aug 31 00:05:32 2004 +++ elephant/CREDITS Tue Aug 31 01:46:12 2004 @@ -6,7 +6,7 @@ Thanks to: -Sleepycat / Margo Selzter for Berkeley DB +Sleepycat for Berkeley DB Kevin Rosenberg for UFFI, answering lots of questions and letting me patch @@ -15,7 +15,9 @@ Rafal Strzalinski for the Makefile and package patch -The CMUCL and SBCL people for a great compiler +The common-lisp.net people for hosting + +The CMUCL and SBCL people for great compilers SLIME for a better environment From blee at common-lisp.net Mon Aug 30 23:53:33 2004 From: blee at common-lisp.net (blee at common-lisp.net) Date: Tue, 31 Aug 2004 01:53:33 +0200 Subject: [elephant-cvs] CVS update: elephant/NEWS Message-ID: Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv5658 Modified Files: NEWS Log Message: versions Date: Tue Aug 31 01:53:32 2004 Author: blee Index: elephant/NEWS diff -u elephant/NEWS:1.2 elephant/NEWS:1.3 --- elephant/NEWS:1.2 Tue Aug 31 01:46:12 2004 +++ elephant/NEWS Tue Aug 31 01:53:32 2004 @@ -4,10 +4,13 @@ Elephant 0.1 was released August 30th, 2004. This is an ALPHA quality release, so claims about correctness, performance and safety should be taken with a grain of salt. -This release has been tested on CMUCL, SBCL and Allegro on -x86 Linux and FreeBSD. OpenMCL and Lispworks versions will -come soon. As a proof of concept I've compiled and run CL-IRC +This release has been tested on CMUCL 19a, SBCL 0.8.13 and +Allegro 6.2 on x86 Linux and FreeBSD. OpenMCL and Lispworks +versions will come soon. As a proof of concept I've +compiled and run CL-IRC + +http:://www.common-lisp.net/project/cl-irc + making all objects and slots persistent, except for the socket-streams. It runs, and saves everything except for the socket-streams.