;;; static-vector.lisp --- Static Vectors

 ;; Vectors allocated in static memory. Useful for things like IO buffers

 ;; created from Lisp and shared with C code.

 ;;; Commentary:

 ;; The source here is pulled directly from the STATIC-VECTORS package on

 ;; Quicklisp: https://github.com/sionescu/static-vectors

 ;;; Code:

 (in-package :io/static-vector)

 ;;; --- Checking for compile-time constants and evaluating such forms

 (defun quotedp (form)

   (and (listp form)

        (= 2 (length form))

        (eql 'quote (car form))))

 (defun constantp (form &optional env)

   (let ((form (if (symbolp form)

                   (macroexpand form env)

                   form)))

     (or (quotedp form)

         (cl:constantp form))))

 (defun eval-constant (form &optional env)

   (declare (ignorable env))

   (cond

     ((quotedp form)

      (second form))

     (t

      #+clozure

      (ccl::eval-constant form)

      #+sbcl

      (sb-int:constant-form-value form env)

      #-(or clozure sbcl)

      (eval form))))

 (defun canonicalize-args (env element-type length)

   (let* ((eltype-spec (or (and (constantp element-type)

                                (ignore-errors

                                 (upgraded-array-element-type

                                  (eval-constant element-type))))

                           '*))

          (length-spec (if (constantp length env)

                           `,(eval-constant length env)

                           '*))

          (type-decl (if (eql '* eltype-spec)

                         'simple-array

                         `(simple-array ,eltype-spec (,length-spec)))))

     (values (if (eql '* eltype-spec)

                 element-type

                 `(quote ,eltype-spec))

             (if (eql '* length-spec)

                 length

                 length-spec)

             type-decl)))

 ;;; --- SBCL implementation

 (declaim (inline fill-foreign-memory))

 (defun fill-foreign-memory (pointer length value)

   "Fill LENGTH octets in foreign memory area POINTER with VALUE."

   (std/alien:memset pointer value length)

   pointer)

 (declaim (inline replace-foreign-memory))

 (defun replace-foreign-memory (dst-ptr src-ptr length)

   "Copy LENGTH octets from foreign memory area SRC-PTR to DST-PTR."

   (std/alien:memcpy dst-ptr src-ptr length)

   dst-ptr)

 ;;; We have to handle all the low-level bits including setting the array header

 ;;; and keeping around the info about the original pointer returned by the

 ;;; foreign allocator.

 ;;;

 ;;; It goes like this:

 ;;;

 ;;; 1. Compute the data size for the Lisp-visible memory (that means an extra #\Nul

 ;;;    at the end for strings)

 ;;; 2. Sum the data size, the SBCL header size, and our extra header size to get

 ;;;    the total foreign size required

 ;;; 3. Adjust the total foreign size to the required alignment, compute the header offset

 ;;;    and write the headers.

 ;;;

 ;;; Array layout:

 ;;;

 ;;;    +-------------------+

 ;;;    | Allocated address | <-- Original pointer

 ;;;    +-------------------+

 ;;;    | Start gap ...     | <-- For large alignments, there's a gap between

 ;;;    |                   |     the data block and the headers.

 ;;;    +-------------------+

 ;;;    | SV header         | <-- The offset from the original pointer (DWORD)

 ;;;    +-------------------+

 ;;;    | Lisp array header | <-- Array element-type and size (DWORD)

 ;;;    +-------------------+

 ;;;    | Lisp array data   | <-- Lisp-visible data

 ;;;    +-------------------+

 ;;;

 ;;; There's no end gap because when a alignment is requested,

 ;;; the requested size must also be a multiple of the alignment.

 (defconstant +array-header-size+

   (* sb-vm:vector-data-offset sb-vm:n-word-bytes))

 (declaim (inline vector-widetag-and-n-bytes))

 (defun vector-widetag-and-n-bytes (type)

   "Returns the widetag and octet size of the upgraded array element type

 for a given type specifier."

   (let ((upgraded-type (upgraded-array-element-type type)))

     (case upgraded-type

       ((nil t) (error "~A is not a specializable array element type" type))

       (t

        #+#.(cl:if (cl:find-symbol "%VECTOR-WIDETAG-AND-N-BITS" "SB-IMPL")

                   '(and) '(or))

        (sb-impl::%vector-widetag-and-n-bits type)

        #+#.(cl:if (cl:find-symbol "%VECTOR-WIDETAG-AND-N-BITS-SHIFT" "SB-IMPL")

                   '(and) '(or))

        (multiple-value-bind (widetag shift)

            (sb-impl::%vector-widetag-and-n-bits-shift type)

          (values widetag (expt 2 (- shift 3))))))))

 (declaim (inline align))

 (defun align (size boundary)

   (* boundary

      (ceiling size boundary)))

 (declaim (inline %memalign))

 (defun %memalign (size alignment)

   (with-alien ((box (* t)))

     (let ((errno (std/alien:posix-memalign box alignment size)))

       (when (not (zerop errno))

         (error "posix_memalign() returned error ~A" errno))

       ;; (mem-ref box :pointer)

       (deref box))))

 (defun %allocate-static-vector (length element-type alignment)

   (declare (type (unsigned-byte 16) alignment))

   (flet ((allocation-sizes (length widetag n-bytes)

            (values

             ;; We're allocating two headers: one for SBCL and

             ;; the other one for our bookkeeping.

             (align (* 2 +array-header-size+) alignment)

             ;; Align data size.

             (align

              (* (if (= widetag sb-vm:simple-character-string-widetag)

                     (1+ length)         ; for the final #\Nul

                     length)

                 n-bytes)

              alignment))))

     (multiple-value-bind (widetag n-bytes)

         (vector-widetag-and-n-bytes element-type)

       (multiple-value-bind (header-size data-size)

           (allocation-sizes length widetag n-bytes)

         (let* ((total-size (+ header-size data-size))

                (foreign-block (%memalign total-size alignment))

                (data-offset header-size )

                (lisp-header-offset

                  (- data-offset +array-header-size+))

                (lisp-header-pointer

                  (sb-sys:sap+ foreign-block lisp-header-offset))

                (extra-header-offset

                  (- data-offset (* 2 +array-header-size+)))

                (extra-header-pointer

                  (sb-sys:sap+ foreign-block extra-header-offset)))

           ;; Write Lisp header: tag and length

           (setf (sb-sys:sap-ref-word lisp-header-pointer 0) widetag)

           (setf (sb-sys:sap-ref-word lisp-header-pointer sb-vm:n-word-bytes)

                 (sb-vm:fixnumize length))

           ;; Save the relative position from the start of the foreign block

           (setf (sb-sys:sap-ref-word extra-header-pointer 0)

                 (- data-offset (* 2 +array-header-size+)))

           ;; Instantiate Lisp object

           (sb-kernel:%make-lisp-obj (logior (sb-sys:sap-int lisp-header-pointer)

                                             sb-vm:other-pointer-lowtag)))))))

 (declaim (inline static-vector-address))

 (defun static-vector-address (vector)

   "Return a foreign pointer to start of the Lisp VECTOR(including its header).

 VECTOR must be a vector created by MAKE-STATIC-VECTOR."

   (logandc2 (sb-kernel:get-lisp-obj-address vector)

             sb-vm:lowtag-mask))

 (declaim (inline static-vector-pointer))

 (defun static-vector-pointer (vector &key (offset 0))

   "Return a foreign pointer to the beginning of VECTOR + OFFSET octets.

 VECTOR must be a vector created by MAKE-STATIC-VECTOR."

   (check-type offset unsigned-byte)

   (sb-sys:int-sap (+ (static-vector-address vector)

                    +array-header-size+

                    offset)))

 (declaim (inline free-static-vector))

 (defun free-static-vector (vector)

   "Free VECTOR, which must be a vector created by MAKE-STATIC-VECTOR."

   (declare (sb-ext:muffle-conditions sb-ext:compiler-note))

   (let* ((extra-header-pointer

            (sb-sys:int-sap (- (static-vector-address vector) +array-header-size+)))

          (start-offset

            (sb-sys:sap-ref-word extra-header-pointer 0)))

     (free-alien (sap-alien (sb-sys:sap+ extra-header-pointer (- start-offset)) (* (unsigned 8)))))

   (values))

 (defmacro with-static-vector ((var length &rest args

                                &key (element-type ''(unsigned-byte 8))

                                  initial-contents initial-element)

                               &body body &environment env)

   "Bind PTR-VAR to a static vector of length LENGTH and execute BODY

 within its dynamic extent. The vector is freed upon exit."

   (declare (ignorable element-type initial-contents initial-element))

   (multiple-value-bind (real-element-type length type-spec)

       (canonicalize-args env element-type length)

     (let ((args (copy-list args)))

       (remf args :element-type)

       `(sb-sys:without-interrupts

          (let ((,var (make-static-vector ,length ,@args

                                          :element-type ,real-element-type)))

            (declare (type ,type-spec ,var))

            (unwind-protect

                 (sb-sys:with-local-interrupts ,@body)

              (when ,var (free-static-vector ,var))))))))

 ;;; --- MAKE-STATIC-VECTOR

 (declaim (inline check-initial-element))

 (defun check-initial-element (element-type initial-element)

   (when (not (typep initial-element element-type))

     ;; FIXME: signal SUBTYPE-ERROR

     (error "MAKE-STATIC-VECTOR: The type of :INITIAL-ELEMENT ~S is not a subtype ~

 of the array's :ELEMENT-TYPE ~S"

            initial-element element-type)))

 (declaim (inline check-initial-contents))

 (defun check-initial-contents (length initial-contents)

   (let ((initial-contents-length (length initial-contents)))

     (when (/= length initial-contents-length)

       ;; FIXME: signal TYPE-ERROR

       (error "MAKE-STATIC-VECTOR: There are ~A elements in the :INITIAL-CONTENTS, ~

 but requested vector length is ~A."

              initial-contents-length length))))

 (declaim (inline check-initialization-arguments))

 (defun check-initialization-arguments (initial-element-p initial-contents-p)

   (when (and initial-element-p initial-contents-p)

     ;; FIXME: signal ARGUMENT-LIST-ERROR

     (error "MAKE-STATIC-VECTOR: You must not specify both ~

 :INITIAL-ELEMENT and :INITIAL-CONTENTS")))

 (defun check-arguments (length element-type

                         initial-element initial-element-p

                         initial-contents initial-contents-p)

   (check-initialization-arguments initial-element-p initial-contents-p)

   (check-type length non-negative-fixnum)

   (when initial-element-p

     (check-initial-element element-type initial-element))

   (when initial-contents-p

     (check-initial-contents length initial-contents)))

 (defconstant +default-alignment+ 16)

 (defconstant +max-alignment+ 4096)

 (declaim (inline make-static-vector))

 (defun make-static-vector (length &key (element-type '(unsigned-byte 8))

                            (initial-element nil initial-element-p)

                            (initial-contents nil initial-contents-p)

                            (alignment nil alignp))

   "Create a simple vector of length LENGTH and type ELEMENT-TYPE 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 #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)

            (optimize speed))

   (check-arguments length element-type initial-element initial-element-p

                    initial-contents initial-contents-p)

   (when alignp

     ;; Check that the alignment is a power of 2 beteeen 16 and 4096.

     #+(and sbcl unix)

     (assert (and (<= +default-alignment+ alignment +max-alignment+)

                  (= 1 (logcount alignment))))

     #-(and sbcl unix)

     (error "Allocation alignment not supported on this implementation."))

   ;; TODO: fix %allocate-static-vector for all implementations

   (let ((vector

           (%allocate-static-vector length element-type

                                    #+sbcl

                                    (or alignment +default-alignment+))))

     (if initial-element-p

         (fill vector initial-element)

         (replace vector initial-contents))))

 (defmacro with-static-vectors (((var length &rest args) &rest more-clauses)

                                &body body)

   "Allocate multiple static vectors at once."

   `(with-static-vector (,var ,length ,@args)

      ,@(if more-clauses

            `((with-static-vectors ,more-clauses

                ,@body))

            body)))