December 2006 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS elephant/src/memutil
by ieslick 16 Dec '06

16 Dec '06

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv4494/src/memutil Modified Files: memutil.lisp Log Message: Checkpoint for 0.6.1 feature set - BROKEN --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/11/11 22:53:13 1.12 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/12/16 19:35:10 1.13 @@ -49,6 +49,8 @@ #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string #+(and sbcl sb-unicode) #:buffer-read-ucs4-string #:byte-length + + #:serialize-string #:deserialize-string #:pointer-int #:pointer-void #:array-or-pointer-char +NULL-CHAR+ +NULL-VOID+ @@ -80,20 +82,24 @@ (length :int)) :returning :void)) -(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-str-to-buf copy-bufs - ;;resize-buffer-stream - ;;buffer-stream-buffer buffer-stream-size buffer-stream-position - ;;buffer-stream-length - reset-buffer-stream - 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-ucs1-string - #+(or lispworks (and allegro ics)) buffer-read-ucs2-string - #+(and sbcl sb-unicode) buffer-read-ucs4-string)) +(eval-when (compile) + (declaim + (optimize (speed 3) (safety 1) (space 0) (debug 0)) + (inline read-int read-uint read-float read-double + write-int write-uint write-float write-double + offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs + ;;resize-buffer-stream + ;;buffer-stream-buffer buffer-stream-size buffer-stream-position + ;;buffer-stream-length + reset-buffer-stream + 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-ucs1-string + #+(or lispworks (and allegro ics)) buffer-read-ucs2-string + #+(and sbcl sb-unicode) buffer-read-ucs4-string)) + ) ;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -103,6 +109,17 @@ (defvar +NULL-CHAR+ (make-null-pointer :char) "A null pointer to a char type.") + +(defmacro memutil-without-interrupts (&body body) + "Ensure platform dependent atomicity" + `( + #+allegro excl:without-interrupts + #+lispworks lispworks:without-interrupts + #+sbcl sb-sys:without-interrupts + #+cmu system:without-interrupts + #+openmcl ccl:without-interrupts + ,@body)) + ;; Thread local storage (special variables) (defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) @@ -125,16 +142,16 @@ (defun grab-buffer-stream () "Grab a buffer-stream from the *buffer-streams* resource pool." - (declare (optimize (speed 3))) (if (= (length *buffer-streams*) 0) (make-buffer-stream) - (vector-pop *buffer-streams*))) + (memutil-without-interrupts + (vector-pop *buffer-streams*)))) (defun return-buffer-stream (bs) "Return a buffer-stream to the *buffer-streams* resource pool." - (declare (optimize (speed 3))) (reset-buffer-stream bs) - (vector-push-extend bs *buffer-streams*)) + (memutil-without-interrupts + (vector-push-extend bs *buffer-streams*))) (defmacro with-buffer-streams (names &body body) "Grab a buffer-stream, executes forms, and returns the @@ -159,18 +176,16 @@ #+(or cmu sbcl) (defun read-int (buf offset) "Read a 32-bit signed integer from a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type fixnum offset)) (the (signed-byte 32) (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) - (* (signed 32))))) + (* (signed 32)))))) #+(or cmu sbcl) (defun read-uint (buf offset) "Read a 32-bit unsigned integer from a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type fixnum offset)) (the (unsigned-byte 32) (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -179,8 +194,7 @@ #+(or cmu sbcl) (defun read-float (buf offset) "Read a single-float from a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type fixnum offset)) (the single-float (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -189,8 +203,7 @@ #+(or cmu sbcl) (defun read-double (buf offset) "Read a double-float from a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type fixnum offset)) (the double-float (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -199,8 +212,7 @@ #+(or cmu sbcl) (defun write-int (buf num offset) "Write a 32-bit signed integer to a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type (signed-byte 32) num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -209,8 +221,7 @@ #+(or cmu sbcl) (defun write-uint (buf num offset) "Write a 32-bit unsigned integer to a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type (unsigned-byte 32) num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -219,8 +230,7 @@ #+(or cmu sbcl) (defun write-float (buf num offset) "Write a single-float to a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type single-float num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -229,8 +239,7 @@ #+(or cmu sbcl) (defun write-double (buf num offset) "Write a double-float to a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type double-float num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -239,8 +248,7 @@ #+(or cmu sbcl) (defun offset-char-pointer (p offset) "Pointer arithmetic." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) p) + (declare (type (alien (* char)) p) (type fixnum offset)) (sap-alien (sap+ (alien-sap p) offset) (* char))) @@ -345,23 +353,21 @@ #+(or cmu sbcl scl) (defun copy-str-to-buf (d do s so l) - (declare (optimize (speed 3) (safety 0)) - (type array-or-pointer-char d) - (type fixnum do so l) - (type string s)) - (%copy-str-to-buf d do - #+sbcl - (sb-sys:vector-sap s) - #+(or cmu scl) - (sys:vector-sap s) - so l)) + (declare (type array-or-pointer-char d) + (type fixnum do so l) + (type string s)) + (%copy-str-to-buf d do + #+sbcl + (sb-sys:vector-sap s) + #+(or cmu scl) + (sys:vector-sap s) + so l)) ;; but OpenMCL can't directly pass string bytes. #+openmcl (defun copy-str-to-buf (dest dest-offset src src-offset length) "Copy a string to a foreign buffer. From Gary Byers." - (declare (optimize (speed 3) (safety 0)) - (type string src) + (declare (type string src) (type array-or-pointer-char dest) (type fixnum length src-offset dest-offset) (dynamic-extent src dest length)) @@ -374,7 +380,7 @@ ;; (defun copy-str-to-buf (dest dest-offset src src-offset length) ;; "Use build-in unicode handling and copying facilities. ;; NOTE: We need to validate the speed of this vs. default." -;; (declare (optimize (speed 3) (safety 0)) +;; (declare ;; (type string src) ;; (type array-or-pointer-char dest) ;; (type fixnum length src-offset dest-offset) @@ -386,11 +392,10 @@ #+(not (or cmu sbcl scl openmcl lispworks)) (defun copy-str-to-buf (dest dest-offset src src-offset length) "Copy a string to a foreign buffer." - (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)) + (declare (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 @@ -419,8 +424,7 @@ (defun resize-buffer-stream (bs length) "Resize the underlying buffer of a buffer-stream, copying the old data." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type fixnum length)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -441,8 +445,7 @@ (defun resize-buffer-stream-no-copy (bs length) "Resize the underlying buffer of a buffer-stream." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type fixnum length)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -461,15 +464,13 @@ (defun reset-buffer-stream (bs) "'Empty' the buffer-stream." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (setf (buffer-stream-size bs) 0) (setf (buffer-stream-position bs) 0)) (defun buffer-write-byte (b bs) "Write a byte." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type (unsigned-byte 8) b)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -483,8 +484,7 @@ (defun buffer-write-int (i bs) "Write a 32-bit signed integer." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type (signed-byte 32) i)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -499,8 +499,7 @@ (defun buffer-write-uint (u bs) "Write a 32-bit unsigned integer." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type (unsigned-byte 32) u)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -515,8 +514,7 @@ (defun buffer-write-float (d bs) "Write a single-float." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type single-float d)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -531,8 +529,7 @@ (defun buffer-write-double (d bs) "Write a double-float." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type double-float d)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -547,9 +544,8 @@ (defun buffer-write-string (s bs) "Write the underlying bytes of a string. On Unicode -Lisps, this is a 16-bit operation." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + Lisps, this is a 16-bit operation." + (declare (type buffer-stream bs) (type string s)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -577,8 +573,7 @@ (defun buffer-read-byte (bs) "Read a byte." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (incf (buffer-stream-position bs)) (deref-array (buffer-stream-buffer bs) '(:array :unsigned-byte) position))) @@ -586,8 +581,7 @@ (defun buffer-read-byte-vector (bs) "Read the whole buffer into byte vector." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let* ((position (buffer-stream-position bs)) (size (buffer-stream-size bs)) (vlen (- size position))) @@ -599,8 +593,7 @@ (defun buffer-write-byte-vector (bs bv) "Read the whole buffer into byte vector." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let* ((position (buffer-stream-position bs)) (size (buffer-stream-size bs)) (vlen (length bv)) @@ -611,40 +604,35 @@ (defun buffer-read-fixnum (bs) "Read a 32-bit signed integer, which is assumed to be a fixnum." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (the fixnum (read-int (buffer-stream-buffer bs) position)))) (defun buffer-read-int (bs) "Read a 32-bit signed integer." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (the (signed-byte 32) (read-int (buffer-stream-buffer bs) position)))) (defun buffer-read-uint (bs) "Read a 32-bit unsigned integer." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) position)))) (defun buffer-read-float (bs) "Read a single-float." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (read-float (buffer-stream-buffer bs) position))) (defun buffer-read-double (bs) "Read a double-float." [43 lines skipped]

1 0

[elephant-cvs] CVS elephant
by ieslick 16 Dec '06

