Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv26060/src

Modified Files: utils.lisp Log Message: doc-strings buffer-streams to sleepycat.lisp with-transaction defaults to *auto-commit* nil

Date: Thu Sep 16 06:23:50 2004 Author: blee

Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.5 elephant/src/utils.lisp:1.6 --- elephant/src/utils.lisp:1.5 Sat Sep 4 10:23:30 2004 +++ elephant/src/utils.lisp Thu Sep 16 06:23:49 2004 @@ -42,76 +42,53 @@

(in-package "ELEPHANT") -(eval-when (:compile-toplevel :load-toplevel :execute) - (use-package "UFFI"))

-(declaim (inline ;resize-buffer-stream - finish-buffer - buffer-write-byte buffer-write-int buffer-write-uint - buffer-write-float buffer-write-double buffer-write-string - buffer-read-byte buffer-read-fixnum buffer-read-int - buffer-read-uint buffer-read-float buffer-read-double - buffer-read-string) - (type fixnum *lisp-obj-id*) +(declaim (type fixnum *lisp-obj-id*) (type hash-table *circularity-hash*) (type boolean *auto-commit*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; buffer-streams -;;; -;;; a stream-like interface for our buffers; methods are -;;; below. ultimately we might want a gray / simple -stream -;;; for real, for now who cares? - -(defstruct buffer-stream - (buffer (allocate-foreign-object :char 1) :type array-or-pointer-char) - (length 0 :type fixnum) - (position 0 :type fixnum)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Thread-local specials

(defparameter *store-controller* nil "The store controller which persistent objects talk to.")

;; Specials which control persistent objects -(defvar *auto-commit* T) - -(declaim (type buffer-stream *out-buf* *key-buf* *in-buf*)) - -;; Buffers for going in and out of the DB -(defvar *out-buf* (make-buffer-stream)) -(defvar *key-buf* (make-buffer-stream)) -(defvar *in-buf* (make-buffer-stream)) +(defvar *auto-commit* T + "Commit things not in transactions?")

;; Stuff the serializer uses -(defvar *lisp-obj-id* 0) -(defvar *circularity-hash* (make-hash-table :test 'eq)) -#+(or cmu scl sbcl allegro) -(defvar *resourced-byte-spec* (byte 32 0)) +(defvar *lisp-obj-id* 0 + "Circularity ids for the serializer.") +(defvar *circularity-hash* (make-hash-table :test 'eq) + "Circularity hash for the serializer.") + +#+(or cmu sbcl allegro) +(defvar *resourced-byte-spec* (byte 32 0) + "Byte specs on CMUCL, SBCL and Allegro are conses.")

;; TODO: make this for real! (defun run-elephant-thread (thunk) + "Sets the specials (which hopefully are thread-local) to +make the Elephant thread-safe." (let ((*current-transaction* +NULL-VOID+) - (*errno-buffer* (allocate-foreign-object :int 1)) - (*get-buffer* (allocate-foreign-object :char 1)) - (*get-buffer-length* 0) + (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*) - (*out-buf* (make-buffer-stream)) - (*key-buf* (make-buffer-stream)) - (*in-buf* (make-buffer-stream)) (*lisp-obj-id* 0) (*circularity-hash* (make-hash-table :test 'eq)) - #+(or cmu scl sbcl allegro) + #+(or cmu sbcl allegro) (*resourced-byte-spec* (byte 32 0))) - (declare (special *current-transaction* *errno-buffer* - *get-buffer* *get-buffer-length* *store-controller* - *auto-commit* *out-buf* *key-buf* *in-buf* + (declare (special *current-transaction* sleepycat::*errno-buffer* + sleepycat::*buffer-streams* + *store-controller* *auto-commit* *lisp-obj-id* *circularity-hash* - #+(or cmu scl sbcl allegro) *resourced-byte-spec*)) + #+(or cmu sbcl allegro) *resourced-byte-spec*)) (funcall thunk)))

@@ -128,6 +105,11 @@ txn-nowait txn-sync (retries 100)) &body body) + "Execute a body with a transaction in place. On success, +the transaction is committed. Otherwise, the transaction is +aborted. If the body deadlocks, the body is re-executed in +a new transaction, retrying a fixed number of iterations. +*auto-commit* is false for the body of the transaction." `(sleepycat:with-transaction (:transaction ,transaction :environment ,environment :parent ,parent @@ -136,7 +118,8 @@ :txn-nowait ,txn-nowait :txn-sync ,txn-sync :retries ,retries) - ,@body)) + (let ((*auto-commit* nil)) + ,@body)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -146,242 +129,70 @@ ;;; flushed from the table too

(defun make-cache-table (&rest args) + "Make a values-weak hash table: when a value has been +collected, so are the keys." #+(or cmu sbcl scl) (apply #'make-hash-table args) #+allegro (apply #'make-hash-table :values :weak args) #+lispworks (apply #'make-hash-table :weak-kind :value args) + #+openmcl + (apply #'make-hash-table :weak :value args) #-(or cmu sbcl scl allegro lispworks) (apply #'make-hash-table args) )

+#+openmcl +(defclass cleanup-wrapper () + ((cleanup :accessor cleanup :initarg :cleanup) + (value :accessor value :initarg :value))) + +#+openmcl +(defmethod ccl:terminate ((c cleanup-wrapper)) + (funcall (cleanup c))) + (defun get-cache (key cache) + "Get a value from a cache-table." #+(or cmu sbcl) (let ((val (gethash key cache))) (if val (values (weak-pointer-value val) t) (values nil nil))) - #-(or cmu sbcl scl) + #+openmcl + (let ((wrap (gethash key cache))) + (if wrap (values (value wrap) t) + (values nil nil))) + #+(or allegro lispworks) (gethash key cache) )

(defun make-finalizer (key cache) #+(or cmu sbcl) (lambda () (remhash key cache)) - #+allegro + #+(or allegro openmcl) (lambda (obj) (declare (ignore obj)) (remhash key cache)) )

(defun setf-cache (key cache value) + "Set a value in a cache-table." #+(or cmu sbcl) (let ((w (make-weak-pointer value))) (finalize value (make-finalizer key cache)) (setf (gethash key cache) w) value) + #+openmcl + (let ((w (make-instance 'cleanup-wrapper :value value + :cleanup (make-finalizer key cache)))) + (ccl:terminate-when-unreachable w) + (setf (gethash key cache) w) + value) #+allegro (progn (excl:schedule-finalization value (make-finalizer key cache)) (setf (gethash key cache) value)) - #-(or cmu sbcl scl allegro) + #+lispworks (setf (gethash key cache) value) )

(defsetf get-cache setf-cache) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; buffer-stream methods - -(eval-when (:compile-toplevel :load-toplevel) - (defun process-struct-slot-defs (slot-defs struct) - (loop for def in slot-defs - collect (list (first def) (list (second def) struct))))) - -(defmacro with-struct-slots (slot-defs struct &body body) - `(symbol-macrolet ,(process-struct-slot-defs slot-defs struct) - ,@body)) - -(defun resize-buffer-stream (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (when (> length len) - (let ((newlen (max length (* len 2)))) - (declare (type fixnum newlen)) - (let ((newbuf (allocate-foreign-object :char newlen))) - (copy-bufs newbuf 0 buf 0 len) - (free-foreign-object buf) - (setf buf newbuf) - (setf len newlen) - nil))))) - -(defun finish-buffer (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position)) - bs - (let ((length pos)) - (setf pos 0) - length))) - -(defun buffer-write-byte (b bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 8) b)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 1))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (setf (deref-array buf '(:array :char) pos) b) - (setf pos needed)))) - -(defun buffer-write-int (i bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (signed-byte 32) i)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-int buf i pos) - (setf pos needed) - nil))) - -(defun buffer-write-uint (u bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type (unsigned-byte 32) u)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-uint buf u pos) - (setf pos needed) - nil))) - -(defun buffer-write-float (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type single-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 4))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-float buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-double (d bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type double-float d)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let ((needed (+ pos 8))) - (when (> needed len) - (resize-buffer-stream bs needed)) - (write-double buf d pos) - (setf pos needed) - nil))) - -(defun buffer-write-string (s bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type string s)) - (with-struct-slots ((buf buffer-stream-buffer) - (pos buffer-stream-position) - (len buffer-stream-length)) - bs - (let* ((str-bytes (byte-length s)) - (needed (+ pos str-bytes))) - (declare (type fixnum str-bytes needed) - (dynamic-extent str-bytes needed)) - (when (> needed len) - (resize-buffer-stream bs needed)) - (copy-str-to-buf buf pos s 0 str-bytes) - (setf pos needed) - nil))) - -(defun buffer-read-byte (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (incf (buffer-stream-position bs)) - (deref-array (buffer-stream-buffer bs) '(:array :char) pos))) - -(defun buffer-read-fixnum (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the fixnum (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-int (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (signed-byte 32) (read-int (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-uint (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) pos)))) - -(defun buffer-read-float (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 4)) - (read-float (buffer-stream-buffer bs) pos))) - -(defun buffer-read-double (bs) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos 8)) - (read-double (buffer-stream-buffer bs) pos))) - -(defun buffer-read-string (bs length) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) - (type fixnum length)) - (let ((pos (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ pos length)) - ;; wide!!! - #+(and allegro ics) - (excl:native-to-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length - :external-format :unicode) - #+lispworks - (fli:convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length :external-format :unicode :null-terminated-p nil) - #-(or lispworks (and allegro ics)) - (convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) pos) - :length length :null-terminated-p nil)))