Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv4494/src/memutil
Modified Files: memutil.lisp Log Message: Checkpoint for 0.6.1 feature set - BROKEN
--- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/11/11 22:53:13 1.12 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/12/16 19:35:10 1.13 @@ -49,6 +49,8 @@ #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string #+(and sbcl sb-unicode) #:buffer-read-ucs4-string #:byte-length + + #:serialize-string #:deserialize-string #:pointer-int #:pointer-void #:array-or-pointer-char +NULL-CHAR+ +NULL-VOID+ @@ -80,20 +82,24 @@ (length :int)) :returning :void))
-(declaim (inline read-int read-uint read-float read-double - write-int write-uint write-float write-double - offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs - ;;resize-buffer-stream - ;;buffer-stream-buffer buffer-stream-size buffer-stream-position - ;;buffer-stream-length - reset-buffer-stream - 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-ucs1-string - #+(or lispworks (and allegro ics)) buffer-read-ucs2-string - #+(and sbcl sb-unicode) buffer-read-ucs4-string)) +(eval-when (compile) + (declaim + (optimize (speed 3) (safety 1) (space 0) (debug 0)) + (inline read-int read-uint read-float read-double + write-int write-uint write-float write-double + offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs + ;;resize-buffer-stream + ;;buffer-stream-buffer buffer-stream-size buffer-stream-position + ;;buffer-stream-length + reset-buffer-stream + 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-ucs1-string + #+(or lispworks (and allegro ics)) buffer-read-ucs2-string + #+(and sbcl sb-unicode) buffer-read-ucs4-string)) + )
;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -103,6 +109,17 @@ (defvar +NULL-CHAR+ (make-null-pointer :char) "A null pointer to a char type.")
+ +(defmacro memutil-without-interrupts (&body body) + "Ensure platform dependent atomicity" + `( + #+allegro excl:without-interrupts + #+lispworks lispworks:without-interrupts + #+sbcl sb-sys:without-interrupts + #+cmu system:without-interrupts + #+openmcl ccl:without-interrupts + ,@body)) + ;; Thread local storage (special variables)
(defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) @@ -125,16 +142,16 @@
(defun grab-buffer-stream () "Grab a buffer-stream from the *buffer-streams* resource pool." - (declare (optimize (speed 3))) (if (= (length *buffer-streams*) 0) (make-buffer-stream) - (vector-pop *buffer-streams*))) + (memutil-without-interrupts + (vector-pop *buffer-streams*))))
(defun return-buffer-stream (bs) "Return a buffer-stream to the *buffer-streams* resource pool." - (declare (optimize (speed 3))) (reset-buffer-stream bs) - (vector-push-extend bs *buffer-streams*)) + (memutil-without-interrupts + (vector-push-extend bs *buffer-streams*)))
(defmacro with-buffer-streams (names &body body) "Grab a buffer-stream, executes forms, and returns the @@ -159,18 +176,16 @@ #+(or cmu sbcl) (defun read-int (buf offset) "Read a 32-bit signed integer from a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type fixnum offset)) (the (signed-byte 32) (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) - (* (signed 32))))) + (* (signed 32))))))
#+(or cmu sbcl) (defun read-uint (buf offset) "Read a 32-bit unsigned integer from a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type fixnum offset)) (the (unsigned-byte 32) (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -179,8 +194,7 @@ #+(or cmu sbcl) (defun read-float (buf offset) "Read a single-float from a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type fixnum offset)) (the single-float (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -189,8 +203,7 @@ #+(or cmu sbcl) (defun read-double (buf offset) "Read a double-float from a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type fixnum offset)) (the double-float (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -199,8 +212,7 @@ #+(or cmu sbcl) (defun write-int (buf num offset) "Write a 32-bit signed integer to a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type (signed-byte 32) num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -209,8 +221,7 @@ #+(or cmu sbcl) (defun write-uint (buf num offset) "Write a 32-bit unsigned integer to a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type (unsigned-byte 32) num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -219,8 +230,7 @@ #+(or cmu sbcl) (defun write-float (buf num offset) "Write a single-float to a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type single-float num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -229,8 +239,7 @@ #+(or cmu sbcl) (defun write-double (buf num offset) "Write a double-float to a foreign char buffer." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) buf) + (declare (type (alien (* char)) buf) (type double-float num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) @@ -239,8 +248,7 @@ #+(or cmu sbcl) (defun offset-char-pointer (p offset) "Pointer arithmetic." - (declare (optimize (speed 3) (safety 0)) - (type (alien (* char)) p) + (declare (type (alien (* char)) p) (type fixnum offset)) (sap-alien (sap+ (alien-sap p) offset) (* char)))
@@ -345,23 +353,21 @@
#+(or cmu sbcl scl) (defun copy-str-to-buf (d do s so l) - (declare (optimize (speed 3) (safety 0)) - (type array-or-pointer-char d) - (type fixnum do so l) - (type string s)) - (%copy-str-to-buf d do - #+sbcl - (sb-sys:vector-sap s) - #+(or cmu scl) - (sys:vector-sap s) - so l)) + (declare (type array-or-pointer-char d) + (type fixnum do so l) + (type string s)) + (%copy-str-to-buf d do + #+sbcl + (sb-sys:vector-sap s) + #+(or cmu scl) + (sys:vector-sap s) + so l))
;; but OpenMCL can't directly pass string bytes. #+openmcl (defun copy-str-to-buf (dest dest-offset src src-offset length) "Copy a string to a foreign buffer. From Gary Byers." - (declare (optimize (speed 3) (safety 0)) - (type string src) + (declare (type string src) (type array-or-pointer-char dest) (type fixnum length src-offset dest-offset) (dynamic-extent src dest length)) @@ -374,7 +380,7 @@ ;; (defun copy-str-to-buf (dest dest-offset src src-offset length) ;; "Use build-in unicode handling and copying facilities. ;; NOTE: We need to validate the speed of this vs. default." -;; (declare (optimize (speed 3) (safety 0)) +;; (declare ;; (type string src) ;; (type array-or-pointer-char dest) ;; (type fixnum length src-offset dest-offset) @@ -386,11 +392,10 @@ #+(not (or cmu sbcl scl openmcl lispworks)) (defun copy-str-to-buf (dest dest-offset src src-offset length) "Copy a string to a foreign buffer." - (declare (optimize (speed 3) (safety 0)) - (type string src) - (type array-or-pointer-char dest) - (type fixnum length src-offset dest-offset) - (dynamic-extent src dest length)) + (declare (type string src) + (type array-or-pointer-char dest) + (type fixnum length src-offset dest-offset) + (dynamic-extent src dest length)) (typecase src (simple-string (loop for i fixnum from 0 below length @@ -419,8 +424,7 @@
(defun resize-buffer-stream (bs length) "Resize the underlying buffer of a buffer-stream, copying the old data." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type fixnum length)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -441,8 +445,7 @@
(defun resize-buffer-stream-no-copy (bs length) "Resize the underlying buffer of a buffer-stream." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type fixnum length)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -461,15 +464,13 @@
(defun reset-buffer-stream (bs) "'Empty' the buffer-stream." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (setf (buffer-stream-size bs) 0) (setf (buffer-stream-position bs) 0))
(defun buffer-write-byte (b bs) "Write a byte." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type (unsigned-byte 8) b)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -483,8 +484,7 @@
(defun buffer-write-int (i bs) "Write a 32-bit signed integer." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type (signed-byte 32) i)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -499,8 +499,7 @@
(defun buffer-write-uint (u bs) "Write a 32-bit unsigned integer." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type (unsigned-byte 32) u)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -515,8 +514,7 @@
(defun buffer-write-float (d bs) "Write a single-float." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type single-float d)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -531,8 +529,7 @@
(defun buffer-write-double (d bs) "Write a double-float." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type double-float d)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -547,9 +544,8 @@
(defun buffer-write-string (s bs) "Write the underlying bytes of a string. On Unicode -Lisps, this is a 16-bit operation." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs) + Lisps, this is a 16-bit operation." + (declare (type buffer-stream bs) (type string s)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) @@ -577,8 +573,7 @@
(defun buffer-read-byte (bs) "Read a byte." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (incf (buffer-stream-position bs)) (deref-array (buffer-stream-buffer bs) '(:array :unsigned-byte) position))) @@ -586,8 +581,7 @@
(defun buffer-read-byte-vector (bs) "Read the whole buffer into byte vector." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let* ((position (buffer-stream-position bs)) (size (buffer-stream-size bs)) (vlen (- size position))) @@ -599,8 +593,7 @@
(defun buffer-write-byte-vector (bs bv) "Read the whole buffer into byte vector." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let* ((position (buffer-stream-position bs)) (size (buffer-stream-size bs)) (vlen (length bv)) @@ -611,40 +604,35 @@
(defun buffer-read-fixnum (bs) "Read a 32-bit signed integer, which is assumed to be a fixnum." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (the fixnum (read-int (buffer-stream-buffer bs) position))))
(defun buffer-read-int (bs) "Read a 32-bit signed integer." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (the (signed-byte 32) (read-int (buffer-stream-buffer bs) position))))
(defun buffer-read-uint (bs) "Read a 32-bit unsigned integer." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) position))))
(defun buffer-read-float (bs) "Read a single-float." - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (read-float (buffer-stream-buffer bs) position)))
(defun buffer-read-double (bs) "Read a double-float."
[43 lines skipped]