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

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

16 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4094 Added Files: cross-platform.lisp serializer1.lisp serializer2.lisp unicode2.lisp Log Message: --- /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/cross-platform.lisp 2007/01/16 00:51:25 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; cross-platform.lisp -- convert Lisp data to/from byte arrays ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :elephant) ;; This is a quick portability hack to avoid external dependencies, if we get ;; to many of these do we need to import a standard library? do we need to import 'port' or some ;; other thread layer to the elephant dependency list? (defmacro ele-without-interrupts (&body body) `(elephant-memutil::memutil-without-interrupts ,@body)) (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 &rest ignored) &body body) (declare (ignore ignored) (ignorable lock)) #+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) ) --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/16 00:51:25 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/16 00:51:25 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; serializer.lisp -- convert Lisp data to/from byte arrays ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package "ELEPHANT") (defpackage :elephant-serializer1 (:use :cl :elephant :elephant-memutil) (:import-from :elephant *resourced-byte-spec* get-cached-instance slot-definition-allocation slot-definition-name compute-slots oid)) (in-package :elephant-serializer1) (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 +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80) (defvar *lisp-obj-id* 0 "Circularity ids for the serializer.") (defvar *circularity-hash* (make-hash-table) "Circularity hash for the serializer.") (defun clear-circularity-hash () "This handles the case where we store an object with lots of object references. CLRHASH then starts to dominate performance as it has to visit ever spot in the table so we're better off GCing the old table than clearing it" (declare (optimize (speed 3) (safety 0))) (if (> (hash-table-size *circularity-hash*) 100) (setf *circularity-hash* (make-hash-table :test 'eq :size 50)) (clrhash *circularity-hash*))) (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (setq *lisp-obj-id* 0) (clear-circularity-hash) (labels ((%serialize (frob) (declare (optimize (speed 3) (safety 0))) (typecase frob (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) (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 (%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))))))) (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) 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 sc) "Deserialize a lisp value from a buffer-stream." (declare (optimize (speed 3) (safety 0)) (type (or null buffer-stream) buf-str)) (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 +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)))) #+(or lispworks (and allegro ics)) ((= 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))) #+(or lispworks (and allegro ics)) ((= 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)) ""))) #+(or lispworks (and allegro ics)) ((= tag +ucs2-pathname+) (parse-namestring (or (buffer-read-ucs2-string bs (buffer-read-fixnum bs)) ""))) #+(and sbcl sb-unicode) ((= tag +ucs4-pathname+) (parse-namestring (or (buffer-read-ucs4-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+) [151 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/16 00:51:25 1.1 [720 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/16 00:51:25 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/16 00:51:25 1.1 [980 lines skipped]

1 0

[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

[elephant-cvs] CVS elephant/src/elephant
by ieslick 11 Nov '06

11 Nov '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv14219/src/elephant Modified Files: serializer.lisp Log Message: Fix bug where BDB tests failing with running SQL backend tests; initial x86/64-bit support for CMUCL/SBCL --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/11/11 15:30:26 1.13 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/11/11 22:53:13 1.14 @@ -140,7 +140,7 @@ ((%serialize (frob) (declare (optimize (speed 3) (safety 0))) (etypecase frob - (fixnum + ((integer #.(- 1 (expt 2 31)) #.(1- (expt 2 31))) ;; fixnum (buffer-write-byte +fixnum+ bs) (buffer-write-int frob bs)) (null @@ -240,7 +240,7 @@ ;; and non-cons do #+(or cmu sbcl) - (buffer-write-uint (%bignum-ref num i) bs) + (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

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 11 Nov '06

11 Nov '06

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv14219/src/memutil Modified Files: memutil.lisp Log Message: Fix bug where BDB tests failing with running SQL backend tests; initial x86/64-bit support for CMUCL/SBCL --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/11/11 06:27:38 1.11 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/11/11 22:53:13 1.12 @@ -164,7 +164,7 @@ (type fixnum offset)) (the (signed-byte 32) (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) - (* integer))))) + (* (signed 32))))) #+(or cmu sbcl) (defun read-uint (buf offset) @@ -204,7 +204,7 @@ (type (signed-byte 32) num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) - (* integer))) num)) + (* (signed 32)))) num)) #+(or cmu sbcl) (defun write-uint (buf num offset)

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 11 Nov '06

11 Nov '06

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv14219/tests Modified Files: testbdb.lisp Log Message: Fix bug where BDB tests failing with running SQL backend tests; initial x86/64-bit support for CMUCL/SBCL --- /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2006/11/11 18:41:11 1.1 +++ /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2006/11/11 22:53:13 1.2 @@ -11,7 +11,7 @@ ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. -(in-package "ELE-TESTS") +(in-package :ele-tests) (defvar env) @@ -29,7 +29,10 @@ (deftest prepares-bdb (progn - (if (find-package :db-bdb) + (setq db nil) + (if (and (find-package :db-bdb) + (eq (first (elephant::controller-spec *store-controller*)) + :BDB)) (finishes (prepare-bdb)) (progn (format t "Berkeley DB not loaded, so not runnning test prepares-bdb~%") @@ -77,11 +80,11 @@ finally (db-bdb::db-sequence-remove seq :auto-commit t)))) (deftest test-seq1 - (if (not (find-package :db-bdb)) + (if (not db) (progn (format t "Berkeley db not loaded, so not runnning test test-seq1~%") - t) - (finishes (test-sequence1))) + t) + (finishes (test-sequence1))) t) (defun test-sequence2 () @@ -118,8 +121,8 @@ (if (not db) (progn (format t "Berkeley DB not open, so not runnning test cleanup-bdb~%") - t) - (finishes (cleanup-bdb))) + t) + (finishes (cleanup-bdb))) t) ;;(unuse-package "DB-BDB")

1 0

[elephant-cvs] CVS elephant
by ieslick 11 Nov '06

11 Nov '06

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv20911 Added Files: config.sexp ele-postgresql.asd Log Message: Missing files from prior checkins -- config.sexp for new build and ele-postgresql from backend cleanup (might even be missing 0.6.0 file) --- /project/elephant/cvsroot/elephant/config.sexp 2006/11/11 18:45:04 NONE +++ /project/elephant/cvsroot/elephant/config.sexp 2006/11/11 18:45:04 1.1 ((: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)) ;; Typical pthread settings are: /lib/tls/libpthread.so.0 ;; nil means that the library in question is not loaded ;; NOTE: The latest SBCL on linux no longer needs the pthread library, ;; it is statically linked against it now with the new thread support--- /project/elephant/cvsroot/elephant/ele-postgresql.asd 2006/11/11 18:45:04 NONE +++ /project/elephant/cvsroot/elephant/ele-postgresql.asd 2006/11/11 18:45:04 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-postgresql.asd -- ASDF system definition for ;;; a PostgreSQL based back-end for Elephant ;;; ;;; Initial version 10/12/2005 by Robert L. Read ;;; <read(a)robertlread.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net> ;;; ;;; This program is released under the following license ;;; ("LLGPL"). ;;; (defsystem ele-postgresql :name "ele-postgresql" :author "Robert L. Read <read(a)robertlread.net>" :version "0.6.0" :maintainer "Robert L. Read <read(a)robertlread.net>" :licence "GPL" :description "PostgreSQL based Object respository for Common Lisp" :components ((:module :src :components ())) :depends-on (:ele-clsql :clsql-postgresql-socket))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 11 Nov '06

11 Nov '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv20735 Added Files: berkeley-db.lisp Log Message: Added a missing file from sleepycat rename --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2006/11/11 18:43:31 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2006/11/11 18:43:31 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; berkeley-db.lisp -- FFI interface to Berkeley DB ;;; ;;; Initial version 9/10/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net> ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package :db-bdb) (declaim (inline %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-delete-kv db-delete-kv-buffered %db-cursor db-cursor %db-cursor-close db-cursor-close %db-cursor-duplicate db-cursor-duplicate %db-cursor-get-key-buffered db-cursor-move-buffered db-cursor-set-buffered db-cursor-get-both-buffered %db-cursor-pget-key-buffered db-cursor-pmove-buffered db-cursor-pset-buffered db-cursor-pget-both-buffered %db-cursor-put-buffered db-cursor-put-buffered %db-cursor-delete db-cursor-delete %db-txn-begin db-transaction-begin %db-txn-abort db-transaction-abort %db-txn-commit db-transaction-commit %db-transaction-id %db-sequence-get db-sequence-get %db-sequence-get-lower db-sequence-get-fixnum )) ;; ;; EXTERNAL LIBRARY DEPENDENCIES - LOAD DURING LOAD/COMPILATION ;; (eval-when (:compile-toplevel :load-toplevel) (def-function ("db_strerr" %db-strerror) ((error :int)) :returning :cstring) (defun db-strerror (errno) "Get the string error associated with an error number." (convert-from-cstring (%db-strerror errno))) (define-condition db-error (error) ((errno :type fixnum :initarg :errno :reader db-error-errno)) (:report (lambda (condition stream) (declare (type db-error condition) (type stream stream)) (format stream "Berkeley DB error: ~A" (db-strerror (db-error-errno condition))))) (:documentation "Berkeley DB errors.")) ) ;; ;; 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-RECNO 3) (defconstant DB-QUEUE 4) (defconstant DB-UNKNOWN 5) (defconstant DB_CREATE #x00000001) (defconstant DB_LOCK_NOWAIT #x00000002) (defconstant DB_FORCE #x00000004) (defconstant DB_NOMMAP #x00000008) (defconstant DB_RDONLY #x00000010) (defconstant DB_RECOVER #x00000020) (defconstant DB_THREAD #x00000040) (defconstant DB_TRUNCATE #x00000080) (defconstant DB_TXN_NOSYNC #x00000100) (defconstant DB_EXCL #x00002000) (defconstant DB_TXN_NOWAIT #x00002000) (defconstant DB_TXN_SYNC #x00004000) (defconstant DB_DUP #x00004000) (defconstant DB_DUPSORT #x00008000) (defconstant DB_JOINENV #x00000000) (defconstant DB_INIT_CDB #x00002000) (defconstant DB_INIT_LOCK #x00004000) (defconstant DB_INIT_LOG #x00008000) (defconstant DB_INIT_MPOOL #x00010000) (defconstant DB_INIT_REP #x00020000) (defconstant DB_INIT_TXN #x00040000) (defconstant DB_LOCKDOWN #x00080000) (defconstant DB_PRIVATE #x00100000) (defconstant DB_RECOVER_FATAL #x00200000) (defconstant DB_SYSTEM_MEM #x00800000) (defconstant DB_AUTO_COMMIT #x01000000) (defconstant DB_READ_COMMITTED #x02000000) (defconstant DB_DEGREE_2 #x02000000) ;; DEPRECATED, now called DB_READ_COMMITTED (defconstant DB_READ_UNCOMMITTED #x04000000) (defconstant DB_DIRTY_READ #x04000000) ;; DEPRECATED, now called DB_READ_UNCOMMITTED (defconstant DB_CURRENT 7) (defconstant DB_FIRST 9) (defconstant DB_GET_BOTH 10) (defconstant DB_GET_BOTH_RANGE 12) (defconstant DB_LAST 17) (defconstant DB_NEXT 18) (defconstant DB_NEXT_DUP 19) (defconstant DB_NEXT_NODUP 20) (defconstant DB_PREV 25) (defconstant DB_PREV_NODUP 26) (defconstant DB_SET 28) (defconstant DB_SET_RANGE 30) (defconstant DB_AFTER 1) (defconstant DB_BEFORE 3) (defconstant DB_KEYFIRST 15) (defconstant DB_KEYLAST 16) (defconstant DB_NODUPDATA 21) (defconstant DB_NOOVERWRITE 22) (defconstant DB_NOSYNC 23) (defconstant DB_POSITION 24) (defconstant DB_SEQ_DEC #x00000001) (defconstant DB_SEQ_INC #x00000002) (defconstant DB_SEQ_WRAP #x00000008) (defconstant DB_SET_LOCK_TIMEOUT 29) (defconstant DB_SET_TXN_TIMEOUT 33) (defconstant DB_FREELIST_ONLY #x00002000) (defconstant DB_FREE_SPACE #x00004000) (defconstant DB_KEYEMPTY -30997) (defconstant DB_KEYEXIST -30996) (defconstant DB_LOCK_DEADLOCK -30995) (defconstant DB_LOCK_NOTGRANTED -30994) (defconstant DB_NOTFOUND -30989) (defconstant DB_LOCK_DEFAULT 1) (defconstant DB_LOCK_EXPIRE 2) (defconstant DB_LOCK_MAXLOCKS 3) (defconstant DB_LOCK_MAXWRITE 4) (defconstant DB_LOCK_MINLOCKS 5) (defconstant DB_LOCK_MINWRITE 6) (defconstant DB_LOCK_OLDEST 7) (defconstant DB_LOCK_RANDOM 8) (defconstant DB_LOCK_YOUNGEST 9) (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)) #+openmcl (ccl:def-foreign-type DB-LOCK (:struct DB-LOCK)) (def-struct DB-LOCKREQ (op DB-LOCKOP) (mode DB-LOCKMODE) (timeout :unsigned-int) (obj (:array :char)) (lock (* DB-LOCK))) #+openmcl (ccl:def-foreign-type DB-LOCKREQ (:struct DB-LOCKREQ)) (defconstant +2^32+ 4294967296) (defconstant +2^64+ 18446744073709551616) (defconstant +2^32-1+ (1- +2^32+)) (defmacro make-64-bit-integer (high32 low32) `(+ ,low32 (ash ,high32 32))) (defmacro high32 (int64) `(ash ,int64 -32)) (defmacro low32 (int64) `(logand ,int64 +2^32-1+)) (defmacro split-64-bit-integer (int64) `(values (ash ,int64 -32) (logand ,int64 +2^32-1+))) ;; Wrapper macro -- handles errno return values ;; makes flags into keywords ;; makes keyword args, cstring wrappers (defvar *errno-buffer* (allocate-foreign-object :int 1)) (eval-when (:compile-toplevel) (defun make-wrapper-args (args flags keys) (if (or flags keys) (append (remove-keys (remove 'flags args) keys) `(&key ,@flags ,@keys)) (remove 'flags args))) (defun remove-keys (args keys) (if keys (loop for key in keys for kw = (if (atom key) key (first key)) for wrapper-args = (remove kw args) then (remove kw wrapper-args) finally (return wrapper-args)) args)) (defun make-fun-args (args flags) (if flags (substitute (cons 'flags (symbols-to-kw-pairs flags)) 'flags args) (substitute 0 'flags args))) (defun make-out-args (count) (loop for i from 1 to count collect (gensym))) (defun symbols-to-kw-pairs (symbols) (loop for symbol in symbols append (list (intern (symbol-name symbol) "KEYWORD") symbol))) (defun symbols-to-pairs (symbols) (loop for symbol in symbols collect (list symbol symbol))) ) (defmacro wrap-errno (names args &key (keys nil) (flags nil) (cstrings nil) (outs 1) (declarations nil) (documentation nil) (transaction nil)) (let ((wname (if (listp names) (first names) names)) (fname (if (listp names) (second names) (intern (concatenate 'string "%" (symbol-name names))))) (wrapper-args (make-wrapper-args args flags keys)) (fun-args (make-fun-args args flags)) (errno (gensym))) (if (> outs 1) (let ((out-args (make-out-args outs))) `(defun ,wname ,wrapper-args ,@(if documentation (list documentation) (values)) ,@(if declarations (list declarations) (values)) (with-cstrings ,(symbols-to-pairs cstrings) (multiple-value-bind ,out-args (,fname ,@fun-args) (let ((,errno ,(first out-args))) (declare (type fixnum ,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 documentation (list documentation) (values)) ,@(if declarations (list declarations) (values)) (with-cstrings ,(symbols-to-pairs cstrings) (let ((,errno (,fname ,@fun-args))) (declare (type fixnum ,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))))))))) (defmacro flags (&key auto-commit joinenv init-cdb init-lock init-log init-mpool init-rep init-txn recover recover-fatal lockdown private system-mem thread force create excl nommap degree-2 read-committed dirty-read read-uncommitted rdonly truncate txn-nosync txn-nowait txn-sync lock-nowait dup dup-sort current first get-both get-both-range last next next-dup next-nodup prev prev-nodup set set-range after before keyfirst keylast freelist-only free-space no-dup-data no-overwrite nosync position seq-dec seq-inc seq-wrap set-lock-timeout set-transaction-timeout) (let ((flags (gensym))) `(let ((,flags 0)) (declare (type fixnum ,flags)) ,@(when auto-commit `((when ,auto-commit (setq ,flags (logior ,flags DB_AUTO_COMMIT))))) ,@(when joinenv `((when ,joinenv (setq ,flags (logior ,flags DB_JOINENV))))) ,@(when init-cdb `((when ,init-cdb (setq ,flags (logior ,flags DB_INIT_CDB))))) ,@(when init-lock `((when ,init-lock (setq ,flags (logior ,flags DB_INIT_LOCK))))) ,@(when init-log `((when ,init-log (setq ,flags (logior ,flags DB_INIT_LOG))))) ,@(when init-mpool `((when ,init-mpool (setq ,flags (logior ,flags DB_INIT_MPOOL))))) ,@(when init-rep `((when ,init-rep (setq ,flags (logior ,flags DB_INIT_REP))))) ,@(when init-txn `((when ,init-txn (setq ,flags (logior ,flags DB_INIT_TXN))))) ,@(when recover `((when ,recover (setq ,flags (logior ,flags DB_RECOVER))))) ,@(when recover-fatal `((when ,recover-fatal (setq ,flags (logior ,flags DB_RECOVER_FATAL))))) ,@(when lockdown `((when ,lockdown (setq ,flags (logior ,flags DB_LOCKDOWN))))) ,@(when private `((when ,private (setq ,flags (logior ,flags DB_PRIVATE))))) ,@(when system-mem `((when ,system-mem (setq ,flags (logior ,flags DB_SYSTEM_MEM))))) ,@(when thread `((when ,thread (setq ,flags (logior ,flags DB_THREAD))))) ,@(when force `((when ,force (setq ,flags (logior ,flags DB_FORCE))))) ,@(when degree-2 `((when ,degree-2 (setq ,flags (logior ,flags DB_DEGREE_2))))) ,@(when read-committed `((when ,read-committed (setq ,flags (logior ,flags DB_READ_COMMITTED))))) ,@(when dirty-read `((when ,dirty-read (setq ,flags (logior ,flags DB_DIRTY_READ))))) ,@(when read-uncommitted `((when ,read-uncommitted (setq ,flags (logior ,flags DB_READ_UNCOMMITTED))))) ,@(when create `((when ,create (setq ,flags (logior ,flags DB_CREATE))))) ,@(when excl `((when ,excl (setq ,flags (logior ,flags DB_EXCL))))) ,@(when nommap `((when ,nommap (setq ,flags (logior ,flags DB_NOMMAP))))) ,@(when rdonly `((when ,rdonly (setq ,flags (logior ,flags DB_RDONLY))))) ,@(when truncate `((when ,truncate (setq ,flags (logior ,flags DB_TRUNCATE))))) ,@(when txn-nosync `((when ,txn-nosync (setq ,flags (logior ,flags DB_TXN_NOSYNC))))) ,@(when txn-nowait `((when ,txn-nowait (setq ,flags (logior ,flags DB_TXN_NOWAIT))))) ,@(when txn-sync `((when ,txn-sync (setq ,flags (logior ,flags DB_TXN_SYNC))))) ,@(when freelist-only `((when ,freelist-only (setq ,flags (logior ,flags DB_FREELIST_ONLY))))) ,@(when free-space `((when ,free-space (setq ,flags (logior ,flags DB_FREE_SPACE))))) ,@(when lock-nowait `((when ,lock-nowait (setq ,flags (logior ,flags DB_LOCK_NOWAIT))))) ,@(when dup `((when ,dup (setq ,flags (logior ,flags DB_DUP))))) ,@(when dup-sort `((when ,dup-sort (setq ,flags (logior ,flags DB_DUPSORT))))) ,@(when current `((when ,current (setq ,flags (logior ,flags DB_CURRENT))))) ,@(when first `((when ,first (setq ,flags (logior ,flags DB_FIRST))))) ,@(when get-both `((when ,get-both (setq ,flags (logior ,flags DB_GET_BOTH))))) ,@(when get-both-range `((when ,get-both-range (setq ,flags (logior ,flags DB_GET_BOTH_RANGE))))) ,@(when last `((when ,last (setq ,flags (logior ,flags DB_LAST))))) ,@(when next `((when ,next (setq ,flags (logior ,flags DB_NEXT))))) ,@(when next-dup `((when ,next-dup (setq ,flags (logior ,flags DB_NEXT_DUP))))) ,@(when next-nodup `((when ,next-nodup (setq ,flags (logior ,flags DB_NEXT_NODUP))))) ,@(when prev `((when ,prev (setq ,flags (logior ,flags DB_PREV))))) ,@(when prev-nodup `((when ,prev-nodup (setq ,flags (logior ,flags DB_PREV_NODUP))))) ,@(when set `((when ,set (setq ,flags (logior ,flags DB_SET))))) ,@(when set-range `((when ,set-range (setq ,flags (logior ,flags DB_SET_RANGE))))) ,@(when after `((when ,after (setq ,flags (logior ,flags DB_AFTER))))) ,@(when before `((when ,before (setq ,flags (logior ,flags DB_BEFORE))))) ,@(when keyfirst `((when ,keyfirst (setq ,flags (logior ,flags DB_KEYFIRST))))) ,@(when keylast `((when ,keylast (setq ,flags (logior ,flags DB_KEYLAST))))) ,@(when no-dup-data `((when ,no-dup-data (setq ,flags (logior ,flags DB_NODUPDATA))))) ,@(when no-overwrite `((when ,no-overwrite (setq ,flags (logior ,flags DB_NOOVERWRITE))))) ,@(when nosync `((when ,nosync (setq ,flags (logior ,flags DB_NOSYNC))))) ,@(when position `((when ,position (setq ,flags (logior ,flags DB_POSITION))))) ,@(when seq-dec `((when ,seq-dec (setq ,flags (logior ,flags DB_SEQ_DEC))))) ,@(when seq-inc `((when ,seq-inc (setq ,flags (logior ,flags DB_SEQ_INC))))) ,@(when seq-wrap `((when ,seq-wrap (setq ,flags (logior ,flags DB_SEQ_WRAP))))) ,@(when set-lock-timeout `((when ,set-lock-timeout (setq ,flags (logior ,flags DB_SET_LOCK_TIMEOUT))))) ,@(when set-transaction-timeout `((when ,set-transaction-timeout (setq ,flags (logior ,flags DB_SET_TXN_TIMEOUT))))) ,flags))) ;; Environment (def-function ("db_env_cr" %db-env-create) ((flags :unsigned-int) (errno :int :out)) :returning :pointer-void) (defun db-env-create () "Create an environment handle." (multiple-value-bind (env errno) (%db-env-create 0) (declare (type fixnum errno)) (if (= errno 0) env (error 'db-error :errno errno)))) (def-function ("db_env_close" %db-env-close) ((dbenvp :pointer-void) (flags :unsigned-int)) :returning :int) (wrap-errno db-env-close (dbenvp flags) :documentation "Close an environment handle.") (def-function ("db_env_open" %db-env-open) ((dbenvp :pointer-void) (home :cstring) (flags :unsigned-int) (mode :int)) :returning :int) (wrap-errno db-env-open (dbenvp home flags mode) :flags (init-cdb init-lock init-log [1502 lines skipped]

1 0