[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sun Jan 21 21:20:05 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv13092/src/elephant
Modified Files:
controller.lisp package.lisp serializer.lisp serializer1.lisp
serializer2.lisp variables.lisp
Log Message:
Up and limping; 0.6.1 working HEAD is in good shape again. Fails four tests (all cursor ranges). Object ID's are turned off for now - they are a user configuration option
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/20 22:12:17 1.19
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/21 21:20:04 1.20
@@ -109,8 +109,8 @@
(defun open-store (spec &rest args)
"Conveniently open a store controller."
(assert (consp spec))
- ;; setup system config parameters (if necessary)
- ;; GF iface to overload by backend
+ ;; Setup system config parameters from my-config
+ (ensure-loaded-configuration)
(setq *store-controller* (get-controller spec))
(initialize-serializer *store-controller*)
(apply #'open-controller *store-controller* args))
@@ -167,7 +167,7 @@
(defun initialize-serializer (sc)
"Establish serializer version on controller startup"
- (cond ((prior-version-p (controller-version sc) '(0 6 0))
+ (cond ((prior-version-p (database-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))
@@ -181,10 +181,10 @@
;;
(defmethod database-version ((sc store-controller))
- (:documentation "A version determination for a given store
+ "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)"))
+ list of the form '(0 6 0)"
(let ((version (controller-version-cached sc)))
(if version version
(let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc)))))
@@ -192,7 +192,7 @@
(with-open-file (stream path :direction :input)
(setf (controller-version-cached sc) (read stream)))
(with-open-file (stream path :direction :output)
- (setf (controller-version-cached sc)
+ (setf (controller-version-cached sc)
(write *elephant-code-version* :stream stream))))))))
(defun prior-version-p (v1 v2)
@@ -358,13 +358,13 @@
;;
(defmethod up-to-date-p ((sc store-controller))
- (equal (controller-version sc) *elephant-code-version*))
+ (equal (database-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)
+ (database-version sc)
*elephant-code-version*
*elephant-upgrade-table*))
(warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your
@@ -383,7 +383,7 @@
"Determine if this store can be brought up to date using the upgrade function"
(unwind-protect
(let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal))
- (ver (controller-version sc)))
+ (ver (database-version sc)))
(when (member ver (rest row) :test #'equal)) t)
nil))
--- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/20 22:12:18 1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/21 21:20:04 1.7
@@ -54,6 +54,7 @@
#:lookup-persistent-symbol
#:lookup-persistent-symbol-id
+ #:int-byte-spec
#:cursor #:secondary-cursor #:make-cursor
#:with-btree-cursor #:cursor-close #:cursor-init
@@ -68,8 +69,6 @@
#:cursor-pset-range #:cursor-pget-both
#:cursor-pget-both-range
- #:run-elephant-thread
-
;; Class indexing management API
#:*default-indexed-class-synch-policy*
#:find-class-index #:find-inverted-index
@@ -95,6 +94,7 @@
#:ele-make-lock
#:ele-with-lock
#:ele-without-interrupts
+ #:slots-and-values
)
#+cmu
(:import-from :pcl
--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/20 22:12:18 1.16
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/21 21:20:04 1.17
@@ -19,16 +19,15 @@
(defun serialize (frob bs sc)
"Generic interface to serialization that dispatches based on the
current Elephant version"
+ (assert sc)
(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"
+ (assert sc)
(funcall (symbol-function (controller-deserialize sc)) bs sc))
-;;(defun serializer-feature (sc)
-;; (
-
;;
;; SQL encoding support
;;
@@ -103,27 +102,75 @@
;; )))
;;;;
-;;;; Serializer comparison via performane test
+;;;; Common utilities
;;;;
-(defun performance-test (serialize-fn deserialize-fn object &optional (iterations 10000))
- (declare (optimize (speed 3) (safety 1)))
- (let ((bs (elephant-memutil::grab-buffer-stream)))
- (reset-buffer-stream bs)
- (loop for i fixnum from 0 to iterations do
- (funcall serialize-fn object bs nil)
- (funcall deserialize-fn bs nil)
- (reset-buffer-stream bs))
- (elephant-memutil::return-buffer-stream bs)))
-
-(defun test-1 (object &optional (iterations 10000))
- (time
- (performance-test #'elephant-serializer1::serialize
- #'elephant-serializer1::deserialize
- object iterations)))
-
-(defun test-2 (object &optional (iterations 10000))
- (time
- (performance-test #'elephant-serializer2::serialize
- #'elephant-serializer2::deserialize
- object iterations)))
\ No newline at end of file
+;; slot names and values for ordinary objects
+
+(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)))
+
+;; array type tags
+
+(declaim (type hash-table array-type-to-byte byte-to-array-type))
+(defvar array-type-to-byte (make-hash-table :test 'equalp))
+(defvar byte-to-array-type (make-hash-table :test 'equalp))
+
+(setf (gethash 'T array-type-to-byte) #x00)
+(setf (gethash 'base-char array-type-to-byte) #x01)
+(setf (gethash 'character array-type-to-byte) #x02)
+(setf (gethash 'single-float array-type-to-byte) #x03)
+(setf (gethash 'double-float array-type-to-byte) #x04)
+(setf (gethash '(complex single-float) array-type-to-byte) #x05)
+(setf (gethash '(complex double-float) array-type-to-byte) #x06)
+(setf (gethash 'fixnum array-type-to-byte) #x07)
+(setf (gethash 'bit array-type-to-byte) #x08)
+
+(defun type= (t1 t2)
+ (and (subtypep t1 t2) (subtypep t2 t1)))
+
+(let ((counter 8))
+ (loop for i from 2 to 65
+ for spec = (list 'unsigned-byte i)
+ for uspec = (upgraded-array-element-type spec)
+ when (type= spec uspec)
+ do
+ (setf (gethash spec array-type-to-byte) (incf counter)))
+ (loop for i from 2 to 65
+ for spec = (list 'signed-byte i)
+ for uspec = (upgraded-array-element-type spec)
+ when (type= spec uspec)
+ do
+ (setf (gethash spec array-type-to-byte) (incf counter))))
+
+(loop for key being the hash-key of array-type-to-byte
+ using (hash-value value)
+ do
+ (setf (gethash value byte-to-array-type) key))
+
+(defun array-type-from-byte (b)
+ (gethash b byte-to-array-type))
+
+(defun byte-from-array-type (ty)
+ (the (unsigned-byte 8) (gethash ty array-type-to-byte)))
+
+(defun int-byte-spec (position)
+ (declare (optimize (speed 3) (safety 0))
+ (type (unsigned-byte 24) position))
+ #+(or cmu sbcl allegro)
+ (progn (setf (cdr *resourced-byte-spec*) (* 32 position))
+ *resourced-byte-spec*)
+ #-(or cmu sbcl allegro)
+ (byte 32 (* 32 position))
+ )
+
--- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/16 00:51:25 1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/21 21:20:04 1.2
@@ -24,7 +24,10 @@
slot-definition-allocation
slot-definition-name
compute-slots
- oid))
+ oid
+ int-byte-spec
+ array-type-from-byte
+ byte-from-array-type))
(in-package :elephant-serializer1)
@@ -82,20 +85,20 @@
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)))
+ (declare #-elephant-without-optimize (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))
+ (declare #-elephant-without-optimize (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)))
+ (declare #-elephant-without-optimize (optimize (speed 3) (safety 0)))
(typecase frob
(fixnum
(buffer-write-byte +fixnum+ bs)
@@ -269,26 +272,13 @@
(%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))
+ (declare #-elephant-without-optimize (optimize (speed 3) (safety 0))
(type (or null buffer-stream) buf-str))
(labels
((%deserialize (bs)
- (declare (optimize (speed 3) (safety 0))
+ (declare #-elephant-without-optimize (optimize (speed 3) (safety 0))
(type buffer-stream bs))
(let ((tag (buffer-read-byte bs)))
(declare (type foreign-char tag))
@@ -439,7 +429,7 @@
(%deserialize buf-str)))))
(defun deserialize-bignum (bs length positive)
- (declare (optimize (speed 3) (safety 0))
+ (declare #-elephant-without-optimize (optimize (speed 3) (safety 0))
(type buffer-stream bs)
(type fixnum length)
(type boolean positive))
@@ -451,58 +441,5 @@
finally (return (if positive num (- num)))))
-;; array type tags
-
-(declaim (type hash-table array-type-to-byte byte-to-array-type))
-(defvar array-type-to-byte (make-hash-table :test 'equalp))
-(defvar byte-to-array-type (make-hash-table :test 'equalp))
-
-(setf (gethash 'T array-type-to-byte) #x00)
-(setf (gethash 'base-char array-type-to-byte) #x01)
-(setf (gethash 'character array-type-to-byte) #x02)
-(setf (gethash 'single-float array-type-to-byte) #x03)
-(setf (gethash 'double-float array-type-to-byte) #x04)
-(setf (gethash '(complex single-float) array-type-to-byte) #x05)
-(setf (gethash '(complex double-float) array-type-to-byte) #x06)
-(setf (gethash 'fixnum array-type-to-byte) #x07)
-(setf (gethash 'bit array-type-to-byte) #x08)
-
-(defun type= (t1 t2)
- (and (subtypep t1 t2) (subtypep t2 t1)))
-
-(let ((counter 8))
- (loop for i from 2 to 65
- for spec = (list 'unsigned-byte i)
- for uspec = (upgraded-array-element-type spec)
- when (type= spec uspec)
- do
- (setf (gethash spec array-type-to-byte) (incf counter)))
- (loop for i from 2 to 65
- for spec = (list 'signed-byte i)
- for uspec = (upgraded-array-element-type spec)
- when (type= spec uspec)
- do
- (setf (gethash spec array-type-to-byte) (incf counter))))
-
-(loop for key being the hash-key of array-type-to-byte
- using (hash-value value)
- do
- (setf (gethash value byte-to-array-type) key))
-
-(defun array-type-from-byte (b)
- (gethash b byte-to-array-type))
-
-(defun byte-from-array-type (ty)
- (the (unsigned-byte 8) (gethash ty array-type-to-byte)))
-
-(defun int-byte-spec (position)
- (declare (optimize (speed 3) (safety 0))
- (type (unsigned-byte 24) position))
- #+(or cmu sbcl allegro)
- (progn (setf (cdr *resourced-byte-spec*) (* 32 position))
- *resourced-byte-spec*)
- #-(or cmu sbcl allegro)
- (byte 32 (* 32 position))
- )
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/20 22:12:18 1.2
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/21 21:20:04 1.3
@@ -27,13 +27,15 @@
slot-definition-allocation
slot-definition-name
compute-slots
- oid))
-
+ oid
+ int-byte-spec
+ array-type-from-byte
+ byte-from-array-type))
(in-package :elephant-serializer2)
(eval-when (compile)
- (declaim (optimize (speed 3) (safety 1) (space 0) (debug 0))
+ (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0))
(inline int-byte-spec
serialize deserialize
slots-and-values
@@ -145,147 +147,153 @@
(defun serialize (frob bs sc)
"Serialize a lisp value into a buffer-stream."
(declare (type buffer-stream bs))
- (let ((*lisp-obj-id* 0)
+ (let ((*lisp-obj-id* -1)
(*circularity-hash* (get-circularity-hash)))
(labels
- ((%serialize (frob)
- (etypecase frob
- ((integer #.most-negative-fixnum #.most-positive-fixnum)
- (buffer-write-byte +fixnum+ bs)
- (buffer-write-int frob bs))
- (null
- (buffer-write-byte +nil+ bs))
- (symbol
- (serialize-symbol frob bs sc))
- (string
- (serialize-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))
+ ((%next-object-id ()
+ (incf *lisp-obj-id*))
+ (%serialize (frob)
+ (etypecase frob
+ ((integer #.most-negative-fixnum #.most-positive-fixnum)
+ (buffer-write-byte +fixnum+ bs)
+ (buffer-write-int frob bs))
+ (null
+ (buffer-write-byte +nil+ bs))
+ (symbol
+ (serialize-symbol frob bs sc))
+ (string
+ (serialize-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))
- (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)))))))
- (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)))
- (character
- (buffer-write-byte +char+ bs)
- ;; might be wide!
- (buffer-write-uint (char-code frob) bs))
- (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))))))
- (pathname
- (let ((pstring (namestring frob)))
- (buffer-write-byte +pathname+ bs)
- (serialize-string pstring bs)))
- (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))))))
-;; (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)))))))
- )))
+ #-(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))
+ (standard-object
+ (buffer-write-byte +object+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (let ((id (%next-object-id)))
+ (buffer-write-int id bs)
+ (setf (gethash frob *circularity-hash*) 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)))))))
+ (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)))
+ (character
+ (buffer-write-byte +char+ bs)
+ ;; might be wide!
+ (buffer-write-uint (char-code frob) bs))
+ (cons
+ (buffer-write-byte +cons+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (let ((id (%next-object-id)))
+ (buffer-write-int id bs)
+ (setf (gethash frob *circularity-hash*) id))
+ (%serialize (car frob))
+ (%serialize (cdr frob))))))
+ (pathname
+ (let ((pstring (namestring frob)))
+ (buffer-write-byte +pathname+ bs)
+ (serialize-string pstring bs)))
+ (hash-table
+ (buffer-write-byte +hash-table+ bs)
+ (let ((idp (gethash frob *circularity-hash*)))
+ (if idp (buffer-write-int idp bs)
+ (progn
+ (let ((id (%next-object-id)))
+ (buffer-write-int id bs)
+ (setf (gethash frob *circularity-hash*) 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))))))
+ ;; (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
+ (let ((id (%next-object-id)))
+ (buffer-write-int id bs)
+ (setf (gethash frob *circularity-hash*) 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)))
@@ -512,61 +520,3 @@
symbol)
(error "Symbol lookup foobar! ID referred to does not exist in database"))))))
-
-;;
-;; Array type tags
-;;
-
-(declaim (type hash-table array-type-to-byte byte-to-array-type))
-(defvar array-type-to-byte (make-hash-table :test 'equalp))
-(defvar byte-to-array-type (make-hash-table :test 'equalp))
-
-(setf (gethash 'T array-type-to-byte) #x00)
-(setf (gethash 'base-char array-type-to-byte) #x01)
-(setf (gethash 'character array-type-to-byte) #x02)
-(setf (gethash 'single-float array-type-to-byte) #x03)
-(setf (gethash 'double-float array-type-to-byte) #x04)
-(setf (gethash '(complex single-float) array-type-to-byte) #x05)
-(setf (gethash '(complex double-float) array-type-to-byte) #x06)
-(setf (gethash 'fixnum array-type-to-byte) #x07)
-(setf (gethash 'bit array-type-to-byte) #x08)
-
-(defun type= (t1 t2)
- (and (subtypep t1 t2) (subtypep t2 t1)))
-
-(let ((counter 8))
- (loop for i from 2 to 65
- for spec = (list 'unsigned-byte i)
- for uspec = (upgraded-array-element-type spec)
- when (type= spec uspec)
- do
- (setf (gethash spec array-type-to-byte) (incf counter)))
- (loop for i from 2 to 65
- for spec = (list 'signed-byte i)
- for uspec = (upgraded-array-element-type spec)
- when (type= spec uspec)
- do
- (setf (gethash spec array-type-to-byte) (incf counter))))
-
-(loop for key being the hash-key of array-type-to-byte
- using (hash-value value)
- do
- (setf (gethash value byte-to-array-type) key))
-
-(defun array-type-from-byte (b)
- (gethash b byte-to-array-type))
-
-(defun byte-from-array-type (ty)
- (the (unsigned-byte 8) (gethash ty array-type-to-byte)))
-
-(defun int-byte-spec (position)
- (declare (optimize (speed 3) (safety 0))
- (type (unsigned-byte 24) position))
- #+(or cmu sbcl allegro)
- (progn (setf (cdr *resourced-byte-spec*) (* 32 position))
- *resourced-byte-spec*)
- #-(or cmu sbcl allegro)
- (byte 32 (* 32 position))
- )
-
-
--- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/20 22:12:18 1.7
+++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/21 21:20:04 1.8
@@ -43,7 +43,14 @@
Users attempting to directly write this variable will run into an
error")
-(defvar *fast-symbols* nil)
+;;;;;;;;;;;;;;;;;;;;
+;;;; User Configuration for site customization
+
+(defvar *fast-symbols* nil) ;; for serializer2.lisp
+
+(defun ensure-loaded-configuration ()
+ (setf *fast-symbols*
+ (elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant))))
;;;;;;;;;;;;;;;;;
;;;; Serializer optimization parameters
More information about the Elephant-cvs
mailing list