diff -r a36280d2ef4e -r 2bad47888dbf lisp/lib/io/static-vector.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/lib/io/static-vector.lisp	Fri Oct 04 16:14:44 2024 -0400
@@ -0,0 +1,299 @@
+;;; 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)))
+