X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/f9a67e67a8f4e4f7bfca09d095098a78579685a1..6dfb20397142408cc4adfa437bb12d8aa300270e:/gffi/vectors.lisp diff --git a/gffi/vectors.lisp b/gffi/vectors.lisp index 1a9313e..8364033 100644 --- a/gffi/vectors.lisp +++ b/gffi/vectors.lisp @@ -20,7 +20,7 @@ ;; 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.6 2008-04-11 20:19:09 espen Exp $ +;; $Id: vectors.lisp,v 1.9 2008-12-10 02:41:40 espen Exp $ (in-package "GFFI") @@ -44,16 +44,23 @@ (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)))) @@ -64,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 @@ -75,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) @@ -285,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)