[elephant-cvs] CVS update: elephant/src/utils.lisp
blee at common-lisp.net
blee at common-lisp.net
Thu Sep 16 04:23:50 UTC 2004
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)
- , at body))
+ (let ((*auto-commit* nil))
+ , at 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)
- , at 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)))
More information about the Elephant-cvs
mailing list