;; 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")
(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))))
&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
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)
(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)
~mdw / clg / blobdiff