16 Dec '06

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv4494 Modified Files: NOTES TODO config.sexp ele-bdb.asd elephant.asd Log Message: Checkpoint for 0.6.1 feature set - BROKEN --- /project/elephant/cvsroot/elephant/NOTES 2006/04/26 17:53:43 1.7 +++ /project/elephant/cvsroot/elephant/NOTES 2006/12/16 19:35:09 1.8 @@ -28,7 +28,6 @@ database / serializer, specials are needed. Also specials will probably play nice with threaded lisps. - ----------------------- CLASSES AND METACLASSES ----------------------- @@ -182,17 +181,22 @@ SERIALIZER: GENERAL ------------------- -Currently assumes a 32-bit architecture, e.g. fixnums fit in -(signed-byte 32), that there are single- and double-floats -(IEEE). Shouldn't be hard to port. +** Ian: update this + +The serializer should be lisp independant but is machine architecture dependant. +Serialization depends on endianness and the native size of fixnums (31 bit or +63 bit) so that a fixnum written on a 64-bit machine would fail on a 32-bit machine +and vice versa. These restrictions are made for the sake of performance. To move +machine architectures (i.e. x86-32 to x86-64, or PPC to x86) you'll need to dump +the DB to some format. (Migration will not work in these instances although someone +is welcome to write a serialization tool that will read foreign formats. I don't think +the time is worth it compared to other features) No optimization for specialized arrays at the moment, other than strings (which should be wickedly fast.) the serializer and deserializer are recursive etypecase and -conds, respectively. in the case of the serializer on -CMUCL this appears to be better than generic functions, -though i don't know why. +conds, respectively. --------------------------- SERIALIZER: PRIMITIVE TYPES @@ -280,6 +284,23 @@ support callables, closures, structures et al. +----------------- +Backend Protocol +----------------- + +In generalizing the elephant metaclass and serializer so it can +work with multiple backend we formalized the interface between the +lisp common functionality and the SQL/BDB specific logic. There +are five protocols backends need to support: + +- Controller setup/teardown +- Persistent slot API +- Collection API +- Transaction API +- Symbol ID serialization protocol + +** Ian TODO + --------- SLEEPYCAT --------- @@ -355,6 +376,14 @@ don't in many cases) should see better non-consing behavior hopefully. -Waiting for Berkeley DB 4.3 to get counters (sequences.) -ETA October 2004. +There are several BDB specific functions available via the +BDB store-controller. +1) Database compaction: when deleting large swaths of the database + it helps to compact the disk storage so we free up disk space. +2) Deadlock detection; when running multi-threaded, one lisp + thread can block another depending on how they're interleaved. + Also if we have multiple OS processes or machines talking + to the same DB we can end up with a deadlock situation. + The typical solution is to run deadlock detection in a separate + thread or launch a process to do so... \ No newline at end of file --- /project/elephant/cvsroot/elephant/TODO 2006/11/11 18:41:10 1.30 +++ /project/elephant/cvsroot/elephant/TODO 2006/12/16 19:35:09 1.31 @@ -1,5 +1,5 @@ -Last updated: November 11, 2006 +Last updated: November 21, 2006 Ongoing release plan notes: @@ -7,19 +7,23 @@ -------------------------------------------- Bugs or Observations: -x 64-bit support (from Marco) -x Windows support for asdf-based library builds? -x MCL 1.1 unicode support; rationalize other lisp support for unicode +- Windows support for asdf-based library builds? Include dll? +- Validate migration 0.6.0->0.6.1 +- Full 64-bit support (arrays, native 64-bit fixnums, etc) + - char vs. uint8 in buffer-stream + - flexible handling of 64-bit fixnums Stability: -- Remove build gensym warnings in sleepycat +- Remove build gensym warnings in sleepycat.lisp - Delete persistent slot values from the slot store with remove-kv to ensure that there's no data left lying around if you define then redefine a class and add back a persistent slot name that you thought was deleted and it gets the old value by default. - Cleaner failure modes if operations are performed without repository or without - transaction or auto-commit (Both) -- Review all the NOTE comments in the code + transaction or auto-commit (auto-commit solved by 4.4?) +- Review all NOTE comments in the code +- Validate that migrate can use either O(c) or O(n/c) where c << n memory +- Migrate code base to SVN and create tickets in TRAC Store variables: - Think through default *store-controller* vs. explicit parameter passing @@ -30,15 +34,15 @@ - Throw condition when store spec is invalid, etc Multi-threading operation: -- Make elephant threads appropriately bind dynamic variables -- Verify that operations such as indexing are thread safe -- Verify that serialization is thread safe +- Make elephant threads appropriately bind dynamic variables? +x Verify that operations such as indexing are thread safe BDB Features: -~ Automatically run db_deadlock when opening a bdb backend? Requires path to +? Determine how to detect deadlock conditions as an optional run-safe mode? +? Automatically run db_deadlock when opening a bdb backend? Requires path to functions and ability to launch shell command. Closing the store stops the sub-process. -- Always support locks that timeout? Tradeoffs? +? Always support locks that timeout? Tradeoffs? - Roll deprecation of *auto-commit* through code base so leaf functions stop referring to it - Trace all paths to db-put or db-delete and ensure that there is a check or a default with-transaction around the primitive components - write a document @@ -73,6 +77,7 @@ Documentation: - Add notes about with-transaction usage (abort & commit behavior on exit) - Add notes about optimize-storage +- Add notes about fast-symbols - Add notes about new BDB 4.4 *auto-commit* behavior. Default for entire store-controller, will auto create a transaction if none is active if open with :auto-commit t or will never auto-commit (regardless of operator flags) if it is not. Make sure open-store @@ -80,15 +85,22 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- +x Improved optimization options to be more user controlled (Pierre Thierry) +x Implement backend support for symbol-table protocol +x Speed up symbol storage and reference using symbol id's +x Ensure serialization is thread-safe and reasonably efficient +x MCL 1.1 unicode support; rationalize other lisp support for unicode +x Modularize serializers for easy upgrade x New build interface; all-lisp compilation (sans win32) -x Ensure serialization is multi-threaded and efficient -x Determine how to detect deadlock conditions as an optional run-safe mode? +x Simplify user-specific configuration parameters using config.sexp and my-config.sexp +x Make sure to ensure thread safety in buffer-stream allocation! + x BDB overwrite of values makes DB grow [So far I can only find that it grows on the 2nd write, but not after that...artifact of page allocation or caching of memory pools?] x FEATURE: Investigate BDB record size; it's 2x larger than expected? [Ditto above] -x Update to support BDB 4.4 +x Update to support BDB 4.4/4.5 x Add ability from within lisp to reclaim DB space after deleting btree key-value pairs x Should we delete slot-values in the db when redefining classes, currently those values stay around - probably indefinitely unless we GC (no, we'll resolve this with a @@ -100,8 +112,9 @@ 0.6.2 - Advanded work, low-hanging fruit (Fall '06) -------------------------------------------------- - Class option MOP add-on to support declared persistent baseclass slots for standard base classes - - Port elephant to closer-to-MOP to make it easier to support additional lisps and to - seriously clean up metaclasses.lisp and classes.lisp protocols + - Evaluate porting elephant to closer-to-MOP to make it easier to + support additional lisps and to seriously clean up + metaclasses.lisp and classes.lisp protocols - A wrapper around migration that emulates a stop-and-copy GC 0.6.3 - Documentation & Tools (Winter '06) @@ -117,7 +130,7 @@ 0.7.0: Fast In-Memory Database (Not backwards compatible) -------------------------------------------------- - - Integrate prevalence-like in-memory database system + - Integrate prevalence-like in-memory database system for single image, multiple-thread operation - Fast serializer port w/ upgrade strategy and prevalence like storage solution - Further improve SQL 64-bit serialization performance (if possible) - (From Ben's e-mail) We are storing persistent objects incorrectly. They should be @@ -127,12 +140,13 @@ [Ian comment: only problem with this is an extra access to oid table each time a class is deserialized and overall storage is constant. Would make it easy to invalidate objects though!] - - Richer controller modes: - - Single-user mode (cache values in instance slots for fast reads, write-through) - - Prevalence mode (read/write to normal slots except on object creation or synch) - (in-memory slot indexing, on disk class) - (works for any backend) + - Richer set of policy decisions on per-class basis - Concurrent mode (for backends that allow multiple processes to connect, current default) + - Single-user mode (cache values in instance slots for fast reads, write-through) + - Backing store mode (read/write to normal slots except on object creation or synch) + (in-memory slot indexing, on disk class) + (works for any backend) + - Backing-store mode - Controller 'switches' - NoSynch - allow transactions to be lost on failure but maintains consistency instead of performance - Usage model examples --- /project/elephant/cvsroot/elephant/config.sexp 2006/11/11 18:45:04 1.1 +++ /project/elephant/cvsroot/elephant/config.sexp 2006/12/16 19:35:09 1.2 @@ -1,7 +1,8 @@ ((:berkeley-db-root . "/usr/local/BerkeleyDB.4.4/") (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.4/lib/libDB-4.4.dylib") (:pthread-lib . nil) - (:clsql-lib . nil)) + (:clsql-lib . nil) + (:fast-symbols . t)) ;; Typical pthread settings are: /lib/tls/libpthread.so.0 ;; nil means that the library in question is not loaded --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/11/11 18:41:10 1.12 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/12/16 19:35:09 1.13 @@ -45,8 +45,8 @@ (defclass bdb-c-source (elephant-c-source) ()) (defmethod compiler-options ((compiler (eql :gcc)) (c bdb-c-source) &key &allow-other-keys) - (let* ((include (merge-pathnames (get-config-option :berkeley-db-root c) "include")) - (lib (merge-pathnames (get-config-option :berkeley-db-root c) "lib"))) + (let* ((include (make-pathname :directory (get-config-option :berkeley-db-include-dir c))) + (lib (make-pathname :directory (get-config-option :berkeley-db-lib-dir c)))) (append (list (format nil "-L~A" lib) (format nil "-I~A" include)) (call-next-method) (list "-ldb")))) @@ -78,8 +78,10 @@ (:bdb-c-source "libberkeley-db") (:file "berkeley-db") (:file "bdb-controller") - (:file "bdb-transactions") - (:file "bdb-collections")) + (:file "bdb-symbol-tables") + (:file "bdb-slots") + (:file "bdb-collections") + (:file "bdb-transactions")) :serial t)))) :depends-on (:uffi :elephant)) --- /project/elephant/cvsroot/elephant/elephant.asd 2006/11/11 06:27:37 1.20 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/12/16 19:35:09 1.21 @@ -146,12 +146,16 @@ (:module elephant :components ((:file "package") - (:file "variables") + (:file "cross-platform") #+cmu (:file "cmu-mop-patches") #+openmcl (:file "openmcl-mop-patches") + (:file "variables") (:file "transactions") (:file "metaclasses") (:file "classes") + (:file "serializer1") ;; 0.6.0 db's + (:file "serializer2") ;; 0.6.1 db's + (:file "unicode2") (:file "serializer") (:file "cache") (:file "controller") @@ -162,5 +166,5 @@ (:file "backend")) :serial t :depends-on (memutil))))) - :depends-on (:uffi)) + :depends-on (:uffi :cl-base64))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 16 Dec '06

16 Dec '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv4494/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp libberkeley-db.c package.lisp Log Message: Checkpoint for 0.6.1 feature set - BROKEN --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/11/11 18:41:10 1.10 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/12/16 19:35:10 1.11 @@ -36,17 +36,17 @@ (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) + (serialize key key-buf sc) (let ((buf (db-get-key-buffered (controller-btrees sc) key-buf value-buf))) - (if buf (values (deserialize buf :sc sc) T) + (if buf (values (deserialize buf sc) T) (values nil nil)))))) (defmethod existsp (key (bt bdb-btree)) (declare (optimize (speed 3) (safety 0) (space 0))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) + (serialize key key-buf (get-con bt)) (let ((buf (db-get-key-buffered (controller-btrees (get-con bt)) key-buf value-buf))) @@ -57,25 +57,43 @@ (defmethod (setf get-value) (value key (bt bdb-btree)) (declare (optimize (speed 3) (safety 0) (space 0))) (assert (or *auto-commit* (not (eq *current-transaction* 0)))) -;; (with-transaction (:store-controller (get-con bt)) - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (serialize value value-buf) - (db-put-buffered (controller-btrees (get-con bt)) - key-buf value-buf - :auto-commit *auto-commit*) - value)) +;; (with-transaction () + (let ((sc (get-con bt))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid bt) key-buf) + (serialize key key-buf sc) + (serialize value value-buf sc) + (db-put-buffered (controller-btrees sc) + key-buf value-buf + :auto-commit *auto-commit*))) +;; ) + value) + +;; (labels ((write-value () +;; (let ((sc (get-con bt))) +;; (with-buffer-streams (key-buf value-buf) +;; (buffer-write-int (oid bt) key-buf) +;; (serialize key key-buf sc) +;; (serialize value value-buf sc) +;; (db-put-buffered (controller-btrees sc) +;; key-buf value-buf +;; :auto-commit *auto-commit*) +;; value)))) +;; (if (eq *current-transaction* 0) +;; (with-transaction (:store-controller (get-con bt)) +;; (write-value)) +;; (write-value)))) (defmethod remove-kv (key (bt bdb-btree)) (declare (optimize (speed 3) (space 0) (safety 0))) (assert (or *auto-commit* (not (eq *current-transaction* 0)))) ;; (with-transaction (:store-controller (get-con bt)) + (let ((sc (get-con bt)) ) (with-buffer-streams (key-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (db-delete-buffered (controller-btrees (get-con bt)) - key-buf :auto-commit *auto-commit*))) + (serialize key key-buf sc) + (db-delete-buffered (controller-btrees sc) + key-buf :auto-commit *auto-commit*)))) ;; Secondary indices @@ -123,9 +141,9 @@ (with-buffer-streams (primary-buf secondary-buf) (flet ((index (key skey) (buffer-write-int (oid bt) primary-buf) - (serialize key primary-buf) + (serialize key primary-buf sc) (buffer-write-int (oid index) secondary-buf) - (serialize skey secondary-buf) + (serialize skey secondary-buf sc) ;; should silently do nothing if ;; the key/value already exists (db-put-buffered @@ -175,8 +193,8 @@ (let ((indices (indices-cache bt))) (with-buffer-streams (key-buf value-buf secondary-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (serialize value value-buf) + (serialize key key-buf sc) + (serialize value value-buf sc) (with-transaction (:store-controller sc) (db-put-buffered (controller-btrees sc) key-buf value-buf) @@ -187,7 +205,7 @@ (when index? ;; Manually write value into secondary index (buffer-write-int (oid index) secondary-buf) - (serialize secondary-key secondary-buf) + (serialize secondary-key secondary-buf sc) ;; should silently do nothing if the key/value already ;; exists (db-put-buffered (controller-indices sc) @@ -202,7 +220,7 @@ (let ((sc (get-con bt))) (with-buffer-streams (key-buf secondary-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) + (serialize key key-buf sc) (with-transaction (:store-controller sc) (let ((value (get-value key bt))) (when value @@ -214,7 +232,7 @@ (funcall (key-fn index) index key value) (when index? (buffer-write-int (oid index) secondary-buf) - (serialize secondary-key secondary-buf) + (serialize secondary-key secondary-buf sc) ;; need to remove kv pairs with a cursor! -- ;; this is a C performance hack (db-delete-kv-buffered @@ -237,25 +255,26 @@ (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) + (serialize key key-buf (get-con bt)) (let ((buf (db-get-key-buffered (controller-indices-assoc (get-con bt)) key-buf value-buf))) - (if buf (values (deserialize buf :sc (get-con bt)) T) + (if buf (values (deserialize buf (get-con bt)) T) (values nil nil))))) (defmethod get-primary-key (key (bt btree-index)) (declare (optimize (speed 3))) - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (let ((buf (db-get-key-buffered - (controller-indices (get-con bt)) - key-buf value-buf))) - (if buf - (let ((oid (buffer-read-fixnum buf))) - (values (deserialize buf :sc (get-con bt)) oid)) - (values nil nil))))) + (let ((sc (get-con bt))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid bt) key-buf) + (serialize key key-buf sc) + (let ((buf (db-get-key-buffered + (controller-indices sc) + key-buf value-buf))) + (if buf + (let ((oid (buffer-read-fixnum buf))) + (values (deserialize buf sc) oid)) + (values nil nil)))))) (defclass bdb-cursor (cursor) ((handle :accessor cursor-handle :initarg :handle)) @@ -286,20 +305,20 @@ (defmethod cursor-current ((cursor bdb-cursor)) (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) - (with-buffer-streams (key-buf value-buf) - (multiple-value-bind (key val) - (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf - :current t) - (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key - :sc (get-con (cursor-btree cursor))) - (deserialize val - :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil)))))) + (let ((sc (get-con (cursor-btree cursor)))) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf + :current t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key sc) + (deserialize val sc))) + (setf (cursor-initialized-p cursor) nil))))))) (defmethod cursor-first ((cursor bdb-cursor)) (declare (optimize (speed 3))) + (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) (multiple-value-bind (key val) @@ -307,15 +326,15 @@ key-buf value-buf :set-range t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key - :sc (get-con (cursor-btree cursor))) - (deserialize val - :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil))))) + (values t + (deserialize key sc) + (deserialize val sc))) + (setf (cursor-initialized-p cursor) nil)))))) ;;A bit of a hack..... (defmethod cursor-last ((cursor bdb-cursor)) (declare (optimize (speed 3))) + (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) (if (db-cursor-set-buffered (cursor-handle cursor) @@ -328,10 +347,8 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key - :sc (get-con (cursor-btree cursor))) - (deserialize val - :sc (get-con (cursor-btree cursor))))) + (values t (deserialize key sc) + (deserialize val sc))) (setf (cursor-initialized-p cursor) nil)))) (multiple-value-bind (key val) (db-cursor-move-buffered (cursor-handle cursor) key-buf @@ -339,71 +356,75 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key - :sc (get-con (cursor-btree cursor))) - (deserialize val - :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil)))))) + (values t (deserialize key sc) + (deserialize val sc ))) + (setf (cursor-initialized-p cursor) nil))))))) (defmethod cursor-next ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) - (with-buffer-streams (key-buf value-buf) - (multiple-value-bind (key val) - (db-cursor-move-buffered (cursor-handle cursor) - key-buf value-buf :next t) - (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key :sc (get-con (cursor-btree cursor))) - (deserialize val :sc (get-con (cursor-btree cursor)))) - (setf (cursor-initialized-p cursor) nil)))) + (let ((sc (get-con (cursor-btree cursor)))) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :next t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key sc) + (deserialize val sc)) + (setf (cursor-initialized-p cursor) nil))))) (cursor-first cursor))) (defmethod cursor-prev ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) - (with-buffer-streams (key-buf value-buf) - (multiple-value-bind (key val) - (db-cursor-move-buffered (cursor-handle cursor) - key-buf value-buf :prev t) - (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key :sc (get-con (cursor-btree cursor))) - (deserialize val :sc (get-con (cursor-btree cursor)))) - (setf (cursor-initialized-p cursor) nil)))) - (cursor-last cursor))) + (let ((sc (get-con (cursor-btree cursor)))) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :prev t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key sc) + (deserialize val sc)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-last cursor)))) (defmethod cursor-set ((cursor bdb-cursor) key) (declare (optimize (speed 3))) + (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) - (serialize key key-buf) + (serialize key key-buf sc) (multiple-value-bind (k val) (db-cursor-set-buffered (cursor-handle cursor) key-buf value-buf :set t) (if k - (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize val :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil))))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t key (deserialize val sc))) + (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-set-range ((cursor bdb-cursor) key) (declare (optimize (speed 3))) + (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) - (serialize key key-buf) + (serialize key key-buf sc) (multiple-value-bind (k val) (db-cursor-set-buffered (cursor-handle cursor) key-buf value-buf :set-range t) (if (and k (= (buffer-read-int k) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize k :sc (get-con (cursor-btree cursor))) - (deserialize val :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil))))) + (values t (deserialize k sc) + (deserialize val sc))) + (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-get-both ((cursor bdb-cursor) key value) (declare (optimize (speed 3))) + (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) - (serialize key key-buf) - (serialize value value-buf) + (serialize key key-buf sc) + (serialize value value-buf sc) (multiple-value-bind (k v) (db-cursor-get-both-buffered (cursor-handle cursor) key-buf value-buf :get-both t) @@ -411,21 +432,22 @@ (if k (progn (setf (cursor-initialized-p cursor) t) (values t key value)) - (setf (cursor-initialized-p cursor) nil))))) + (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-get-both-range ((cursor bdb-cursor) key value) (declare (optimize (speed 3))) + (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) - (serialize key key-buf) - (serialize value value-buf) + (serialize key key-buf sc) + (serialize value value-buf sc) (multiple-value-bind (k v) (db-cursor-get-both-buffered (cursor-handle cursor) key-buf value-buf :get-both-range t) (if k (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize v :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil))))) + (values t key (deserialize v sc))) + (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-delete ((cursor bdb-cursor)) (declare (optimize (speed 3))) @@ -438,7 +460,7 @@ (when (and key (= (buffer-read-int key) (cursor-oid cursor))) ;; in case of a secondary index this should delete everything ;; as specified by the BDB docs. - (remove-kv (deserialize key :sc (get-con (cursor-btree cursor))) + (remove-kv (deserialize key (get-con (cursor-btree cursor))) (cursor-btree cursor))) (setf (cursor-initialized-p cursor) nil))) (error "Can't delete with uninitialized cursor!"))) @@ -458,7 +480,7 @@ (declare (ignore v)) (if (and k (= (buffer-read-int k) (cursor-oid cursor))) (setf (get-value - (deserialize k :sc (get-con (cursor-btree cursor))) + (deserialize k (get-con (cursor-btree cursor))) (cursor-btree cursor)) value) (setf (cursor-initialized-p cursor) nil)))) @@ -489,14 +511,11 @@ :current t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t - (deserialize - key - :sc (get-con (cursor-btree cursor))) - (deserialize - val - :sc (get-con (cursor-btree cursor))) - (progn (buffer-read-int pkey) (deserialize pkey)))) [275 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/11/11 18:41:10 1.13 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/12/16 19:35:10 1.14 @@ -25,6 +25,8 @@ :accessor controller-environment) (oid-db :type (or null pointer-void) :accessor controller-oid-db) (oid-seq :type (or null pointer-void) :accessor controller-oid-seq) + (symid-db :type (or null pointer-void) :accessor controller-symid-db) + (symid-seq :type (or null pointer-void) :accessor controller-symid-seq) (btrees :type (or null pointer-void) :accessor controller-btrees) (indices :type (or null pointer-void) :accessor controller-indices) (indices-assoc :type (or null pointer-void) @@ -55,7 +57,20 @@ (string t) (otherwise nil)))) +(defmethod controller-version ((sc store-controller)) + (let ((version (controller-version sc))) + (if version version + (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) + (if (probe-file path) + (with-open-file (stream path :direction :input) + (read stream)) + (with-open-file (stream path :direction :output) + (write *elephant-code-version* :stream stream))))))) + +;; ;; Open/close +;; + (defmethod open-controller ((sc bdb-store-controller) &key (recover t) (recover-fatal nil) (thread t) (deadlock-detect nil)) @@ -78,20 +93,20 @@ :auto-commit t :type DB-BTREE :create t :thread thread) (setf (controller-btrees sc) btrees) - (db-bdb::db-set-lisp-compare btrees) + (db-bdb::db-set-lisp-compare btrees (controller-serializer-version sc)) (db-open btrees :file "%ELEPHANT" :database "%ELEPHANTBTREES" :auto-commit t :type DB-BTREE :create t :thread thread) (setf (controller-indices sc) indices) - (db-bdb::db-set-lisp-compare indices) - (db-bdb::db-set-lisp-dup-compare indices) + (db-bdb::db-set-lisp-compare indices (controller-serializer-version sc)) + (db-bdb::db-set-lisp-dup-compare indices (controller-serializer-version sc)) (db-set-flags indices :dup-sort t) (db-open indices :file "%ELEPHANT" :database "%ELEPHANTINDICES" :auto-commit t :type DB-BTREE :create t :thread thread) (setf (controller-indices-assoc sc) indices-assoc) - (db-bdb::db-set-lisp-compare indices-assoc) - (db-bdb::db-set-lisp-dup-compare indices-assoc) + (db-bdb::db-set-lisp-compare indices-assoc (controller-serializer-version sc)) + (db-bdb::db-set-lisp-dup-compare indices-assoc (controller-serializer-version sc)) (db-set-flags indices-assoc :dup-sort t) (db-open indices-assoc :file "%ELEPHANT" :database "%ELEPHANTINDICES" :auto-commit t :type DB-UNKNOWN :thread thread :rdonly t) @@ -110,6 +125,19 @@ :auto-commit t :create t :thread t) (setf (controller-oid-seq sc) oid-seq))) + (let ((db (db-create env))) + (setf (controller-symid-db sc) db) + (db-open db :file "%ELEPHANTSYMID" :database "%ELEPHANTSYMID" + :auto-commit t :type DB-BTREE :create t :thread thread) + (let ((symid-seq (db-sequence-create db))) + (db-sequence-set-cachesize symid-seq *cachesize*) + (db-sequence-set-flags symid-seq :seq-inc t :seq-wrap t) + (db-sequence-set-range symid-seq 0 most-positive-fixnum) + (db-sequence-initial-value symid-seq 0) + (db-sequence-open symid-seq "%ELEPHANTSYMID" + :auto-commit t :create t :thread t) + (setf (controller-symid-seq sc) symid-seq))) + (setf (slot-value sc 'root) (make-instance 'bdb-btree :from-oid -1 :sc sc)) @@ -121,6 +149,13 @@ sc))) +;; NOTE: This was the easist way to do this. A BDB hash table would be better +;; and perhaps generally a better thing to export; however I don't want to +;; go through the effort at this time. + +(defparameter *symbol-to-id-table-oid* -3) +(defparameter *id-to-symbol-table-oid* -4) + (defmethod close-controller ((sc bdb-store-controller)) (when (slot-value sc 'root) (stop-deadlock-detector sc) @@ -130,6 +165,10 @@ ;; clean instance cache (flush-instance-cache sc) ;; close handles / environment + (db-sequence-close (controller-symid-seq sc)) + (setf (controller-symid-seq sc) nil) + (db-close (controller-symid-db sc)) + (setf (controller-symid-db sc) nil) (db-sequence-close (controller-oid-seq sc)) (setf (controller-oid-seq sc) nil) (db-close (controller-oid-db sc)) @@ -152,6 +191,17 @@ (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ :auto-commit t :txn-nosync t)) +(defmethod next-symid ((sc bdb-store-controller)) + (declare (type bdb-store-controller sc)) + (db-sequence-get-fixnum (controller-symid-seq sc) 1 :transaction +NULL-VOID+ + :auto-commit t :txn-nosync t)) + + + +;; +;; Automated Deadlock Support +;; + (defparameter *deadlock-type-alist* '((:oldest . "o") (:youngest . "y") @@ -206,6 +256,10 @@ #+(and (not allegro) port) (port:run-prog "kill" :wait t :args (list "-9" (format nil "~A" pid))) #+(and sbcl linux) (sb-ext:process-kill "/bin/kill" (list "-9" (format nil "~A" pid)))) +;; +;; Take advantage of release 4.4's compact storage feature. Hidden features of BDB only +;; + (defmethod optimize-storage ((ctrl bdb-store-controller) &key start-key stop-key (freelist-only nil) (free-space t) &allow-other-keys) @@ -219,59 +273,12 @@ (db-compact (controller-indices-assoc ctrl) nil nil end) (db-compact (controller-oid-db ctrl) nil nil end)) (progn - (serialize start-key start) + (serialize start-key start ctrl) (db-compact (controller-db ctrl) start - (when stop-key (serialize stop-key stop) stop) + (when stop-key (serialize stop-key stop ctrl) stop) end :freelist-only freelist-only :free-space free-space))) - (values (deserialize end :sc ctrl)))) - -;; -;; Persistent slot protocol -;; + (values (deserialize end ctrl)))) -(defmethod persistent-slot-reader ((sc bdb-store-controller) instance name) -;; (declare (optimize (speed 3) (safety 1) (space 1))) - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid instance) key-buf) - (serialize name key-buf) - (let ((buf (db-get-key-buffered (controller-db sc) - key-buf value-buf))) - (if buf (deserialize buf :sc sc) - #+cmu - (error 'unbound-slot :instance instance :slot name) - #-cmu - (error 'unbound-slot :instance instance :name name))))) - -(defmethod persistent-slot-writer ((sc bdb-store-controller) new-value instance name) -;; (declare (optimize (speed 3) (safety 1) (space 1))) -;; (format t "psw -- sc: ~A ct: ~A ac: ~A~%" *store-controller* *current-transaction* *auto-commit*) - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid instance) key-buf) - (serialize name key-buf) - (serialize new-value value-buf) - (db-put-buffered (controller-db sc) - key-buf value-buf - :transaction *current-transaction* - :auto-commit *auto-commit*) - new-value)) - -(defmethod persistent-slot-boundp ((sc bdb-store-controller) instance name) -;; (declare (optimize (speed 3) (safety 1) (space 1))) - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid instance) key-buf) - (serialize name key-buf) - (let ((buf (db-get-key-buffered (controller-db sc) - key-buf value-buf))) - (if buf t nil)))) - -(defmethod persistent-slot-makunbound ((sc bdb-store-controller) instance name) -;; (declare (optimize (speed 3) (safety 1) (space 1))) - (with-buffer-streams (key-buf) - (buffer-write-int (oid instance) key-buf) - (serialize name key-buf) - (db-delete-buffered (controller-db sc) key-buf - :transaction *current-transaction* - :auto-commit *auto-commit*))) --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2006/11/11 18:41:10 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2006/12/16 19:35:10 1.2 @@ -55,6 +55,7 @@ ;;; */ +#include <stdint.h> #include <string.h> #include <wchar.h> @@ -66,17 +67,41 @@ /* Pointer arithmetic utility functions */ /* should these be in network-byte order? probably not..... */ int read_int(char *buf, int offset) { - int i; + int int; memcpy(&i, buf+offset, sizeof(int)); return i; } -unsigned int read_uint(char *buf, int offset) { - unsigned int ui; +int read_uint(char *buf, int offset) { + unsigned int ui; memcpy(&ui, buf+offset, sizeof(unsigned int)); return ui; } +int32_t read_int32(char *buf, int offset) { + int int32_t; + memcpy(&i, buf+offset, sizeof(int32_t)); + return i; +} + +uint32_t read_uint32(char *buf, int offset) { + uint32_t ui; + memcpy(&ui, buf+offset, sizeof(uint32_t)); + return ui; +} + +int64_t read_int64(char *buf, int offset) { + int64_t i; + memcpy(&i, buf+offset, sizeof(int64_t)); + return i; +} + +uint64_t read_uint64(char *buf, int offset) { + uint64_t ui; + memcpy(&ui, buf+offset, sizeof(uint64_t)); + return ui; +} + float read_float(char *buf, int offset) { float f; memcpy(&f, buf+offset, sizeof(float)); @@ -89,14 +114,33 @@ return d; } +/* Platform specific integer */ void write_int(char *buf, int num, int offset) { memcpy(buf+offset, &num, sizeof(int)); } -void write_uint(char *buf, unsigned int num, int offset) { +void write_uint(char *buf, unsighed int num, int offset) { memcpy(buf+offset, &num, sizeof(unsigned int)); } + +/* Well-defined integer widths */ +void write_int32(char *buf, int32_t num, int offset) { + memcpy(buf+offset, &num, sizeof(int32_t)); +} + +void write_uint32(char *buf, uint32_t num, int offset) { + memcpy(buf+offset, &num, sizeof(uint32_t)); +} + +void write_int64(char *buf, int64_t num, int offset) { + memcpy(buf+offset, &num, sizeof(int64_t)); +} + +void write_uint64(char *buf, uint64_t num, int offset) { + memcpy(buf+offset, &num, sizeof(uint64_t)); +} + void write_float(char *buf, float num, int offset) { memcpy(buf+offset, &num, sizeof(float)); } @@ -228,7 +272,7 @@ return db->set_dup_compare(db, dup_compare_fcn); } -#define type_numeric(c) ((c)<8) +#define type_numeric1(c) ((c)<8) #include <math.h> double read_num(char *buf); @@ -239,7 +283,9 @@ /* Inspired by the BDB docs. We have to memcpy to insure memory alignment. */ -int lisp_compare(DB *dbp, const DBT *a, const DBT *b) { + +/* Original serializer */ +int lisp_compare1(DB *dbp, const DBT *a, const DBT *b) { int difference; double ddifference; char *ad, *bd, at, bt; @@ -262,7 +308,7 @@ at = ad[4]; bt = bd[4]; /* Compare numerics. */ - if (type_numeric(at) && type_numeric(bt)) { + if (type_numeric1(at) && type_numeric1(bt)) { ddifference = read_num(ad+4) - read_num(bd+4); if (ddifference > 0) return 1; else if (ddifference < 0) return -1; @@ -270,6 +316,7 @@ } /* Compare types. */ + if difference = at - bt; if (difference) return difference; @@ -294,12 +341,81 @@ } } -int db_set_lisp_compare(DB *db) { - return db->set_bt_compare(db, &lisp_compare); +#define type_numeric2(c) ((c)<9) + +/* New serializer */ +int lisp_compare2(DB *dbp, const DBT *a, const DBT *b) { + int difference; + double ddifference; + char *ad, *bd, at, bt; + ad = (char*)a->data; + bd = (char*)b->data; + + /* Compare OIDs: OIDs are limited by native integer width */ + difference = read_int(ad, 0) - read_int(bd, 0); + if (difference) return difference; + + /* Have a type tag? */ + if (a->size == 4) + if (b->size == 4) + return 0; + else + return -1; + else if (b->size == 4) + return 1; + + at = ad[4]; bt = bd[4]; + + /* Compare numerics. */ + if (type_numeric2(at) && type_numeric2(bt)) { + ddifference = read_num2(ad+4) - read_num2(bd+4); + if (ddifference > 0) return 1; + else if (ddifference < 0) return -1; + return 0; + } + + /* Compare types. */ + if + difference = at - bt; + if (difference) return difference; + + ;; TODO: compare strings of different sizes? + ;; TODO: compare symbol-ids? + + /* Same type! */ + switch (at) { + case #x3F: /* nil */ + return 0; + case 9: /* 8-bit string */ + if( bt == 9 ) + return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); + else + return full_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)) + case 10: /* 16-bit string */ + return utf16_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); + case 11: + return wcs_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); + default: + return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); + } +} + +int db_set_lisp_compare(DB *db, int version) { + switch (version) { + case 1: + return db->set_bt_compare(db, &lisp_compare1); + default: + return db->set_bt_compare(db, &lisp_compare2); + } } -int db_set_lisp_dup_compare(DB *db) { - return db->set_dup_compare(db, &lisp_compare); +int db_set_lisp_dup_compare(DB *db, int version) { + switch (version) { + case 1: + return db->set_dup_compare(db, &lisp_compare1); + default: + return db->set_dup_compare(db, &lisp_compare2); + } } #ifndef exp2 --- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/11/11 18:41:10 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/12/16 19:35:10 1.3 @@ -26,7 +26,7 @@ Elephant, but with some magic for Elephant. In general there is a 1-1 mapping from functions here and functions in Berkeley DB, so refer to their documentation for details.") - (:use common-lisp uffi elephant-memutil elephant elephant-backend) + (:use common-lisp uffi elephant-memutil elephant-backend elephant) #+cmu (:use alien) #+sbcl @@ -40,4 +40,5 @@ #+openmcl (:import-from :ccl #:byte-length) - ) + (:export + #:optimize-storage))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 16 Dec '06

16 Dec '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4494/src/elephant Modified Files: backend.lisp controller.lisp package.lisp serializer.lisp transactions.lisp variables.lisp Log Message: Checkpoint for 0.6.1 feature set - BROKEN --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/20 15:45:37 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/12/16 19:35:10 1.5 @@ -36,14 +36,19 @@ #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers + #:*elephant-code-version* #:store-controller #:open-controller #:close-controller + #:controller-serialize + #:controller-deserialize #:controller-spec #:controller-root + #:controller-version #:controller-class-root #:root #:spec #:class-root #:flush-instance-cache + #:controller-symbol-cache #:controller-symbol-id-cache ;; Collection generic functions #:btree #:btree-index #:indexed-btree #:build-indexed-btree #:build-btree #:existsp @@ -52,12 +57,18 @@ #:deserialize #:serialize #:deserialize-from-base64-string #:serialize-to-base64-string + ;; Serialization callbacks + #:lookup-persistent-symbol + #:lookup-persistent-symbol-id ;; Cursor accessors #:cursor #:cursor-btree #:cursor-oid #:cursor-initialized-p ;; Transactions + #:*transaction-stack* + #:*current-transaction* + #:*auto-commit* #:execute-transaction #:controller-start-transaction #:controller-commit-transaction @@ -68,6 +79,9 @@ #:register-backend-con-init #:lookup-backend-con-init ) + (:import-from :elephant-serializer2 + #:serialize-symbol-complete + ) (:export ;; Variables #:*cachesize* @@ -81,28 +95,40 @@ #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers + #:*elephant-code-version* #:store-controller #:open-controller #:close-controller + #:controller-serialize + #:controller-deserialize #:controller-spec #:controller-root #:controller-class-root + #:controller-version #:root #:spec #:class-root #:flush-instance-cache + #:controller-symbol-cache #:controller-symbol-id-cache ;; Collection generic functions #:btree #:btree-index #:indexed-btree #:build-indexed-btree #:build-btree #:existsp #:map-indices ;; Serialization #:deserialize #:serialize + #:serialize-symbol-complete #:deserialize-from-base64-string #:serialize-to-base64-string + ;; Serialization callbacks + #:lookup-persistent-symbol + #:lookup-persistent-symbol-id ;; Cursor accessors #:cursor #:cursor-btree #:cursor-oid #:cursor-initialized-p ;; Transactions + #:*transaction-stack* + #:*auto-commit* + #:*current-transaction* #:execute-transaction #:controller-start-transaction #:controller-commit-transaction --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/11/11 15:30:26 1.16 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/12/16 19:35:10 1.17 @@ -105,10 +105,11 @@ ;; ;; Callback hooks for persistent variables ;; +;; NOTE: Design sketch; not sure I'll include this... -(defvar *variable-hooks* nil - "An alist (specs -> varlist) where varlist is tuple of - lisp name, store name (auto) and policy") +;;(defvar *variable-hooks* nil +;; "An alist (specs -> varlist) where varlist is tuple of +;; lisp name, store name (auto) and policy") ;;(defun add-hook (name spec) ;; (if (assoc spec *variable-hooks* :test #'equal) @@ -147,8 +148,7 @@ ;; (defmethod clear-agents (agent) ;; (setf *agencies* nil)) - - + ;; ;; Open a Store @@ -158,7 +158,8 @@ "Conveniently open a store controller." (assert (consp spec)) (setq *store-controller* (get-controller spec)) - (ensure-marked-version + (initialize-serializer *store-controller*) + (ensure-properties (apply #'open-controller *store-controller* args))) (defun close-store (&optional sc) @@ -196,45 +197,57 @@ :documentation "This should be a persistent btree instantiated by the backend") (class-root :reader controller-class-root :documentation "This should be a persistent indexed btree instantiated by the backend") - ;; NOTE: This is backend specific and should get moved... + ;; Upgradable serializer strategy + (version :accessor controller-version :initform nil) + (serializer-version :accessor controller-serializer-version :initform nil) + (serialize :accessor controller-serialize :initform nil) + (deserialize :accessor controller-deserialize :initform nil) + ;; Symbol ID caches + (symbol-cache :accessor controller-symbol-cache :initform (make-hash-table :size 2000)) + (symbol-id-cache :accessor controller-symbol-id-cache :initform (make-hash-table :size 2000)) ) (:documentation "Class of objects responsible for the book-keeping of holding DB handles, the cache, table creation, counters, locks, the root (for garbage collection,) et cetera.")) +(defun initialize-serializer (sc) + "Establish serializer version on controller startup" + (cond ((equal (controller-version sc) '(0 6 1)) + (setf (controller-serializer-version sc) 2) + (setf (controller-serialize sc) 'elephant-serializer2::serialize) + (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)) + ((prior-version-p (controller-version sc) '(0 6 0)) + (setf (controller-serializer-version sc) 1) + (setf (controller-serialize sc) 'elephant-serializer1::serialize) + (setf (controller-deserialize sc) 'elephant-serializer1::deserialize)) + (t (error "Unsupported Elephant database version")))) + ;; -;; VERSIONING AND UPGRADES +;; VERSIONING ;; -;; Need to tag databases -;; Need to handle untagged db's -;; Need to provide upgrade hooks - (defvar *restricted-properties* '(:version) "Properties that are not user manipulable") -(defmethod controller-properties ((sc store-controller)) - (get-from-root *elephant-properties-label* :store-controller sc)) - -(defmethod set-ele-property (property value &key (sc *store-controller*)) - (assert (and (symbolp property) (not (member property *restricted-properties*)))) - (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) - (setf (get-value *elephant-properties-label* (controller-root sc)) - (if (assoc property props) - (progn (setf (cdr (assoc property props)) value) - props) - (acons property value props))))) +(defgeneric controller-version ((sc store-controller)) + (:documentation "Return the elephant version of this controller - should not + require the serializer to operate as it may be used to determine + the serializer version used to read the DB. This has to be valid + prior to the DB being opened.")) -(defmethod get-ele-property (property &key (sc *store-controller*)) - (assert (symbolp property)) - (let ((entry (assoc property - (get-from-root *elephant-properties-label* - :store-controller sc)))) - (when entry - (cdr entry)))) +(defun prior-version-p (v1 v2) + "Is v1 an equal or earlier version than v2" + (cond ((and (null v1) (null v2)) t) + ((and (null v1) (not (null v2))) t) + ((and (not (null v1)) (null v2)) nil) + ((< (car v1) (car v2)) t) + ((> (car v1) (car v2)) nil) + ((= (car v1) (car v2)) + (prior-version-p (cdr v1) (cdr v2))) + (t (error "Version problem!")))) -(defmethod ensure-marked-version ((sc store-controller)) +(defmethod ensure-properties ((sc store-controller)) "Not sure this test is right (empty root)" (let ((props (controller-properties sc)) (empty? (and (empty-btree-p (controller-root sc)) @@ -250,31 +263,33 @@ (acons :version *elephant-unmarked-code-version* props))))) sc) -(defmethod controller-version ((sc store-controller)) - (let ((alist (controller-properties sc))) - (let ((result (assoc :version alist))) - (if result - (cdr result) - nil)))) + +;; +;; Upgrade paths +;; (defmethod up-to-date-p ((sc store-controller)) (equal (controller-version sc) *elephant-code-version*)) +(defmethod upgrade ((sc store-controller) target-spec) + (unless (upgradable-p sc) + (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" + (controller-spec sc) + (controller-version sc) + *elephant-code-version* + *elephant-upgrade-table*)) + (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your + data does not require any unsupported features") + (let ((source sc) + (target (open-store target-spec))) + (migrate target source) + (close-store target))) + (defparameter *elephant-upgrade-table* '( ((0 6 0) (0 5 0)) + ((0 6 1) (0 6 0)) )) -(defun prior-version-p (v1 v2) - "Is v1 an equal or earlier version than v2" - (cond ((and (null v1) (null v2)) t) - ((and (null v1) (not (null v2))) t) - ((and (not (null v1)) (null v2)) nil) - ((< (car v1) (car v2)) t) - ((> (car v1) (car v2)) nil) - ((= (car v1) (car v2)) - (prior-version-p (cdr v1) (cdr v2))) - (t (error "Version problem!")))) - (defmethod upgradable-p ((sc store-controller)) "Determine if this store can be brought up to date using the upgrade function" (unwind-protect @@ -283,15 +298,30 @@ (when (member ver (rest row) :test #'equal)) t) nil)) -(defmethod upgrade ((sc store-controller)) - (unless (upgradable-p sc) - (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" - (controller-spec sc) - (controller-version sc) - *elephant-code-version* - *elephant-upgrade-table*)) - (warn "Upgrade by migrating your old repository to a clean repository created using the current code base. i.e. (migrate new old)")) - + +;; +;; PROPERTIES +;; + +(defmethod controller-properties ((sc store-controller)) + (get-from-root *elephant-properties-label* :store-controller sc)) + +(defmethod set-ele-property (property value &key (sc *store-controller*)) + (assert (and (symbolp property) (not (member property *restricted-properties*)))) + (let ((props (get-from-root *elephant-properties-label* :store-controller sc))) + (setf (get-value *elephant-properties-label* (controller-root sc)) + (if (assoc property props) + (progn (setf (cdr (assoc property props)) value) + props) + (acons property value props))))) + +(defmethod get-ele-property (property &key (sc *store-controller*)) + (assert (symbolp property)) + (let ((entry (assoc property + (get-from-root *elephant-properties-label* + :store-controller sc)))) + (when entry + (cdr entry)))) ;; ;; OBJECT CACHE @@ -322,7 +352,11 @@ (defparameter *legacy-conversions-db* '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree")) - (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")))) + (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")) + (("sleepycat" . "bdb-btree") . ("db-bdb" . "bdb-btree")) + (("sleepycat" . "bdb-indexed-btree") . ("db-bdb" . "bdb-indexed-btree")) + (("sleepycat" . "bdb-btree-index") . ("db-bdb" . "bdb-btree-index")))) + (defun handle-legacy-classes (name version) (declare (ignore version)) @@ -353,12 +387,15 @@ "Close the db handles and environment. Tries to wipe out references to the db handles.")) -(defgeneric connection-is-indeed-open (controller) - (:documentation "Validate the controller and the db that it is connected to")) +(defgeneric database-version ((sc store-controller)) + (:documentation "A version determination for a given store + controller that is independant of the serializer as the + serializer is dispatched based on the code version which is a + list of the form '(0 6 0)")) -(defmethod connection-is-indeed-open ((controller t)) - "Default implementation is dumb..." - t) +(defgeneric connection-is-indeed-open (controller) + (:documentation "Validate the controller and the db that it is connected to") + (:method ((controller t)) t)) (defgeneric next-oid (sc) (:documentation @@ -369,32 +406,6 @@ "Tell the backend to reclaim any storage caused by key deletion, if possible. This should default to return space to the filesystem rather than just to the free list.")) -;; Handling dbconnection specs - -(defmethod close-controller :after ((sc store-controller)) - "Delete connection spec so object ops on cached db info fail" - (remhash (controller-spec sc) *dbconnection-spec*)) - - - -;; Low-level support for metaclass protocol - -(defgeneric persistent-slot-reader (sc instance name) - (:documentation - "Backend specific slot reader function")) - -(defgeneric persistent-slot-writer (sc new-value instance name) - (:documentation - "Backend specific slot writer function")) - -(defgeneric persistent-slot-boundp (sc instance name) - (:documentation - "Backend specific slot bound test function")) - -(defgeneric persistent-slot-makunbound (sc instance name) - (:documentation - "Backend specific slot makunbound handler")) - ;; ;; Object Root Operations ;; @@ -429,6 +440,47 @@ (map-btree fn (controller-root store-controller))) ;; +;; Handling dbconnection specs +;; + +(defmethod close-controller :after ((sc store-controller)) + "Delete connection spec so object ops on cached db info fail" + (remhash (controller-spec sc) *dbconnection-spec*)) + +;; +;; Support for serialization efficiency +;; + +(defgeneric lookup-persistent-symbol-id (sc symbol) + (:documentation "Return an ID for the provided symbol. This function is + a callback for the serializer that the backends share in + most cases.")) + +(defgeneric lookup-persistent-symbol (sc id) + (:documentation "Return a symbol for the ID. This should always succeed. + The database should not use the existing serializer to perform + this function; but memutils and unicode are available")) +;; +;; Low-level support for metaclass protocol +;; + +(defgeneric persistent-slot-reader (sc instance name) + (:documentation + "Backend specific slot reader function")) + +(defgeneric persistent-slot-writer (sc new-value instance name) + (:documentation + "Backend specific slot writer function")) + +(defgeneric persistent-slot-boundp (sc instance name) + (:documentation + "Backend specific slot bound test function")) + +(defgeneric persistent-slot-makunbound (sc instance name) + (:documentation + "Backend specific slot makunbound handler")) + +;; ;; Explicit storage reclamation ;; --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/11/11 06:27:38 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2006/12/16 19:35:10 1.4 @@ -26,12 +26,15 @@ "Elephant: an object-oriented database for Common Lisp with multiple backends for Berkeley DB, SQL and others.") (:export #:*store-controller* #:*current-transaction* #:*auto-commit* - #:*elephant-lib-path* + #:*elephant-lib-path* #:*elephant-code-version* #:store-controller #:controller-root #:controller-class-root + #:controller-version #:controller-serialize #:controller-deserialize #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp - #:flush-instance-cache #:optimize-storage + #:get-cached-instance #:flush-instance-cache + #:controller-symbol-cache #:controller-symbol-id-cache + #:optimize-storage #:with-transaction #:start-ele-transaction #:commit-transaction #:abort-transaction @@ -48,6 +51,9 @@ #:btree-differ #:migrate #:*inhibit-slot-copy* + #:lookup-persistent-symbol + #:lookup-persistent-symbol-id + #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first @@ -83,6 +89,11 @@ #:get-instances-by-value #:get-instances-by-range #:drop-instances + + ;; Utilities + #:ele-make-lock + #:ele-with-lock + #:ele-without-interrupts ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/11/11 22:53:13 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/12/16 19:35:10 1.15 @@ -16,581 +16,48 @@ (in-package :elephant) -(declaim (inline int-byte-spec - ;serialize deserialize - slots-and-values - deserialize-bignum)) - -(uffi:def-type foreign-char :char) - -;; Constants - -(defconstant +fixnum+ 1) -(defconstant +char+ 2) -(defconstant +single-float+ 3) -(defconstant +double-float+ 4) -(defconstant +negative-bignum+ 5) -(defconstant +positive-bignum+ 6) -(defconstant +rational+ 7) - -(defconstant +nil+ 8) - -;; 8-bit -(defconstant +ucs1-symbol+ 9) -(defconstant +ucs1-string+ 10) -(defconstant +ucs1-pathname+ 11) - -;; 16-bit -(defconstant +ucs2-symbol+ 12) -(defconstant +ucs2-string+ 13) -(defconstant +ucs2-pathname+ 14) - -;; 32-bit -(defconstant +ucs4-symbol+ 20) -(defconstant +ucs4-string+ 21) -(defconstant +ucs4-pathname+ 22) - -(defconstant +persistent+ 15) ;; stored by id+classname -(defconstant +cons+ 16) -(defconstant +hash-table+ 17) -(defconstant +object+ 18) -(defconstant +array+ 19) -(defconstant +struct+ 20) - -(defconstant +fill-pointer-p+ #x40) -(defconstant +adjustable-p+ #x80) +(defun serialize (frob bs sc) + "Generic interface to serialization that dispatches based on the + current Elephant version" + (funcall (symbol-function (controller-serialize sc)) frob bs sc)) + +(defun deserialize (bs sc) + "Generic interface to serialization that dispatches based on the + current Elephant version" + (funcall (symbol-function (controller-deserialize sc)) bs sc)) ;; -;; This may be overkill, but is intended to avoid continually allocating -;; hashes each time we serialize an object. I added some adaptation -;; to keep it from dropping and re-allocating if the user continually saves -;; large collections of objects. However the defaults should handle most -;; apps just fine. The queue is useful because a system with 10 threads -;; will need 10 circularity queues if it is storing large objects +;; SQL encoding support ;; -(defvar *circularity-hash-queue* nil - "Circularity ids for the serializer.") - -;; quick portability hack, do we need to import 'port' or some -;; other thread layer to the elephant dependency list? - -(defun ele-make-lock () - #+allegro (mp::make-process-lock) - #+cmu (mp:make-lock) - #+sbcl (sb-thread:make-mutex) - #+mcl (ccl:make-lock) - #+lispworks (mp:make-lock) - #-(or allegro sbcl cmu lispworks mcl) nil ) - -(defmacro ele-with-lock ((lock) &body body) - #+allegro `(mp:with-process-lock (,lock) ,@body) - #+cmu `(mp:with-lock-held (,lock) ,@body) - #+sbcl `(sb-thread:with-mutex (,lock) ,@body) - #+lispworks `(mp:with-lock (,lock) ,@body) - #+mcl `(ccl:with-lock-grabbed (,lock) ,@body) - #-(or allegro sbcl cmu lispworks mcl) `(progn ,@body) ) - -(defvar *circularity-lock* - (ele-make-lock)) - -(defun drop-circularity-hash-p (hash) - "This allows us to tune our memory usage to the application. - If grow-ceiling-p is enabled then we'll slowly adapt to - a growing demand so we balance GC load and reserved memory" - (if (> (hash-table-size hash) *circularity-max-hash-size*) - (if (and *circularity-grow-ceiling-p* - (>= (incf *circularity-adapt-count*) - *circularity-adapt-step-size*)) - (progn - (setf *circularity-max-hash-size* - (ceiling (* *circularity-growth-factor* - *circularity-max-hash-size*))) - nil) - t) - (progn - (decf *circularity-adapt-count* 0.5) - nil))) - -(defun get-circularity-hash () - (if (not *circularity-hash-queue*) - (make-hash-table :test 'eq :size 50) - (if *circularity-lock* - (ele-with-lock (*circularity-lock*) - (pop *circularity-hash-queue*)) - (pop *circularity-hash-queue*)))) - -(defun release-circularity-hash (hash) - (unless (drop-circularity-hash-p hash) - (clrhash hash) - (if *circularity-lock* - (ele-with-lock (*circularity-lock*) - (push hash *circularity-hash-queue*)) - (push hash *circularity-hash-queue*)))) - - - -(defun serialize (frob bs) - "Serialize a lisp value into a buffer-stream." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((*lisp-obj-id* 0) - (*circularity-hash* (get-circularity-hash))) - (labels - ((%serialize (frob) - (declare (optimize (speed 3) (safety 0))) - (etypecase frob - ((integer #.(- 1 (expt 2 31)) #.(1- (expt 2 31))) ;; 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)) - (buffer-write-byte - #+(and allegro ics) -;; +ucs2-symbol+ - (etypecase s - (base-string +ucs1-symbol+) ;; +ucs1-symbol+ - (string +ucs2-symbol+)) - #+(or (and sbcl sb-unicode) lispworks) - (etypecase s - (base-string +ucs1-symbol+) - (string #+sbcl +ucs4-symbol+ #+lispworks +ucs2-symbol+)) - #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) - +ucs1-symbol+ - bs) - (buffer-write-int (byte-length s) bs) - (buffer-write-string s bs) - (let ((package (symbol-package frob))) - (if package - (%serialize (package-name package)) - (%serialize nil))))) - (string - (progn - (buffer-write-byte - #+(and allegro ics) - (etypecase frob - (base-string +ucs1-string+) ;; +ucs1-string+ - (string +ucs2-string+)) - #+(or (and sbcl sb-unicode) lispworks) - (etypecase frob - (base-string +ucs1-string+) - (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+)) - #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) - +ucs1-string+ - bs) - (buffer-write-int (byte-length frob) bs) - (buffer-write-string frob bs))) - (persistent - (buffer-write-byte +persistent+ bs) - (buffer-write-int (oid frob) bs) - ;; This circumlocution is necessitated by - ;; an apparent bug in SBCL 9.9 --- type-of sometimes - ;; does NOT return the "proper name" of the class as the - ;; CLHS says it should, but gives the class object itself, - ;; which cannot be directly serialized.... - (let ((tp (type-of frob))) - #+(or sbcl) - (if (not (symbolp tp)) - (setf tp (class-name (class-of frob)))) - (%serialize tp)) - ) - #-(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 +char+ bs) - ;; might be wide! - (buffer-write-uint (char-code frob) bs)) - (pathname - (let ((s (namestring frob))) - (declare (type string s) (dynamic-extent s)) - (buffer-write-byte - #+(and allegro ics) - (etypecase s - (base-string +ucs1-pathname+) ;; +ucs1-pathname+ - (string +ucs2-pathname+)) - #+(or (and sbcl sb-unicode) lispworks) - (etypecase s - (base-string +ucs1-pathname+) - (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+)) - #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) - +ucs1-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 - ;; this ldb is consing on CMUCL! - ;; there is an OpenMCL function which should work - ;; and non-cons - do - #+(or cmu sbcl) - (buffer-write-uint (ldb (int-byte-spec i) num) bs) ;; (%bignum-ref num i) bs) - #+(or allegro lispworks openmcl) - (buffer-write-uint (ldb (int-byte-spec i) num) 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))))))) -;; (structure-object -;; (buffer-write-byte +struct+ 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 frbo *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))) - (when (array-has-fill-pointer-p frob) - (buffer-write-int (fill-pointer frob) bs)) - (loop for i fixnum from 0 below (array-total-size frob) - do - (%serialize (row-major-aref frob i))))))) - ))) - (%serialize frob) - (release-circularity-hash *circularity-hash*) - 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 = () - do - (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))) - -(defun deserialize (buf-str &key sc) - "Deserialize a lisp value from a buffer-stream." - (declare (optimize (speed 3) (safety 0)) - (type (or null buffer-stream) buf-str)) - (let ((*circularity-hash* (get-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)) -;; (format t "Tag: ~A~%" tag) - (cond - ((= tag +fixnum+) - (buffer-read-fixnum bs)) - ((= tag +nil+) nil) - ((= tag +ucs1-symbol+) - (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) - (maybe-package-name (%deserialize bs))) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) - ((= tag +ucs2-symbol+) - (let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) - (maybe-package-name (%deserialize bs))) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) - #+(and sbcl sb-unicode) - ((= tag +ucs4-symbol+) - (let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) - (maybe-package-name (%deserialize bs))) -;; (format t "ouput name = ~A~%" name) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) - ((= tag +ucs1-string+) - (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) - ((= tag +ucs2-string+) - (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) - #+(and sbcl sb-unicode) - ((= tag +ucs4-string+) - (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) - ((= tag +persistent+) -;; (get-cached-instance *store-controller* - (get-cached-instance sc - (buffer-read-fixnum bs) - (%deserialize bs))) - ((= tag +single-float+) - (buffer-read-float bs)) - ((= tag +double-float+) - (buffer-read-double bs)) - ((= tag +char+) - (code-char (buffer-read-uint bs))) - ((= tag +ucs1-pathname+) - (parse-namestring - (or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) ""))) - ((= tag +ucs2-pathname+) - (parse-namestring - (or (buffer-read-ucs2-string bs (buffer-read-fixnum bs)) ""))) [242 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/06/19 01:03:30 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/12/16 19:35:10 1.4 @@ -52,7 +52,6 @@ :txn-nowait ,txn-nowait :txn-sync ,txn-sync)) - ;; ;; An interface to manage transactions explicitely ;; @@ -68,8 +67,9 @@ (defgeneric controller-abort-transaction (store-controller &key &allow-other-keys) (:documentation "Abort an elephant transaction")) - +;; ;; User Interface +;; (defun start-ele-transaction (&key (store-controller *store-controller*) (parent *current-transaction*) --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/11/10 01:48:49 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/12/16 19:35:10 1.6 @@ -30,12 +30,12 @@ ;;;;;;;;;;;;;;;; ;;;; Versioning Support -(defvar *elephant-code-version* '(0 6 0) +(defvar *elephant-code-version* '(0 6 1) "The current database version supported by the code base") -(defvar *elephant-unmarked-code-version* '(0 5 0) +(defvar *elephant-unmarked-code-version* '(0 6 0) "If a database is opened with existing data but no version then - we assume it's version 0.5.0") + we assume it's version 0.6.0") (defvar *elephant-properties-label* 'elephant::*database-properties* "This is the symbol used to store properties associated with the @@ -48,22 +48,6 @@ (defvar *circularity-initial-hash-size* 50 "This is the default size of the circularity cache used in the serializer") -(defvar *circularity-max-hash-size* 100 - "This is the largest hash table that is maintained by the serializer. Larger - hash tables are dropped from the has queue assuming that it was a one of - transaction or an error.") -(defparameter *circularity-grow-ceiling-p* t - "This enables the system to slowly adapt to larger-than-average lists or other - collections of objects (like large trees) to avoid continually GC'ing large - data structures and reducing total copying over time") -(defparameter *circularity-adapt-step-size* 4 - "How many times we see something over the max in succession before we adapt - to a larger maximum size") -(defparameter *circularity-growth-factor* 0.5 - "How much to increase the max size after each adaptation step") -(defvar *circularity-adapt-count* 0 - "Maintains a count of how many times we've seen a hash table over the appropriate - size. This is reduced by 1/2 each time we don't have one that is oversized.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -86,32 +70,21 @@ (defvar *resourced-byte-spec* (byte 32 0) "Byte specs on CMUCL, SBCL and Allegro are conses.") -;; TODO: make this for real! -;; NOTE: ISE - We have to special case backend variable refs -;; to pull this off so we'll need to do what we did with -;; transactions so bear with me - I'll add this back as soon -;; as someone screams! - -;; (defun run-elephant-thread (thunk) -;; "Sets the specials (which hopefully are thread-local) to -;; make the Elephant thread-safe." -;; (let ((*current-transaction* +NULL-VOID+) -;; (sleepycat::*errno-buffer* (allocate-foreign-object :int 1)) -;; ;; if vector-push-extend et al are thread-safe, this -;; ;; doesn't need to be thread-local. -;; (sleepycat::*buffer-streams* -;; (make-array 0 :adjustable t :fill-pointer t)) -;; (*store-controller* *store-controller*) -;; (*auto-commit* *auto-commit*) -;; (*transaction-stack* -;; (make-array 0 :adjustable t :fill-pointer t)) -;; #+(or cmu sbcl allegro) -;; (*resourced-byte-spec* (byte 32 0))) -;; (declare (special *current-transaction* sleepycat::*errno-buffer* -;; sleepycat::*buffer-streams* -;; *store-controller* *auto-commit* *transaction-stack* -;; #+(or cmu sbcl allegro) *resourced-byte-spec*)) -;; (funcall thunk))) +;; +;; Thread-specific specials +;; + +;; NOTE: how to handle (*errno-buffer* (allocate-foreign-object :int 1)) +(defparameter *elephant-thread-local-vars* + '((*store-controller* *store-controller*) + (*current-transaction* +NULL-VOID+) + (*transaction-stack* (make-array 0 :adjustable t :fill-pointer t)) + #+(or cmu sbcl allegro) (*resourced-byte-spec* (byte 32 0)))) + +(defmacro with-elephant-variables (&body body) + `(let ,*elephant-thread-local-vars* + (declare (special ,(mapcar #'car *elephant-thread-local-vars*))) + ,@body)) ;; get rid of spot idx and adjust the arrray (defun remove-indexed-element-and-adjust (idx array)

1 0