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