X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/90e8bbf63d6ab5647f284af1cbab30ae37c5ae1c..6dfb20397142408cc4adfa437bb12d8aa300270e:/gffi/vectors.lisp

diff --git a/gffi/vectors.lisp b/gffi/vectors.lisp
index 082c34c..8364033 100644
--- a/gffi/vectors.lisp
+++ b/gffi/vectors.lisp
@@ -20,27 +20,47 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: vectors.lisp,v 1.2 2006-06-08 13:24:25 espen Exp $
+;; $Id: vectors.lisp,v 1.9 2008-12-10 02:41:40 espen Exp $
 
 
 (in-package "GFFI")
 
+
+;;; Accessor functions for raw memory access
+
+(define-memory-accessor int-16)
+(define-memory-accessor int-32)
+(define-memory-accessor int-64)
+(define-memory-accessor uint-16)
+(define-memory-accessor uint-32)
+(define-memory-accessor uint-64)
+(define-memory-accessor single-float)
+(define-memory-accessor double-float)
+
+
 ;;; Vector
 
 (defun make-c-vector (type length &key content location temp)
   (let* ((element-size (size-of type))
 	 (location (or location (allocate-memory (* element-size length))))
 	 (writer (writer-function type :temp temp)))
-    (etypecase content
-      (vector
+
+    (cond
+      #+(or cmu sbcl)
+      ((and 
+	(typep content 'simple-unboxed-array) 
+	(type-equal-p type (array-element-type content)))
+       (with-pinned-objects (content)
+	 (copy-memory (vector-sap content) (* length element-size) location)))
+      ((listp content)
        (loop
-	for element across content
+	for element in content
 	for i below length
 	for offset by element-size
 	do (funcall writer element location offset)))
-      (list
+      (t
        (loop
-	for element in content
+	for element across content
 	for i below length
 	for offset by element-size
 	do (funcall writer element location offset))))
@@ -51,7 +71,7 @@ (defun map-c-vector (seqtype function location element-type length
 		     &optional (ref :read))
   (let ((reader (reader-function element-type :ref ref))
 	(element-size (size-of element-type)))
-    (case seqtype 
+    (case seqtype
      ((nil)
       (loop
        for i below length
@@ -62,6 +82,23 @@ (defun map-c-vector (seqtype function location element-type length
        for i below length
        for offset by element-size
        collect (funcall function (funcall reader location offset))))
+     (vector
+      (let ((vector (make-array length :element-type element-type)))
+	(cond
+	  #+(or cmu sbcl)
+	  ((and 
+	    (typep vector 'simple-unboxed-array)
+	    (or (eq function 'identity) (eq function #'identity)))
+	   (with-pinned-objects (vector)
+	     (copy-memory location (* length element-size) (vector-sap vector))))
+	  (t
+	   (loop
+	    for i below length
+	    for offset by element-size
+	    do (setf 
+		(aref vector i)
+		(funcall function (funcall reader location offset))))))
+	vector))
      (t
       (loop
        with sequence = (make-sequence seqtype length)
@@ -101,6 +138,17 @@ (define-type-method alien-type ((type vector))
   (declare (ignore type))
   (alien-type 'pointer))
 
+(define-type-method argument-type ((type vector))
+  (declare (ignore type))
+  'sequence)
+
+(define-type-method return-type ((type vector))
+  (destructuring-bind (element-type &optional (length '*)) 
+      (rest (type-expand-to 'vector type))
+    (if (constantp length)
+	`(vector ,(return-type element-type) ,length)
+      `(vector ,(return-type element-type) *))))
+
 (define-type-method size-of ((type vector) &key inlined)
   (if inlined
       (destructuring-bind (element-type &optional (length '*)) 
@@ -261,6 +309,177 @@ (define-type-method copy-function ((type vector) &key inlined)
 		(funcall copy-content (ref-pointer from offset) vector)))))))))
 
 
+;;;; Unboxed vector
+
+(deftype unboxed-vector (element-type &optional (length '*)) 
+  `(simple-array ,element-type (,length)))
+
+(define-type-method argument-type ((type unboxed-vector))
+  type)
+
+(define-type-method return-type ((type unboxed-vector))
+  (destructuring-bind (element-type &optional (length '*)) 
+      (rest (type-expand-to 'unboxed-vector type))
+    (if (constantp length)
+	`(unboxed-vector ,(return-type element-type) ,length)
+      `(unboxed-vector ,(return-type element-type) *))))
+
+(defun check-unboxed-vector (type)
+  #+(or sbcl cmu)
+  (unless (subtypep type 'simple-unboxed-array)
+    (error "~A is not a subtype of ~A" type 'simple-unboxed-array)))
+
+#+(or sbcl cmu)
+(progn
+  (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*)) 
+	(rest (type-expand-to 'unboxed-vector type))
+      (when (and (eq length '*) (out-arg-p style))
+	(error "Can't use vector with variable size as return type"))
+      (cond
+	((and (in-arg-p style) copy-in-p)
+	 `(with-pointer (,var (with-pinned-objects (,vector)
+				(copy-memory (vector-sap ,vector) 
+				 (* (length ,vector) ,(size-of element-type)))))
+	    ,form))
+	((in-arg-p style)
+	 `(with-pinned-objects (,vector)
+	    (let ((,var (vector-sap ,vector)))
+	      ,form)))
+	((out-arg-p style)
+	 `(with-pointer (,var)
+	    ,form)))))
+
+  (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
+    (declare (ignore copy-p))
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*)) 
+	(rest (type-expand-to 'unboxed-vector type))
+      `(with-pinned-objects (,vector)
+	 (copy-memory 
+	  (vector-sap ,vector) 
+	  (* ,(if (eq length '*) `(length ,vector) length) 
+	     ,(size-of element-type))))))
+
+
+  (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (when (eq length '*)
+	(error "Can't use vector of variable size as return type"))
+      `(let ((c-vector ,form)
+	     (vector (make-array ,length :element-type ',element-type)))
+	 (with-pinned-objects (vector)
+	   (copy-memory c-vector (* ,length ,(size-of element-type)) (vector-sap vector))
+	   ,(when (eq ref :free)
+	     `(deallocate-memory c-vector))
+	   vector))))
+
+  (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
+    (declare (ignore temp))
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (if inlined
+	  (if (eq length '*)
+	      (error "Can't inline vector with variable size: ~A" type)
+	      #'(lambda (vector location &optional (offset 0))
+		  (with-pinned-objects (vector)
+		    (copy-memory 
+		     (vector-sap vector) 
+		     (* length (size-of element-type))
+		     (pointer+ location offset)))))
+	  #'(lambda (vector location &optional (offset 0))
+	      (setf 
+	       (ref-pointer location offset)
+	       (with-pinned-objects (vector)
+		 (copy-memory (vector-sap vector) 
+		  (* (length vector) (size-of element-type)))))))))
+
+  (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (cond
+	((eq length '*)
+	 (error "Can't create reader function for vector with variable size"))
+	(inlined
+	 #'(lambda (location &optional (offset 0))
+	     (let ((vector (make-array length :element-type element-type)))
+	       (with-pinned-objects (vector)
+		 (copy-memory 
+		  (pointer+ location offset)
+		  (* length (size-of element-type))
+		  (vector-sap vector))
+		 vector))))
+	(t
+	 #'(lambda (location &optional (offset 0))
+	     (let ((vector (make-array length :element-type element-type)))
+	       (unless (null-pointer-p (ref-pointer location offset))
+		 (with-pinned-objects (vector)
+		   (copy-memory 
+		    (ref-pointer location offset)
+		    (* (length vector) (size-of element-type))
+		    (vector-sap vector)))
+		 (when (eq ref :get)
+		   (deallocate-memory (ref-pointer location offset))
+		   (setf (ref-pointer location offset) (make-pointer 0)))
+		 vector))))))))
+
+
+#-(or sbcl cmu)
+(progn
+  (define-type-method alien-arg-wrapper ((type unboxed-vector) var vector style form &optional copy-in-p)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (alien-arg-wrapper `(vector ,element-type ,length) var vector style form copy-in-p)))
+
+  (define-type-method to-alien-form ((type unboxed-vector) vector &optional copy-p)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (to-alien-form `(vector ,element-type ,length) vector copy-p)))
+
+  (define-type-method from-alien-form ((type unboxed-vector) form &key (ref :free))
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (from-alien-form `(vector ,element-type ,length) form :ref ref)))
+
+  (define-type-method writer-function ((type unboxed-vector) &key temp inlined)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (writer-function `(vector ,element-type ,length) :temp temp :inlined inlined)))
+
+  (define-type-method reader-function ((type unboxed-vector) &key (ref :read) inlined)
+    (check-unboxed-vector type)
+    (destructuring-bind (element-type &optional (length '*))
+	(rest (type-expand-to 'unboxed-vector type))
+      (reader-function `(vector ,element-type ,length) :ref ref :inlined inlined))))
+
+(define-type-method destroy-function ((type unboxed-vector) &key temp inlined)
+  (declare (ignore temp))
+  (check-unboxed-vector type)
+  (destructuring-bind (element-type &optional (length '*))
+      (rest (type-expand-to 'unboxed-vector type))
+    (cond
+     #+sbcl 
+     ((eq length '*)
+      (error "Can't create destroy function for vector with variable size"))
+     (inlined
+      #'(lambda (location &optional (offset 0))
+	  (clear-memory location (* length (size-of element-type)) offset)))
+     (t
+      #'(lambda (location &optional (offset 0))
+	  (unless (null-pointer-p (ref-pointer location offset))
+	    (deallocate-memory (ref-pointer location offset))
+	    (setf (ref-pointer location offset) (make-pointer 0))))))))
+
+
 ;;;; Null terminated vector
 
 (defun make-0-vector (type &key content location temp)
@@ -295,7 +514,7 @@ (defun map-0-vector (seqtype function location element-type &optional (ref :read
 
 (defun unset-0-vector (location element-type &optional temp-p)
   (loop
-   with destroy = (destroy-function element-type temp-p)
+   with destroy = (destroy-function element-type :temp temp-p)
    with element-size = (size-of element-type)
    for offset by element-size
    until (memory-clear-p (pointer+ location offset) element-size)
@@ -411,9 +630,9 @@ (define-type-method copy-function ((type vector0) &key inlined)
 		     for element by element-size
 		     until (memory-clear-p from-vector element-size element)
 		     finally (return length)))
-		   (to-vector (setf 
-			       (ref-pointer to offset)		  
-			       (allocate-memory (* length element-size)))))
+		   (to-vector 
+		    (setf (ref-pointer to offset)		  
+		     (allocate-memory (* (1+ length) element-size)))))
 	      (loop
 	       repeat length
 	       for element by element-size
@@ -575,3 +794,50 @@ (define-type-method copy-function ((type counted-vector) &key inlined)
 	       repeat length
 	       for element from counter-size by element-size
 	       do (funcall copy-element from-vector to-vector element))))))))
+
+
+;;;; Accessor functions for raw memory access
+
+(defun vector-reader-function (type &key (start 0) end)
+  "Returns a function for reading values from raw C vectors"
+  (let ((element-size (size-of type))
+	(reader (reader-function type)))
+    #'(lambda (vector index)
+	(assert (and (>= index start) (or (not end) (< index end))))
+	(funcall reader vector (* index element-size)))))
+
+(defun vector-writer-function (type &key (start 0) end)
+  "Returns a function for writing values to raw C vectors"
+  (let ((element-size (size-of type))
+	(writer (writer-function type)))
+    #'(lambda (value vector index)
+	(assert (and (>= index start) (or (not end) (< index end))))
+	(funcall writer value vector (* index element-size)))))
+
+
+(defmacro define-vector-accessor (type)
+  (let ((name (intern (format nil "VECTOR-REF-~A" type)))
+	(ref (intern (format nil "REF-~A" type))))
+    `(progn     
+       (declaim 
+	(ftype (function (pointer fixnum) ,type) ,name)
+	(inline ,name))
+       (defun ,name (vector index)
+	 (,ref vector (* ,(size-of type) index)))
+       (declaim 
+	(ftype (function (,type pointer fixnum) ,type) (setf ,name))
+	(inline (setf ,name)))
+       (defun (setf ,name) (value vector index)
+	 (setf (,ref vector (* ,(size-of type) index)) value)))))
+
+(define-vector-accessor int-8)
+(define-vector-accessor uint-8)
+(define-vector-accessor int-16)
+(define-vector-accessor uint-16)
+(define-vector-accessor int-32)
+(define-vector-accessor uint-32)
+(define-vector-accessor int-64)
+(define-vector-accessor uint-64)
+(define-vector-accessor double-float)
+(define-vector-accessor single-float)
+