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

[elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp
by ieslick 08 Feb '07

08 Feb '07

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv2282/contrib/eslick/db-lisp Modified Files: btree.lisp package.lisp pages.lisp Log Message: Removing vestigial directory --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/08 15:57:19 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/08 23:05:46 1.3 @@ -7,7 +7,8 @@ '((0 . :unknown) (1 . :index) (2 . :leaf) - (3 . :blob))) + (3 . :overflow) + (#xFF . :root))) (defun get-type (byte) (assert (<= byte (car (last *type-table*)))) @@ -41,9 +42,27 @@ ;; Indexes: ;; +type = root +endian-tag = 0xDAF00F00 (32-bit) +db_version = 0-6-1 (48 bit) +free-data-block = page-ptr (32-bits) +num-keys - int32 + +type = index +num-keys - int32 +serialized-key - buffer-stream +page-pointer (int32-page) +serialized-key - buffer-stream +page-pointer (int32-page) +... +type - leaf +num-elts - ;; User Operations: +;; btree-open +(defun open-btree-file (path &key page-size (create t)) + ;; btree-create ;; btree-search --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/08 15:57:19 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/08 23:05:46 1.3 @@ -3,9 +3,3 @@ (defpackage :db-lisp (:use :cl :elephant :elephant-backend :elephant-memutil)) -;; file - open/close binary files -;; octet-stream - read/write binary buffers -;; binary-fields - macro package for reading/writing lisp arrays -;; pages - binary pages read/written to and from stream; simple metadata -;; includes a simple LRU page-caching scheme using linked-lists -;; btree - btrees implemented on top of pages --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 15:57:19 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 23:05:46 1.2 @@ -1,6 +1,31 @@ (in-package :db-lisp) ;; +;; Utilities +;; + +(defun copy-slots (obj1 obj2 slotnames) + (loop for slotname in slotnames do + (setf (slot-value obj2 slotname) (slot-value obj1 slotname)))) + +(defun write-integer-to-array (integer array offset &optional (bytes 4)) + (declare (type fixnum offset bytes) + (type integer integer) + (type (array (unsigned-byte 8)) array)) + (loop for i fixnum from 0 below bytes do + (setf (aref array (+ offset i)) + (ldb (byte 8 (* i 8)) integer)))) + +(defun read-integer-from-array (array offset &optional (bytes 4)) + (declare (type fixnum offset bytes) + (type (array (unsigned-byte 8)) 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))) + value)) + + +;; ;; Mixins ;; @@ -53,14 +78,15 @@ ;; Primitive read-write of buffer-pages ;; -;; ;; Read/Write fixnums -;; -(defun write-fixnum (page offset fix &optional (bytes 4)) - (loop for i from 0 below bytes do - (setf (aref (page-buffer page) (+ offset i)) - (ldb (byte 8 (* i 8)) fix)))) +(defmethod write-integer (fixnum page offset &optional (bytes 4)) + (declare (type fixnum fixnum offset bytes)) + (write-fixnum-to-array fixnum (page-buffer page) offset bytes)) + +(defmethod read-integer (page offset &optional (bytes 4)) + (declare (type fixnum offset bytes)) + (read-integer-from-array (page-buffer page) offset bytes)) ;; NOTE: Redo memutil/serializer primitives here? @@ -182,9 +208,11 @@ (defmethod cache-page ((pool buffer-pool) page) (push page (gethash (page-position page) (pool-hash pool)))) +;; ------------------------------------------------------------------------ ;; ;; User cache operations ;; +;; ------------------------------------------------------------------------ (defmethod get-page ((pool buffer-pool) stream position) (touch-page

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 08 Feb '07

08 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv2282/db-bdb Modified Files: bdb-collections.lisp Log Message: Removing vestigial directory --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/04 10:08:27 1.16 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/08 23:05:46 1.17 @@ -306,17 +306,17 @@ (defmethod cursor-first ((cursor bdb-cursor)) (let ((sc (get-con (cursor-btree cursor)))) - (with-buffer-streams (key-buf value-buf) - (buffer-write-oid (cursor-oid cursor) key-buf) - (multiple-value-bind (key val) - (db-cursor-set-buffered (cursor-handle cursor) - key-buf value-buf :set-range t) - (if (and key (= (buffer-read-oid 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)))))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) + (multiple-value-bind (key val) + (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (if (and key (= (buffer-read-oid 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-last ((cursor bdb-cursor)) "A fast cursor last, but a bit 'hackish' by exploiting oid ordering"

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by rread 08 Feb '07

08 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv26423/src/db-clsql Modified Files: sql-collections.lisp sql-controller.lisp Log Message: More robust upgrade mechanism, one bug fix, better user of PK --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/02 23:51:58 1.9 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/08 22:33:35 1.10 @@ -526,7 +526,7 @@ (let ((cur-pk (get-current-key cursor))) (decf (:sql-crsr-ck cursor)) (if (equal cur-pk (get-current-key cursor)) - (decf (:dp-nmbr cursor)) + (setf (:dp-nmbr cursor) (max 0 (- (:dp-nmbr cursor) 1))) (setf (:dp-nmbr cursor) (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) @@ -593,12 +593,13 @@ (setf (:sql-crsr-ck cursor) (- (length (:sql-crsr-ks cursor)) 1)) (setf (:dp-nmbr cursor) + (max 0 (- (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) (get-con (cursor-btree cursor)) ) - 1)) + 1))) (assert (>= (:dp-nmbr cursor) 0)) (setf (cursor-initialized-p cursor) t) (has-key-value-scnd cursor :returnpk returnpk) @@ -615,10 +616,11 @@ (progn (setf (:sql-crsr-ck cursor) (- (:sql-crsr-ck cursor) (+ 1 (:dp-nmbr cursor)))) (setf (:dp-nmbr cursor) + (max 0 (- (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) (get-con (cursor-btree cursor)) -) 1)) + ) 1))) (has-key-value-scnd cursor :returnpk returnpk)) (cursor-last-x cursor :returnpk returnpk))) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/07 22:54:12 1.17 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/08 22:33:35 1.18 @@ -34,13 +34,13 @@ ( ;; (db :accessor controller-db :initarg :db :initform nil) (dbcons :accessor controller-db-table :initarg :db :initform nil) + (uses-pk :accessor uses-pk-of :initarg :uses-pk) ) (: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. This is the Postgresql-specific subclass of store-controller.")) - ;; This should be much more elegant --- but as of Feb. 6, SBCL 1.0.2 has a weird, ;; unpleasant bug when ASDF tries to load this stuff. ;; (defvar *thread-table-lock* nil) @@ -300,6 +300,20 @@ (clsql:table-exists-p [keyvalue] :database con :owner :all) ) +;; Our goal here is to see if the "pk" column exists.... +;; if it does, we can use a certain optimization the sql-get-from-clcn-nth. +;; Post 6.1 versions should have it, but 6.0 versions won't. +;; My goal here is to be as robust as possible; there is no portable way +;; to add a column nicely. If you want to upgrade (which will really only +;; help if you use duplicate keys), then do a migration from your old repository +;; to a new repository. +(defun query-uses-pk (con) + ;; we want to use ":owner :all" because we don't really care who created + ;; the table, as long as we have the rights we need! + (member "pk" (clsql:list-attributes [keyvalue] :database con :owner :all) + :test 'equal) + ) + ;; This is just an initial version; it is possible that ;; we might someday wish to use blobs instead; certainly, I am @@ -320,6 +334,8 @@ ;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem! ;; ALL OF THIS needs to be inside a transaction. + +;; At one time this was conditional, but all NEW repositories should have this. (clsql::create-sequence [serial] :database con) (clsql::query (format nil "create table keyvalue ( @@ -329,19 +345,17 @@ value varchar )") :database con) +;; (clsql::create-table [keyvalue] +;; ;; This is most likely to work with any database system.. +;; '( +;; ([clctn_id] integer :not-null) +;; ([key] text :not-null) +;; ([value] text) +;; ) +;; :database con) - ;; (clsql::create-table [keyvalue] - - ;; ;; This is most likely to work with any database system.. - ;; '( - ;; ([clctn_id] integer :not-null) - ;; ([key] text :not-null) - ;; ([value] text) - ;; ) - ;; :database con) - - ;; :constraints '("PRIMARY KEY (clctn_id key)" - ;; "UNIQUE (clctn_id,key)") +;; :constraints '("PRIMARY KEY (clctn_id key)" +;; "UNIQUE (clctn_id,key)") ;; apparently in postgres this is failing pretty awfully because ;; sequence-exists-p return nil and then we get an error that the sequence exists! @@ -412,8 +426,9 @@ ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it.. (unless (keyvalue-table-exists con) - (with-transaction (:store-controller sc) - (create-keyvalue-table con))) + (with-transaction (:store-controller sc) + (create-keyvalue-table con))) + (setf (uses-pk-of sc) (query-uses-pk con)) (unless (version-table-exists con) (with-transaction (:store-controller sc) (create-version-table con))) @@ -450,8 +465,6 @@ (defmethod reconnect-controller ((sc sql-store-controller)) (clsql:reconnect :database (controller-db sc) :force nil) -;; (setf (controller-db sc) -;; (clsql:reconnect :database (controller-db sc))) ) (defmethod close-controller ((sc sql-store-controller)) @@ -543,17 +556,21 @@ (let* ((con (controller-db sc)) (kbs (serialize-to-base64-string key sc)) - (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by pk offset ~A limit 1 " - clcn - kbs - n)) + (offsetquery (if (uses-pk-of sc) + (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by pk offset ~A limit 1 " + clcn + kbs + n) + nil)) (tuples - (clsql::query offsetquery :database con) -;; (clsql::select [value] -;; :from [keyvalue] -;; :where [and [= [clctn_id] clcn] [= [key] kbs]] -;; :database con -;; ) + (if (uses-pk-of sc) + (clsql::query offsetquery :database con) + (clsql::select [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con + ) + ) ) ) ;; Get the lowest value by sorting and taking the first value; @@ -565,21 +582,22 @@ ;; that efficiently without changing the database structure; ;; but that's OK, I could add a column to support that ;; relatively easily later on. - (if tuples - (values (deserialize-from-base64-string (caar tuples) sc) - t) - (values nil nil)) - -;; (if (< n (length tuples)) -;; (values (nth n (sort -;; (mapcar -;; #'(lambda (x) -;; (deserialize-from-base64-string (car x) sc)) -;; tuples) -;; #'my-generic-less-than)) -;; t) -;; (values nil nil)) -)) + (if (uses-pk-of sc) + (if tuples + (values (deserialize-from-base64-string (caar tuples) sc) + t) + (values nil nil)) + (if (< n (length tuples)) + (values (nth n (sort + (mapcar + #'(lambda (x) + (deserialize-from-base64-string (car x) sc)) + tuples) + #'my-generic-less-than)) + t) + (values nil nil)) + ) + )) (defun sql-get-from-clcn-cnt (clcn key sc) (assert (integerp clcn)) @@ -597,11 +615,20 @@ (assert (integerp clcn)) (let* ((con (controller-db sc)) (tuples - (clsql::select [pk] [key] [value] + (if (uses-pk-of sc) + (clsql::select [pk] [key] [value] :from [keyvalue] :where [and [= [clctn_id] clcn]] :database con - ))) + ) + (clsql::select [key] [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn]] + :database con + ) + ) + ) + ) (mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string q :sc sc)) x)) tuples))) @@ -678,24 +705,11 @@ (if (or (null to-remove) (my-generic-less-than (car tuple) to-remove)) (setf to-remove (car tuple)))) - ;; (nth 0 (sort - ;; (mapcar - ;; #'(lambda (x) - ;; (deserialize-from-base64-string (car x) :sc sc)) - ;; tuples) - ;; #'my-generic-less-than))))) - ;; (format t "to-remove = ~A~%" to-remove) (clsql::delete-records :from [keyvalue] :where [and [= [clctn_id] clcn] [= [key] kbs] [= [value] to-remove]] :database con ) - ;; (format t "After deletion = ~A~%" - ;; (clsql::select [value] - ;; :from [keyvalue] - ;; :where [and [= [clctn_id] clcn] [= [key] kbs]] - ;; :database con - ;; )) ) ) )

1 0

[elephant-cvs] CVS elephant/tests
by rread 08 Feb '07

08 Feb '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv26423/tests Modified Files: testindexing.lisp Log Message: More robust upgrade mechanism, one bug fix, better user of PK --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/07 22:54:13 1.25 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/08 22:33:35 1.26 @@ -204,9 +204,6 @@ (defclass idx-five-del () ((slot1 :initarg :slot1 :initform 1 :accessor slot1)) (:metaclass persistent-metaclass)) - (format t "r1 = ~A~%" r1) - (format t "r1 = ~A~%" (get-index (get-value 'idx-five-del (elephant::controller-class-root *store-controller*)) - 'slot1)) (values (eq (length r1) 1) (signals-error (get-instances-by-value 'idx-five-del 'slot1 1))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 08 Feb '07

08 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv28359 Modified Files: serializer2.lisp Log Message: Last of Henrik's changes --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/08 15:51:01 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/08 15:58:26 1.20 @@ -165,7 +165,7 @@ (%serialize (frob) (etypecase frob (fixnum - (if (< #.most-positive-fixnum +2^32+) ;; should be compiled away + (if (< #.most-positive-fixnum +2^31+) ;; should be compiled away (progn (buffer-write-byte +fixnum32+ bs) (buffer-write-int32 frob bs))

1 0

[elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp
by ieslick 08 Feb '07

08 Feb '07

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv28034 Modified Files: TODO btree.lisp file.lisp octet-stream.lisp package.lisp Added Files: pages.lisp Removed Files: buffers.lisp Log Message: Working changes for db-lisp backend --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/08 15:57:19 1.2 @@ -1,4 +1,34 @@ +High level lisp backend design: +- Page storage, layout policy; lisp array or foreign data? + - key length limits + - ordering functions + - secondary index functions +- Locking policy (in-memory) + - blocking or optimistic concurrency + - how to signal +- Transaction ids +- Logging transactions and side effects + +Performance considerations: +- Slot access is usually local to objects +- Variable length objects are fundamental +- How to handle large blobs? + +Foreign array blocks? Faster copies, +avoid GC overhead, easy to write to +disk, static type, fast pointer ops. + +Aligned data types to simplify pointers + +Index pages (btree catalogs) +Object pages (sequences of slots) +Blob pages + +PTHREAD mutex speed + +=========================== + A lisp backend will need: - read/write binary sequences - move/cache binary pages to/from disk --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/08 15:57:19 1.2 @@ -1,2 +1,55 @@ (in-package :db-lisp) +;; Data layout +;; - page types: index, leaf, blobs + +(defparameter *type-table* + '((0 . :unknown) + (1 . :index) + (2 . :leaf) + (3 . :blob))) + +(defun get-type (byte) + (assert (<= byte (car (last *type-table*)))) + (cdr (assoc byte *type-table*))) + +(defun get-type-id (type-symbol) + (loop for (id symbol) in *type-table* do + (when (eq type-symbol symbol) + (return id)) + finally (error "Invalid page type identifier"))) + +;; +;; Read/Write references +;; + +;; +;; Page headers +;; + +(defun read-page-header (page) + (with-buffer-streams (header) + (buffer-write-from-array-offset (page-buffer page) 0 1 header) + (setf (page-type page) (get-type (buffer-read-byte header))))) + +(defun write-page-header (page) + (with-buffer-streams (header) + (buffer-write-byte (get-type-id (page-type page)) header) + (buffer-read-to-array-offset (page-buffer page) 0 header))) + +;; +;; Indexes: +;; + + + +;; User Operations: +;; btree-create + +;; btree-search +;; btree-insert + +;; Internal operations: +;; btree-split-child +;; btree-insert-nonfull + --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/08 15:57:19 1.2 @@ -2,17 +2,17 @@ (in-package :db-lisp) (defclass binary-file () - ((stream :initarg :stream :initform nil - :accessor binary-file-stream))) + ((path :initarg :path :initarg "" :accessor binary-file-path) + (stream :initarg :stream :accessor binary-file-stream))) -(defun open-binary-file (dir name &optional (if-does-not-exist :create)) - (let ((stream (open (make-pathname :directory dir :name name) +(defun open-binary-file (path &optional (if-does-not-exist :create)) + (let ((stream (open path :direction :io :element-type '(unsigned-byte 8) :if-exists :overwrite :if-does-not-exist if-does-not-exist))) (when stream - (make-instance 'binary-file :stream stream)))) + (make-instance 'binary-file :path path :stream stream)))) -(defmethod close-file ((bf binary-file)) +(defmethod close-binary-file ((bf binary-file)) (close (binary-file-stream bf))) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/octet-stream.lisp 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/octet-stream.lisp 2007/02/08 15:57:19 1.2 @@ -174,7 +174,7 @@ (make-instance 'octet-output-stream :buffer (make-array 128 :element-type '(unsigned-byte 8)))) -(defclass octet-io-stream (octet-output-stream octet-input-stream) +(defclass octet-io-stream (octet-output-stream octet-input-stream) ((limit :accessor limit-p :initarg :limit))) (defmethod #.*stream-write-byte-function* ((stream octet-io-stream) integer) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/08 15:57:19 1.2 @@ -1,72 +1,11 @@ (in-package :cl-user) -(defpackage :rucksack-elephant - (:use :cl :rucksack) - (:export - ;; controller - #:open-rucksack #:close-rucksack #:with-rucksack #:current-rucksack - #:rucksack #:standard-rucksack - #:rucksack-cache - #:rucksack-directory - #:rucksack-commit #:rucksack-rollback - #:add-rucksack-root #:map-rucksack-roots #:rucksack-roots - #:commit #:rollback - ;; class indexing -;; #:add-class-index #:add-slot-index -;; #:remove-class-index #:remove-slot-index -;; #:map-class-indexes #:map-slot-indexes - #:rucksack-add-class-index #:rucksack-add-slot-index - #:rucksack-make-class-index - #:rucksack-remove-class-index #:rucksack-remove-slot-index - #:rucksack-class-index #:rucksack-slot-index - #:rucksack-map-class-indexes #:rucksack-map-slot-indexes - #:rucksack-maybe-index-changed-slot #:rucksack-maybe-index-new-object - #:rucksack-map-class #:rucksack-map-slot - ;; Transactions -;; #:current-transaction -;; #:transaction-start #:transaction-commit #:transaction-rollback -;; #:with-transaction -;; #:transaction #:standard-transaction -;; #:transaction-start-1 #:transaction-commit-1 -;; #:transaction-id - ;; Conditions - #:rucksack-error #:simple-rucksack-error #:transaction-conflict - #:btree-error #:btree-search-error #:btree-insertion-error - #:btree-key-already-present-error #:btree-type-error - #:btree-error-btree #:btree-error-key #:btree-error-value - ;; Heaps - #:heap #:free-list-heap #:mark-and-sweep-heap #:simple-free-list-heap - #:open-heap #:close-heap - #:heap-stream #:heap-end - ;; BTree IF -;; #:btree - #:btree-key< #:btree-key= #:btree-value= - #:btree-max-node-size #:btree-unique-keys-p - #:btree-key-type #:btree-value-type - #:btree-node-class #:btree-node - ;; Indexes - #:map-index #:index-insert #:index-delete #:make-index - ;; BTrees - #:btree-search #:btree-insert -;; #:map-btree - - ;; Objects -;; #:persistent-object - #:persistent-data #:persistent-array #:persistent-cons - #:object-id - #:p-cons #:p-array - #:p-eql - #:p-car #:p-cdr #:p-list - #:p-make-array #:p-aref #:p-array-dimensions - #:p-length #:p-find #:p-replace #:p-position - )) - (defpackage :db-lisp - (:use :cl :elephant :elephant-backend :rucksack-elephant)) + (:use :cl :elephant :elephant-backend :elephant-memutil)) -;; file -;; octet-stream -;; binary-data -;; binary-types -;; buffers -;; btree +;; file - open/close binary files +;; octet-stream - read/write binary buffers +;; binary-fields - macro package for reading/writing lisp arrays +;; pages - binary pages read/written to and from stream; simple metadata +;; includes a simple LRU page-caching scheme using linked-lists +;; btree - btrees implemented on top of pages --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 15:57:20 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 15:57:20 1.1 (in-package :db-lisp) ;; ;; Mixins ;; (defclass doubly-linked-list-mixin () ((next :accessor dlist-next :initform nil) (prev :accessor dlist-prev :initform nil))) (defmethod link-node ((node doubly-linked-list-mixin) before after) "Insert page into doubly linked list" (unless (null before) (setf (dlist-next before) node)) (setf (dlist-next node) after) (setf (dlist-prev node) before) (unless (null after) (setf (page-prev after) ndoe)) node) (defmethod unlink-node ((node doubly-linked-list-mixin)) "Remove page from linked list; return next" (unless (null (dlist-next node)) (setf (dlist-prev (dlist-next node)) (dlist-prev node))) (unless (null (dlist-prev node)) (setf (dlist-next (dlist-prev node)) (dlist-next node))) node) ;; ============================================================================ ;; ;; Buffer-Page -- Maintains a page of binary data ;; ;; ============================================================================ (defclass buffer-page (doubly-linked-list-mixin) ((position :accessor page-position :initarg :position :initform -1) ;; position (type :accessor page-type :initarg :type :initform :unknown) (size :accessor page-size :initarg :page-size :initform 4096) (dirty-p :accessor page-dirty-p :initform nil) (buffer :accessor page-buffer :type (simple-array (unsigned-byte 8) (*))) (stream :accessor page-stream-store)) (:documentation "A buffer-page is an in-memory buffer containing the contents of a random access stream (usually a file).")) (defmethod initialize-instance :after ((page buffer-page) &rest initargs) (declare (ignore initargs)) (setf (page-buffer page) (make-array (page-size page) :element-type '(unsigned-byte 8)))) ;; ;; Primitive read-write of buffer-pages ;; ;; ;; Read/Write fixnums ;; (defun write-fixnum (page offset fix &optional (bytes 4)) (loop for i from 0 below bytes do (setf (aref (page-buffer page) (+ offset i)) (ldb (byte 8 (* i 8)) fix)))) ;; NOTE: Redo memutil/serializer primitives here? (defmethod copy-page ((page1 buffer-page) (page2 buffer-page)) (copy-slots page1 page2 '(position type size dirty-p stream)) (loop for (i fixnum) from 0 below (page-size page2) do (setf (aref (page-buffer page2) i) (aref (page-buffer page1) i)))) ;; ;; Read-write buffer-pages from buffer-streams ;; (defmethod write-buffer-stream ((page buffer-page) (bs buffer-stream) offset) "Put contents of buffer stream into the page at offset; return the buffer-stream" (buffer-read-to-array-offset (page-buffer page) offset bs) bs) (defmethod read-buffer-stream ((page buffer-page) (bs buffer-stream) offset length) "Put array contents at offset into buffer-stream and return stream" (declare (type fixnum offset length)) (buffer-write-from-array-offset (page-buffer page) offset length bs) bs) ;; ;; Page-level IO with backing stream store ;; (defmethod associate-page ((page associated-buffer-page) (stream stream) position) (setf (page-file-position page) position) (setf (page-stream-store page) stream)) (defmethod seek-to-page ((page buffer-page)) (file-position (page-stream page) (page-position page))) (defmethod load-page ((page buffer-page)) (seek-to-page page) (read-sequence (page-buffer page) str)) (defmethod flush-page ((page buffer-page)) (seek-to-page page) (write-sequence (page-buffer page) str)) (defmethod zero-page ((page buffer-page) &optional (value 0)) (loop for i from 0 upto (1- (length (page-buffer page))) do (setf (aref (page-buffer page) i) value)) page) ;; ============================================================================ ;; ;; Caching buffer pool ;; ;; ============================================================================ (defparameter *default-buffer-pool-pages* 4000) (defparameter *default-page-size* 4096) (defclass buffer-pool () ((lock :accessor pool-lock :initarg :lock :initform nil) (page-count :accessor pool-pages :initarg :pages :initform *default-buffer-pool-pages*) (page-size :accessor pool-page-size :initarg :page-size :initform *default-page-size*) (free-list :accessor pool-free-list :initform nil) (active-list :accessor pool-active-list :initform nil) (least-recently-used :accessor pool-lru-page :initform nil) (hash :accessor pool-hash :initform nil))) (defmethod initialize-instance :after ((pool buffer-pool) &rest rest) "Create a set of pages to populate the pool" (declare (ignore rest)) (labels ((make-page () (make-instance 'buffer-page :page-size (pool-page-size pool)))) (unless (= (pool-pages pool) 0) (setf (pool-free-list pool) (make-page))) (let ((prior (pool-free-list pool))) (dotimes (i (pool-pages pool) pool) (setf prior (link-page (make-page) prior nil)))))) ;; ;; Pool level operations ;; (defmethod eject-page ((pool buffer-pool)) "Eject the least recently used, unwritten page, from the cache" (assert (not (null (pool-lru-page pool)))) (let ((lru (pool-lru-page pool))) (setf (pool-lru-page pool) (dlist-prev (unlink-page lru))) (loop until (or (null lru) (not (dirty-p lru))) do (setf lru (dlist-prev lru))) (when (null lru) (error "No unwritten pages available to eject! Memory exhausted!")) lru)) (defun pop-free-list (pool) (let ((page (pool-free-list pool))) (setf (pool-free-list pool) (dlist-next page)) (unlink-node page))) (defun push-free-list (page pool) (link-node page nil (pool-free-list pool)) (setf (pool-free-list pool) page)) (defun push-active-list (page pool) (link-node page nil (pool-active-list pool)) (setf (pool-active-list pool) page)) (defun touch-page (page pool) (push-active-list (unlink-node page))) (defmethod get-empty-page ((pool buffer-pool) position) (if (null (pool-free-list pool)) (eject-page pool) (pop-free-list pool))) (defmethod lookup-page ((pool buffer-pool) position stream) (let ((pages (gethash position (pool-hash pool)))) (find stream pages :key #'page-stream-store))) (defmethod cache-page ((pool buffer-pool) page) (push page (gethash (page-position page) (pool-hash pool)))) ;; ;; User cache operations ;; (defmethod get-page ((pool buffer-pool) stream position) (touch-page (or (lookup-page pool) (cache-page pool (load-page (associate-page (get-empty-page pool) stream position)))) pool))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 08 Feb '07

08 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv27108 Modified Files: serializer2.lisp Log Message: Missing checking from Henrik's changes --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 19:33:11 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/08 15:51:01 1.19 @@ -21,9 +21,6 @@ #+cmu (:import-from :bignum %bignum-ref) - #+sbcl - (:import-from :sb-bignum - %bignum-ref) (:import-from :elephant *circularity-initial-hash-size* get-cached-instance @@ -44,7 +41,7 @@ (inline serialize deserialize slots-and-values deserialize-bignum - #+(or sbcl cmu) %bignum-ref))) + #+cmu %bignum-ref))) (uffi:def-type foreign-char :char) @@ -329,14 +326,14 @@ (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! + ;; this ldb is consing on CMUCL/OpenMCL! ;; there is an OpenMCL function which should work ;; and non-cons do - #+(or cmu sbcl) - (buffer-write-uint (%bignum-ref num i) bs) - #+(or lispworks openmcl allegro) - (buffer-write-uint (ldb (byte 32 (* 32 i)) num) bs) + #+cmu + (buffer-write-uint32 (%bignum-ref num i) bs) ;; should fail under 64-bit CMU + #-cmu + (buffer-write-uint32 (ldb (byte 32 (* 32 i)) num) bs) ))) ;;;

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by rread 07 Feb '07

07 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv4302/src/db-clsql Modified Files: package.lisp sql-controller.lisp Log Message: Commiting a thread-safe version of the SQL side (but SBCL-depdent.) --- /project/elephant/cvsroot/elephant/src/db-clsql/package.lisp 2006/11/11 18:41:11 1.1 +++ /project/elephant/cvsroot/elephant/src/db-clsql/package.lisp 2007/02/07 22:54:12 1.2 @@ -20,5 +20,8 @@ (defpackage db-clsql (:use :common-lisp :uffi :cl-base64 - :elephant :elephant-memutil :elephant-backend)) + :elephant :elephant-memutil :elephant-backend +;; :elephant-utils + #+sbcl :sb-thread + )) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/05 00:32:27 1.16 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/07 22:54:12 1.17 @@ -22,14 +22,64 @@ ;; The main SQL Controller Class ;; +;; Every actual CL-SQL connection has to be in a separate thread. +;; My solution to this is to keep a map of threads, and reuse +;; connections within a certain thread. +;; This seems to be effective under SBCL; as of 06-Feb-2007 we +;; don't necessarily have a way to do this under the other implementations +;; (see src/utils/lock.lisp.) + (defclass sql-store-controller (store-controller) - ((db :accessor controller-db :initarg :db :initform nil)) + ( +;; (db :accessor controller-db :initarg :db :initform nil) + (dbcons :accessor controller-db-table :initarg :db :initform nil) + ) (: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. This is the Postgresql-specific subclass of store-controller.")) + +;; This should be much more elegant --- but as of Feb. 6, SBCL 1.0.2 has a weird, +;; unpleasant bug when ASDF tries to load this stuff. +;; (defvar *thread-table-lock* nil) +;; (defvar *thread-table-lock* (sb-thread::make-mutex :name "thread-table-lock")) + +(defvar *thread-table-lock* nil) + +(defun insure-thread-table-lock () + (if (null *thread-table-lock*) +;; nil +;; (setq *thread-table-lock* (sb-thread::make-mutex :name "thread-table-lock")) + (setq *thread-table-lock* (elephant::ele-make-lock)) + ) +) + + +(defun thread-hash () + (elephant::ele-thread-hash-key) +) + + +(defmethod controller-db ((sc sql-store-controller)) + (elephant::ele-with-lock (*thread-table-lock*) + (let ((curcon (gethash (thread-hash) (controller-db-table sc)))) + (if curcon + curcon + (let* ((dbtype (car (second (controller-spec sc)))) + (con (clsql:connect (cdr (second (controller-spec sc))) + :database-type dbtype + :pool t + :if-exists :new))) + (setf (gethash (thread-hash) (controller-db-table sc)) + con) + con) + ) + ) + )) + + (eval-when (:compile-toplevel :load-toplevel) (register-backend-con-init :clsql 'sql-test-and-construct)) @@ -270,15 +320,25 @@ ;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem! ;; ALL OF THIS needs to be inside a transaction. - (clsql::create-table [keyvalue] - - ;; This is most likely to work with any database system.. - '( - ([clctn_id] integer :not-null) - ([key] text :not-null) - ([value] text) - ) - :database con) + (clsql::create-sequence [serial] :database con) + (clsql::query + (format nil "create table keyvalue ( + pk integer PRIMARY KEY DEFAULT nextval('serial'), + clctn_id integer NOT NULL, + key varchar NOT NULL, + value varchar + )") + :database con) + + ;; (clsql::create-table [keyvalue] + + ;; ;; This is most likely to work with any database system.. + ;; '( + ;; ([clctn_id] integer :not-null) + ;; ([key] text :not-null) + ;; ([value] text) + ;; ) + ;; :database con) ;; :constraints '("PRIMARY KEY (clctn_id key)" ;; "UNIQUE (clctn_id,key)") @@ -338,6 +398,7 @@ (recover-fatal nil) (thread t)) (declare (ignore recover recover-fatal thread)) + (insure-thread-table-lock) (the sql-store-controller (let* ((dbtype (car (second (controller-spec sc)))) (path (cadr (second (controller-spec sc)))) @@ -346,7 +407,8 @@ (con (clsql:connect (cdr (second (controller-spec sc))) :database-type dbtype :if-exists :old))) - (setf (slot-value sc 'db) con) + (setf (slot-value sc 'dbcons) (make-hash-table :test 'equal)) +;; (setf (slot-value sc 'db) con) ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it.. (unless (keyvalue-table-exists con) @@ -365,19 +427,45 @@ ) ) +(defmethod connection-ok-p ((sc sql-store-controller)) + (connection-ok-p-con (controller-db sc))) + +(defun connection-ok-p-con (con) + (let ((str (format nil "~A" con))) + (search "OPEN" str) + )) + +(defmethod connection-really-ok-p ((sc sql-store-controller)) + ;; I don't really have a good way of doing this, but + ;; one thing that is sure is that the the print form should + ;; have OPEN and not CLOSED in it. + ) + +(defmethod controller-status ((sc sql-store-controller)) +;; This is a crummy way to deal with status; we really want +;; to return something we can compute against. + (clsql:status) + ) + + (defmethod reconnect-controller ((sc sql-store-controller)) - (setf (controller-db sc) - (clsql:reconnect :database (controller-db sc))) + (clsql:reconnect :database (controller-db sc) :force nil) +;; (setf (controller-db sc) +;; (clsql:reconnect :database (controller-db sc))) ) + (defmethod close-controller ((sc sql-store-controller)) - (when (slot-value sc 'db) - ;; close the connection - ;; (actually clsql has pooling and other complications, I am not sure - ;; that this is complete.) - (clsql:disconnect :database (controller-db sc)) - (setf (slot-value sc 'class-root) nil) + (maphash #'(lambda (k v) + (ignore-errors + (if (connection-ok-p-con v) + (clsql:disconnect :database v) + ) + ) + ) + (controller-db-table sc) + ) (setf (slot-value sc 'root) nil) - )) + ) ;; Because this is part of the public ;; interface that I'm tied to, it has to accept a store-controller... @@ -401,7 +489,6 @@ (defun sql-add-to-clcn (clcn key value sc &key (insert-only nil)) - (declare (ignore sc)) (assert (integerp clcn)) (let ((con (controller-db sc)) (vbs @@ -456,17 +543,17 @@ (let* ((con (controller-db sc)) (kbs (serialize-to-base64-string key sc)) - (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by value offset ~A limit 1 " + (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by pk offset ~A limit 1 " clcn kbs n)) (tuples -;; (clsql::query offsetquery :database con) - (clsql::select [value] - :from [keyvalue] - :where [and [= [clctn_id] clcn] [= [key] kbs]] - :database con - ) + (clsql::query offsetquery :database con) +;; (clsql::select [value] +;; :from [keyvalue] +;; :where [and [= [clctn_id] clcn] [= [key] kbs]] +;; :database con +;; ) ) ) ;; Get the lowest value by sorting and taking the first value; @@ -478,20 +565,21 @@ ;; that efficiently without changing the database structure; ;; but that's OK, I could add a column to support that ;; relatively easily later on. -;; (if (and (> (length tuples) 1)) -;; (format t "l = ~A~%" (length tuples)) -;; ) - (if (< n (length tuples)) -;; (values (deserialize-from-base64-string (car (nth n tuples)) sc) -;; t) - (values (nth n (sort - (mapcar - #'(lambda (x) - (deserialize-from-base64-string (car x) sc)) - tuples) - #'my-generic-less-than)) + (if tuples + (values (deserialize-from-base64-string (caar tuples) sc) t) - (values nil nil)))) + (values nil nil)) + +;; (if (< n (length tuples)) +;; (values (nth n (sort +;; (mapcar +;; #'(lambda (x) +;; (deserialize-from-base64-string (car x) sc)) +;; tuples) +;; #'my-generic-less-than)) +;; t) +;; (values nil nil)) +)) (defun sql-get-from-clcn-cnt (clcn key sc) (assert (integerp clcn)) @@ -509,7 +597,7 @@ (assert (integerp clcn)) (let* ((con (controller-db sc)) (tuples - (clsql::select [key] [value] + (clsql::select [pk] [key] [value] :from [keyvalue] :where [and [= [clctn_id] clcn]] :database con @@ -559,7 +647,6 @@ (defun sql-remove-from-clcn (clcn key sc) - (declare (ignore sc)) (assert (integerp clcn)) (let ((con (controller-db sc)) (kbs (serialize-to-base64-string key sc))

1 0

[elephant-cvs] CVS elephant/tests
by rread 07 Feb '07

07 Feb '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv4302/tests Modified Files: elephant-tests.lisp testindexing.lisp Log Message: Commiting a thread-safe version of the SQL side (but SBCL-depdent.) --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/05 19:33:46 1.24 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/07 22:54:13 1.25 @@ -165,10 +165,12 @@ (print (do-test 'indexing-basic)) (print (do-test 'indexing-inherit)) (print (do-test 'indexing-range)) + (print (do-test 'indexing-wipe-index)) (print (do-test 'indexing-reconnect-db)) (print (do-test 'indexing-change-class)) (print (do-test 'indexing-redef-class)) - (print (do-test 'indexing-timing)))) + (print (do-test 'indexing-timing)) + )) (defun do-collection-tests (&optional (spec *default-spec*)) "Just test indexing" --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/06 16:32:02 1.24 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/07 22:54:13 1.25 @@ -204,7 +204,9 @@ (defclass idx-five-del () ((slot1 :initarg :slot1 :initform 1 :accessor slot1)) (:metaclass persistent-metaclass)) - + (format t "r1 = ~A~%" r1) + (format t "r1 = ~A~%" (get-index (get-value 'idx-five-del (elephant::controller-class-root *store-controller*)) + 'slot1)) (values (eq (length r1) 1) (signals-error (get-instances-by-value 'idx-five-del 'slot1 1))

1 0

[elephant-cvs] CVS elephant
by rread 07 Feb '07

07 Feb '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv4302 Modified Files: INSTALL ele-clsql.asd Log Message: Commiting a thread-safe version of the SQL side (but SBCL-depdent.) --- /project/elephant/cvsroot/elephant/INSTALL 2007/02/05 19:33:10 1.21 +++ /project/elephant/cvsroot/elephant/INSTALL 2007/02/07 22:54:12 1.22 @@ -117,7 +117,7 @@ 4) Compile and load Elephant: The new backend load process should work automatically on Un*x -systems but if there are problems with loading foreign libraries, +systems but if there are probolems with loading foreign libraries, then you can test your C tools setup with 'make' in the elephant root directory. This will build the common memutils library in src/memutil/libmemutil.so/dylib that all backends require. @@ -168,7 +168,7 @@ (asdf:operate 'asdf:load-op :elephant-tests) (in-package :ele-tests) (setf *default-spec* <backend>) - where <backend> = { *testsqlite3-spec* | *testpg-spec* | *testbdb-spec* } + Where <backend> = { *testsqlite3-spec* | *testpg-spec* | *testbdb-spec* } (do-backend-tests) This will test the standalone API for your backend. Currently all tests are --- /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/11/11 18:41:10 1.8 +++ /project/elephant/cvsroot/elephant/ele-clsql.asd 2007/02/07 22:54:12 1.9 @@ -57,7 +57,8 @@ (:file "sql-controller") (:file "sql-transaction") (:file "sql-collections")) - :serial t)))) + :serial t + )))) :depends-on (:elephant :clsql :cl-base64))

1 0