[elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp
ieslick
ieslick at common-lisp.net
Wed Feb 14 04:36:09 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp
In directory clnet:/tmp/cvs-serv32730/src/contrib/eslick/db-lisp
Modified Files:
TODO btree.lisp file.lisp pages.lisp
Log Message:
Documentation, optimizations, deadlock process, etc
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/12 20:36:44 1.3
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/14 04:36:09 1.4
@@ -1,8 +1,8 @@
Active TODO:
- secondary indices
-- lisp-based comparison function for serialized streams
- variable size keys and values
+- lisp-based comparison function for serialized streams
- transaction logging and transactions
- page-level locks
(transactions are used to mark page-level rd/wr locks)
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/12 20:36:44 1.4
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/14 04:36:09 1.5
@@ -38,9 +38,9 @@
(#xFE . :root-as-leaf)
(#xFF . :root)))
-(defun get-type (byte)
- (assert (<= byte (car (last *type-table*))))
- (cdr (assoc byte *type-table*)))
+(defun get-type (id)
+ (assert (<= id (caar (last *type-table*))))
+ (cdr (assoc id *type-table*)))
(defun get-type-id (type-symbol)
(loop for (id . symbol) in *type-table* do
@@ -88,24 +88,24 @@
(def-field +free-list-next+ (1 4 0))
+(defconstant +root-key-start+ 23)
(def-field +root-version+ (1 1 *db-version*))
(def-field +root-reserved+ (2 8 #xDEADBEEFDEADBEEF))
(def-field +root-alloc-pointer+ (10 4 0))
(def-field +root-free-pointer+ (14 4 0))
-(def-field +root-last-valid-byte+ (18 3 0))
+(def-field +root-last-valid-byte+ (18 3 +root-key-start+))
(def-field +root-num-keys+ (21 2 0))
-(defconstant +root-key-start+ 23)
+(defconstant +index-key-start+ 14)
(def-field +index-reserved+ (1 8 0))
-(def-field +index-last-valid-byte+ (9 3 0))
+(def-field +index-last-valid-byte+ (9 3 +index-key-start+))
(def-field +index-num-keys+ (12 2 0))
-(defconstant +index-key-start+ 14)
+(defconstant +leaf-key-start+ 14)
(def-field +leaf-prev+ (1 4 0))
(def-field +leaf-next+ (5 4 0))
-(def-field +leaf-last-valid-byte+ (9 3 0))
+(def-field +leaf-last-valid-byte+ (9 3 +leaf-key-start+))
(def-field +leaf-num-keys+ (12 2 0))
-(defconstant +leaf-key-start+ 14)
(defun leaf-p (page)
(or (eq (page-type page) :leaf)
@@ -119,7 +119,9 @@
(write-page-type page (setf (page-type page) :root-as-leaf))
(write-field-default +root-version+ page)
(write-field-default +root-reserved+ page)
+ (write-field-default +root-alloc-pointer+ page)
(write-field-default +root-free-pointer+ page)
+ (write-field-default +root-last-valid-byte+ page)
(write-field-default +root-num-keys+ page))
(defun initialize-index-page (page)
@@ -143,36 +145,36 @@
(defparameter *max-key-size* 255)
(defparameter *max-value-size* 255)
-(defun read-pointer (page offset)
+(defmethod read-pointer ((page buffer-page) offset)
(read-integer page offset 4))
-(defun write-pointer (page offset pointer)
+(defmethod write-pointer ((page buffer-page) offset pointer)
(write-integer pointer page offset 4))
-(defmethod extract-key (page offset bs)
+(defmethod extract-key ((page buffer-page) offset bs)
(let ((klen (read-integer page offset 4)))
(values (when (> klen 0) (read-buffer-stream page bs (+ offset 4) klen))
(read-pointer page (+ offset klen 4))
- (+ offset klen 8))))
+ (+ klen 8))))
-(defmethod write-key (page offset bs pointer)
+(defmethod write-key ((page buffer-page) offset (bs buffer-stream) pointer)
(let ((klen (buffer-stream-size bs)))
(assert (< klen *max-key-size*))
- (write-integer page offset klen 4)
+ (write-integer klen page offset)
(write-buffer-stream page bs (+ offset 4))
(write-pointer page (+ offset (buffer-stream-size bs) 4) pointer)))
-(defmethod extract-value (page offset bs)
+(defmethod extract-value ((page buffer-page) offset (bs buffer-stream))
(let ((vlen (read-integer page offset)))
(values (when (> vlen 0) (read-buffer-stream page bs (+ offset 4) vlen)) vlen)))
-(defmethod write-value (page offset bs)
+(defmethod write-value ((page buffer-page) offset bs)
(let ((vlen (buffer-stream-size bs)))
(assert (< vlen *max-value-size*))
- (write-integer page offset vlen 4)
- (write-buffer-stream page bs offset)))
+ (write-integer vlen page offset 4)
+ (write-buffer-stream page bs (+ offset 4))))
-(defmethod skip-value (page offset)
+(defmethod skip-value ((page buffer-page) offset)
"Returns the offset after the value is consumed"
(let ((vlen (read-integer page offset)))
(+ offset vlen)))
@@ -181,17 +183,42 @@
"Get the last valid page irrespective of page type"
(case (page-type page)
(:root (read-field +root-last-valid-byte+ page))
+ (:root-as-leaf (read-field +root-last-valid-byte+ page))
(:index (read-field +index-last-valid-byte+ page))
(:leaf (read-field +leaf-last-valid-byte+ page))))
-(defun set-last-valid-byte (value page)
+(defun set-last-valid-byte (page value)
(case (page-type page)
(:root (write-field +root-last-valid-byte+ page value))
+ (:root-as-leaf (write-field +root-last-valid-byte+ page value))
(:index (write-field +index-last-valid-byte+ page value))
(:leaf (write-field +leaf-last-valid-byte+ page value))))
(defsetf last-valid-byte set-last-valid-byte)
+(defun first-key-offset (page)
+ (case (page-type page)
+ (:root +root-key-start+)
+ (:root-as-leaf +root-key-start+)
+ (:index +index-key-start+)
+ (:leaf +leaf-key-start+)))
+
+(defmethod num-keys ((page buffer-page))
+ (case (page-type page)
+ (:root (read-field +root-num-keys+ page))
+ (:root-as-leaf (read-field +root-num-keys+ page))
+ (:index (read-field +index-num-keys+ page))
+ (:leaf (read-field +leaf-num-keys+ page))))
+
+(defmethod set-num-keys ((page buffer-page) value)
+ (case (page-type page)
+ (:root (write-field +root-num-keys+ page value))
+ (:root-as-leaf (write-field +root-num-keys+ page value))
+ (:index (write-field +index-num-keys+ page value))
+ (:leaf (write-field +leaf-num-keys+ page value))))
+
+(defsetf num-keys set-num-keys)
+
;;
;; Comparison functions
;;
@@ -222,7 +249,7 @@
;; BTREE Class and useful accessors
;;
-(defclass btree ()
+(defclass lisp-btree ()
((pool :accessor btree-buffer-pool :initarg :pool
:documentation "Maintain a pool of memory pages")
(primary-bfile :accessor btree-primary-file :initarg :bfile
@@ -231,42 +258,43 @@
:documentation "The in-memory root of main BTree DB")
(compare-fn :accessor btree-compare-fn :initarg :compare-fn)))
-(defmethod btree-stream ((bt btree))
- (binary-file-stream (btree-file bt)))
+(defmethod btree-stream ((bt lisp-btree))
+ (binary-file-stream (btree-primary-file bt)))
-(defmethod btree-get-page ((bt btree) position)
+(defmethod btree-get-page ((bt lisp-btree) position)
(get-page (btree-buffer-pool bt) (btree-stream bt) position))
-(defmethod btree-allocation-pointer ((bt btree))
+(defmethod btree-allocation-pointer ((bt lisp-btree))
(read-field +root-alloc-pointer+ (btree-root bt)))
-(defmethod write-btree-allocation-pointer (value (bt btree))
+(defmethod write-btree-allocation-pointer (value (bt lisp-btree))
(write-field +root-alloc-pointer+ (btree-root bt) value))
(defsetf btree-allocation-pointer write-btree-allocation-pointer)
-(defmethod btree-free-pointer ((bt btree))
+(defmethod btree-free-pointer ((bt lisp-btree))
(read-field +root-free-pointer+ (btree-root bt)))
-(defmethod write-btree-free-pointer (value (bt btree))
+(defmethod write-btree-free-pointer (value (bt lisp-btree))
(write-field +root-alloc-pointer+ (btree-root bt) value))
(defsetf btree-free-pointer write-btree-free-pointer)
+
;;
;; Manipulating backing store
;;
;; Physical operations (not init, no flush)
-(defmethod pop-free-db-page ((bt btree))
+(defmethod pop-free-db-page ((bt lisp-btree))
"Take a page off the free list"
(let* ((pop-page (btree-get-page bt (btree-free-pointer bt)))
(new-top-page (btree-get-page bt (read-field +free-list-next+ pop-page))))
(setf (btree-free-pointer bt) (page-position new-top-page))
pop-page))
-(defmethod push-free-db-page ((bt btree) free-page)
+(defmethod push-free-db-page ((bt lisp-btree) free-page)
"Pushes an initialized (tagged) free page on the free list"
(let ((new-top (page-position free-page))
(old-top-page (btree-get-page bt (btree-free-pointer bt))))
@@ -274,14 +302,14 @@
(setf (btree-free-pointer bt) new-top)
free-page))
-(defmethod new-db-page ((bt btree))
+(defmethod new-db-page ((bt lisp-btree))
"Append a new page to the disk file"
(let ((new-page-position (btree-allocation-pointer bt)))
(incf (btree-allocation-pointer bt)
(page-size (btree-root bt)))
new-page-position))
-(defmethod get-free-db-page ((bt btree))
+(defmethod get-free-db-page ((bt lisp-btree))
"Get a fresh page from free list or by allocation"
(if (> (btree-free-pointer bt) 0)
(pop-free-db-page bt)
@@ -303,17 +331,17 @@
;; Logical operations
-(defmethod free-page ((bt btree) page)
+(defmethod free-page ((bt lisp-btree) page)
"Free a page so it goes on the free list"
(initialize-free-page page)
(push-free-db-page bt page))
-(defmethod allocate-index-page ((bt btree))
+(defmethod allocate-index-page ((bt lisp-btree))
(let ((idx-page (get-free-db-page bt)))
(initialize-index-page idx-page)
idx-page))
-(defmethod allocate-leaf-page ((bt btree))
+(defmethod allocate-leaf-page ((bt lisp-btree))
(let ((leaf-page (get-free-db-page bt)))
(initialize-leaf-page leaf-page)
leaf-page))
@@ -350,6 +378,7 @@
(copy-region page start region-size offset)
(write-key page start key-bs pointer)
(setf (last-valid-byte page) (+ offset last-byte))
+ (incf (num-keys page))
page))
(defun insert-key-and-value (page start key-bs pointer value-bs)
@@ -364,6 +393,7 @@
(write-key page start key-bs pointer)
(write-value page (+ start 8) value-bs)
(setf (last-valid-byte page) (+ offset last-byte))
+ (incf (num-keys page))
page))
(defun delete-key (page start)
@@ -374,6 +404,7 @@
(offset (- (+ key-size 8))))
(copy-region page begin region-size offset)
(setf (last-valid-byte page) (+ offset last-byte))
+ (decf (num-keys page))
page))
(defun delete-key-and-value (page start)
@@ -386,6 +417,7 @@
(offset (- delete-size)))
(copy-region page begin region-size offset)
(setf (last-valid-byte page) (+ offset last-byte))
+ (decf (num-keys page))
page))
(defun replace-value (page vstart new-value)
@@ -399,25 +431,12 @@
(copy-region page region-start region-length offset))
(write-value page vstart new-value)))
-
-(defun first-key-offset (page)
- (case (page-type page)
- (:root +root-key-start+)
- (:index +index-key-start+)
- (:leaf +leaf-key-start+)))
-
-(defun num-keys (page)
- (case (page-type page)
- (:root (read-field +root-num-keys+ page))
- (:index (read-field +index-num-keys+ page))
- (:leaf (read-field +leaf-num-keys+ page))))
-
(defmacro scan-page-keys ((key-bs pointer position btree page) &body body)
"Walks a page one key at a time returning the associated pointer and
position after consuming the pointer. For leaf pages, this places it
at the beginning of the value field. The body is not evaluated
if there are zero keys."
- (declare (ignorable btree))
+ (declare (ignorable lisp-btree))
(assert (and (atom key-bs) (atom pointer) (atom position)))
(let ((i (gensym))
(dbkey (gensym))
@@ -439,13 +458,20 @@
;; Top-level initialization
;;
-(defun open-btree-file (path &key
+(defun open-lisp-btree (path &key
(page-size *btree-page-size*)
(cache-pages *btree-cache-size*)
bpool
- (compare-name 'lexical-compare-<))
- (let* ((new-p (probe-file path :follow-symlinks t))
- (bfile (open-binary-file path :if-does-not-exist :create))
+ (compare-name 'lexical-compare-<)
+ (if-does-not-exist :create)
+ (if-exists :new-version))
+ (let* ((new-p (or
+ (eq if-exists :overwrite)
+ (not (probe-file path :follow-symlinks t))))
+ (bfile (make-instance 'binary-file
+ :path path
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist))
(bpool (if bpool bpool
(make-instance 'buffer-pool
:pages cache-pages
@@ -453,20 +479,20 @@
(root (make-instance 'buffer-page
:type :root
:page-size page-size))
- (btree (make-instance 'btree
- :file bfile
+ (btree (make-instance 'lisp-btree
+ :root root
:pool bpool
- :root-page root
+ :bfile bfile
:compare-fn compare-name)))
(associate-page root (binary-file-stream bfile) 0)
(if new-p
(initialize-root-page root)
(load-page root))
- (assert (root-page-p root))
+ (assert (root-p root))
btree))
-(defun close-btree-file (btree)
- (close-binary-file (btree-file btree))
+(defun close-lisp-btree (btree)
+ (close-file (btree-primary-file btree))
(setf (btree-buffer-pool btree) nil)
(setf (btree-root btree) nil))
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/12 20:36:44 1.3
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/14 04:36:09 1.4
@@ -20,12 +20,13 @@
((path :initarg :path :initarg "" :accessor binary-file-path)
(stream :initarg :stream :accessor binary-file-stream)))
-(defmethod initialize-instance :after ((file binary-file) &key (if-does-not-exist :create))
+(defmethod initialize-instance :after ((file binary-file) &key (if-does-not-exist :create) (if-exists :new-version))
(assert (binary-file-path file))
(setf (binary-file-stream file)
(open (binary-file-path file)
:direction :io :element-type '(unsigned-byte 8)
- :if-exists :overwrite :if-does-not-exist if-does-not-exist)))
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)))
(defmethod close-file ((bf binary-file))
(close (binary-file-stream bf)))
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/12 20:36:44 1.3
+++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/14 04:36:09 1.4
@@ -28,13 +28,16 @@
(declare (type fixnum offset bytes)
(type integer integer)
(type (array (unsigned-byte 8)) array))
+ (assert (< offset (length array)))
(loop for i fixnum from 0 below bytes do
(setf (aref array (+ offset i))
- (ldb (byte 8 (* i 8)) integer))))
+ (ldb (byte 8 (* i 8)) integer)))
+ integer)
(defun read-integer-from-array (array offset &optional (bytes 4))
(declare (type fixnum offset bytes)
(type (array (unsigned-byte 8)) array))
+ (assert (< offset (length array)))
(let ((value 0))
(loop for i fixnum from 0 below bytes do
(setf value (dpb (aref array (+ i offset)) (byte 8 (* i 8)) value)))
More information about the Elephant-cvs
mailing list