[elephant-cvs] CVS elephant/src/memutil
ieslick
ieslick at common-lisp.net
Sat Dec 16 19:35:11 UTC 2006
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
+ , at 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]
More information about the Elephant-cvs
mailing list