[cffi-devel] Static vectors suitable for FFI

[Stelian Ionescu]

Attached is an implementation for SBCL. make-static-vector only
allocates instances of (simple-array (unsigned-byte 8) (*)) but that can
be extended to other unboxed arrays.
The current sharable vector interface doesn't work very well because it
doesn't allow me for instance to pin a list of vectors, but only a
single vector at a time. Also, I'd prefer to avoid pinning at all given
how it interferes with the GC.

-- 
Stelian Ionescu a.k.a. fe[nl]ix
Quidquid latine dictum sit, altum videtur.

-------------- next part --------------
(in-package :cffi)

(declaim (inline fill-foreign-memory))
(defun fill-foreign-memory (pointer length value)
  "Fill LENGTH octets in foreign memory area POINTER with VALUE."
  (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
  (sb-kernel:system-area-ub8-fill value pointer 0 length))

(declaim (inline copy-foreign-memory))
(defun copy-foreign-memory (src-ptr dst-ptr length)
  "Copy LENGTH octets from foreign memory area SRC-PTR to DST-PTR."
  (sb-kernel:system-area-ub8-copy src-ptr 0 dst-ptr 0 length))

(defconstant +array-header-size+ (* 2 sb-vm:n-word-bytes))

(defun make-static-vector (size)
  "Create an (UNSIGNED-BYTE 8) simple vector of size SIZE which will
not be moved by the garbage collector. The vector might be allocated in
foreign memory so you must always call FREE-STATIC-VECTOR to free it."
  (declare (sb-ext:muffle-conditions sb-ext:compiler-note)
           (optimize speed))
  (check-type size alexandria:non-negative-fixnum)
  (let* ((allocation-size (+ size +array-header-size+))
         (memblock (foreign-alloc :char :count allocation-size)))
    (cond
      ((null-pointer-p memblock)
       ;; FIXME: signal proper error condition
       (error "Cannot allocate foreign memory!"))
      (t
       ;; the malloc'd memory must be aligned on a 2-word boundary
       ;; I'd expect malloc() to return a properly aligned pointer everywhere
       ;; but I'm not certain. SIONESCU 20090505
       (assert (zerop (mod (pointer-address memblock) (* 2 sb-vm:n-word-bytes))))
       (fill-foreign-memory memblock allocation-size 0)
       (let ((type-tag sb-vm:simple-array-unsigned-byte-8-widetag)
             (length (sb-vm:fixnumize size)))
         (setf (mem-aref memblock :int 0) type-tag
               (mem-aref memblock :int 1) length)
         (sb-kernel:%make-lisp-obj (logior (pointer-address memblock)
                                           sb-vm:other-pointer-lowtag)))))))

(declaim (inline static-vector-pointer))
(defun static-vector-pointer (vector)
  "Return a foreign pointer to VECTOR's data.
VECTOR must be a vector created by MAKE-STATIC-VECTOR."
  (make-pointer (sb-kernel:get-lisp-obj-address vector)))

(declaim (inline free-static-vector))
(defun free-static-vector (vector)
  "Free VECTOR if allocated in foreign memory."
  (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
  (let ((pointer (static-vector-pointer vector)))
    (foreign-free (inc-pointer pointer (- 1 +array-header-size+)))))

(defmacro with-static-vector ((ptr-var size) &body body)
  "Bind PTR-VAR to a static vector of size SIZE and execute BODY
within its dynamic extent. The static vector is freed upon exit."
  (alexandria:with-gensyms (static-vector)
    `(let* ((,static-vector (make-static-vector ,size))
            (,ptr-var (static-vector-pointer ,static-vector)))
       (unwind-protect
            (progn , at body)
         (free-static-vector ,static-vector)))))
-------------- next part --------------
A non-text attachment was scrubbed...
Name: signature.asc
Type: application/pgp-signature
Size: 198 bytes
Desc: This is a digitally signed message part
URL: <https://mailman.common-lisp.net/pipermail/cffi-devel/attachments/20090505/4867f883/attachment.sig>