1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/lisp/lib/io/static-vector.lisp Fri Oct 04 16:14:44 2024 -0400
1.3@@ -0,0 +1,299 @@
1.4+;;; static-vector.lisp --- Static Vectors
1.5+
1.6+;; Vectors allocated in static memory. Useful for things like IO buffers
1.7+;; created from Lisp and shared with C code.
1.8+
1.9+;;; Commentary:
1.10+
1.11+;; The source here is pulled directly from the STATIC-VECTORS package on
1.12+;; Quicklisp: https://github.com/sionescu/static-vectors
1.13+
1.14+;;; Code:
1.15+(in-package :io/static-vector)
1.16+;;; --- Checking for compile-time constants and evaluating such forms
1.17+
1.18+(defun quotedp (form)
1.19+ (and (listp form)
1.20+ (= 2 (length form))
1.21+ (eql 'quote (car form))))
1.22+
1.23+(defun constantp (form &optional env)
1.24+ (let ((form (if (symbolp form)
1.25+ (macroexpand form env)
1.26+ form)))
1.27+ (or (quotedp form)
1.28+ (cl:constantp form))))
1.29+
1.30+(defun eval-constant (form &optional env)
1.31+ (declare (ignorable env))
1.32+ (cond
1.33+ ((quotedp form)
1.34+ (second form))
1.35+ (t
1.36+ #+clozure
1.37+ (ccl::eval-constant form)
1.38+ #+sbcl
1.39+ (sb-int:constant-form-value form env)
1.40+ #-(or clozure sbcl)
1.41+ (eval form))))
1.42+
1.43+(defun canonicalize-args (env element-type length)
1.44+ (let* ((eltype-spec (or (and (constantp element-type)
1.45+ (ignore-errors
1.46+ (upgraded-array-element-type
1.47+ (eval-constant element-type))))
1.48+ '*))
1.49+ (length-spec (if (constantp length env)
1.50+ `,(eval-constant length env)
1.51+ '*))
1.52+ (type-decl (if (eql '* eltype-spec)
1.53+ 'simple-array
1.54+ `(simple-array ,eltype-spec (,length-spec)))))
1.55+ (values (if (eql '* eltype-spec)
1.56+ element-type
1.57+ `(quote ,eltype-spec))
1.58+ (if (eql '* length-spec)
1.59+ length
1.60+ length-spec)
1.61+ type-decl)))
1.62+
1.63+;;; --- SBCL implementation
1.64+(declaim (inline fill-foreign-memory))
1.65+(defun fill-foreign-memory (pointer length value)
1.66+ "Fill LENGTH octets in foreign memory area POINTER with VALUE."
1.67+ (std/alien:memset pointer value length)
1.68+ pointer)
1.69+
1.70+(declaim (inline replace-foreign-memory))
1.71+(defun replace-foreign-memory (dst-ptr src-ptr length)
1.72+ "Copy LENGTH octets from foreign memory area SRC-PTR to DST-PTR."
1.73+ (std/alien:memcpy dst-ptr src-ptr length)
1.74+ dst-ptr)
1.75+
1.76+;;; We have to handle all the low-level bits including setting the array header
1.77+;;; and keeping around the info about the original pointer returned by the
1.78+;;; foreign allocator.
1.79+;;;
1.80+;;; It goes like this:
1.81+;;;
1.82+;;; 1. Compute the data size for the Lisp-visible memory (that means an extra #\Nul
1.83+;;; at the end for strings)
1.84+;;; 2. Sum the data size, the SBCL header size, and our extra header size to get
1.85+;;; the total foreign size required
1.86+;;; 3. Adjust the total foreign size to the required alignment, compute the header offset
1.87+;;; and write the headers.
1.88+;;;
1.89+;;; Array layout:
1.90+;;;
1.91+;;; +-------------------+
1.92+;;; | Allocated address | <-- Original pointer
1.93+;;; +-------------------+
1.94+;;; | Start gap ... | <-- For large alignments, there's a gap between
1.95+;;; | | the data block and the headers.
1.96+;;; +-------------------+
1.97+;;; | SV header | <-- The offset from the original pointer (DWORD)
1.98+;;; +-------------------+
1.99+;;; | Lisp array header | <-- Array element-type and size (DWORD)
1.100+;;; +-------------------+
1.101+;;; | Lisp array data | <-- Lisp-visible data
1.102+;;; +-------------------+
1.103+;;;
1.104+;;; There's no end gap because when a alignment is requested,
1.105+;;; the requested size must also be a multiple of the alignment.
1.106+
1.107+(defconstant +array-header-size+
1.108+ (* sb-vm:vector-data-offset sb-vm:n-word-bytes))
1.109+
1.110+(declaim (inline vector-widetag-and-n-bytes))
1.111+(defun vector-widetag-and-n-bytes (type)
1.112+ "Returns the widetag and octet size of the upgraded array element type
1.113+for a given type specifier."
1.114+ (let ((upgraded-type (upgraded-array-element-type type)))
1.115+ (case upgraded-type
1.116+ ((nil t) (error "~A is not a specializable array element type" type))
1.117+ (t
1.118+ #+#.(cl:if (cl:find-symbol "%VECTOR-WIDETAG-AND-N-BITS" "SB-IMPL")
1.119+ '(and) '(or))
1.120+ (sb-impl::%vector-widetag-and-n-bits type)
1.121+ #+#.(cl:if (cl:find-symbol "%VECTOR-WIDETAG-AND-N-BITS-SHIFT" "SB-IMPL")
1.122+ '(and) '(or))
1.123+ (multiple-value-bind (widetag shift)
1.124+ (sb-impl::%vector-widetag-and-n-bits-shift type)
1.125+ (values widetag (expt 2 (- shift 3))))))))
1.126+
1.127+(declaim (inline align))
1.128+(defun align (size boundary)
1.129+ (* boundary
1.130+ (ceiling size boundary)))
1.131+
1.132+(declaim (inline %memalign))
1.133+(defun %memalign (size alignment)
1.134+ (with-alien ((box (* t)))
1.135+ (let ((errno (std/alien:posix-memalign box alignment size)))
1.136+ (when (not (zerop errno))
1.137+ (error "posix_memalign() returned error ~A" errno))
1.138+ ;; (mem-ref box :pointer)
1.139+ (deref box))))
1.140+
1.141+(defun %allocate-static-vector (length element-type alignment)
1.142+ (declare (type (unsigned-byte 16) alignment))
1.143+ (flet ((allocation-sizes (length widetag n-bytes)
1.144+ (values
1.145+ ;; We're allocating two headers: one for SBCL and
1.146+ ;; the other one for our bookkeeping.
1.147+ (align (* 2 +array-header-size+) alignment)
1.148+ ;; Align data size.
1.149+ (align
1.150+ (* (if (= widetag sb-vm:simple-character-string-widetag)
1.151+ (1+ length) ; for the final #\Nul
1.152+ length)
1.153+ n-bytes)
1.154+ alignment))))
1.155+ (multiple-value-bind (widetag n-bytes)
1.156+ (vector-widetag-and-n-bytes element-type)
1.157+ (multiple-value-bind (header-size data-size)
1.158+ (allocation-sizes length widetag n-bytes)
1.159+ (let* ((total-size (+ header-size data-size))
1.160+ (foreign-block (%memalign total-size alignment))
1.161+ (data-offset header-size )
1.162+ (lisp-header-offset
1.163+ (- data-offset +array-header-size+))
1.164+ (lisp-header-pointer
1.165+ (sb-sys:sap+ foreign-block lisp-header-offset))
1.166+ (extra-header-offset
1.167+ (- data-offset (* 2 +array-header-size+)))
1.168+ (extra-header-pointer
1.169+ (sb-sys:sap+ foreign-block extra-header-offset)))
1.170+ ;; Write Lisp header: tag and length
1.171+ (setf (sb-sys:sap-ref-word lisp-header-pointer 0) widetag)
1.172+ (setf (sb-sys:sap-ref-word lisp-header-pointer sb-vm:n-word-bytes)
1.173+ (sb-vm:fixnumize length))
1.174+ ;; Save the relative position from the start of the foreign block
1.175+ (setf (sb-sys:sap-ref-word extra-header-pointer 0)
1.176+ (- data-offset (* 2 +array-header-size+)))
1.177+ ;; Instantiate Lisp object
1.178+ (sb-kernel:%make-lisp-obj (logior (sb-sys:sap-int lisp-header-pointer)
1.179+ sb-vm:other-pointer-lowtag)))))))
1.180+
1.181+(declaim (inline static-vector-address))
1.182+(defun static-vector-address (vector)
1.183+ "Return a foreign pointer to start of the Lisp VECTOR(including its header).
1.184+VECTOR must be a vector created by MAKE-STATIC-VECTOR."
1.185+ (logandc2 (sb-kernel:get-lisp-obj-address vector)
1.186+ sb-vm:lowtag-mask))
1.187+
1.188+(declaim (inline static-vector-pointer))
1.189+(defun static-vector-pointer (vector &key (offset 0))
1.190+ "Return a foreign pointer to the beginning of VECTOR + OFFSET octets.
1.191+VECTOR must be a vector created by MAKE-STATIC-VECTOR."
1.192+ (check-type offset unsigned-byte)
1.193+ (sb-sys:int-sap (+ (static-vector-address vector)
1.194+ +array-header-size+
1.195+ offset)))
1.196+
1.197+(declaim (inline free-static-vector))
1.198+(defun free-static-vector (vector)
1.199+ "Free VECTOR, which must be a vector created by MAKE-STATIC-VECTOR."
1.200+ (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
1.201+ (let* ((extra-header-pointer
1.202+ (sb-sys:int-sap (- (static-vector-address vector) +array-header-size+)))
1.203+ (start-offset
1.204+ (sb-sys:sap-ref-word extra-header-pointer 0)))
1.205+ (free-alien (sap-alien (sb-sys:sap+ extra-header-pointer (- start-offset)) (* (unsigned 8)))))
1.206+ (values))
1.207+
1.208+(defmacro with-static-vector ((var length &rest args
1.209+ &key (element-type ''(unsigned-byte 8))
1.210+ initial-contents initial-element)
1.211+ &body body &environment env)
1.212+ "Bind PTR-VAR to a static vector of length LENGTH and execute BODY
1.213+within its dynamic extent. The vector is freed upon exit."
1.214+ (declare (ignorable element-type initial-contents initial-element))
1.215+ (multiple-value-bind (real-element-type length type-spec)
1.216+ (canonicalize-args env element-type length)
1.217+ (let ((args (copy-list args)))
1.218+ (remf args :element-type)
1.219+ `(sb-sys:without-interrupts
1.220+ (let ((,var (make-static-vector ,length ,@args
1.221+ :element-type ,real-element-type)))
1.222+ (declare (type ,type-spec ,var))
1.223+ (unwind-protect
1.224+ (sb-sys:with-local-interrupts ,@body)
1.225+ (when ,var (free-static-vector ,var))))))))
1.226+
1.227+
1.228+;;; --- MAKE-STATIC-VECTOR
1.229+(declaim (inline check-initial-element))
1.230+(defun check-initial-element (element-type initial-element)
1.231+ (when (not (typep initial-element element-type))
1.232+ ;; FIXME: signal SUBTYPE-ERROR
1.233+ (error "MAKE-STATIC-VECTOR: The type of :INITIAL-ELEMENT ~S is not a subtype ~
1.234+of the array's :ELEMENT-TYPE ~S"
1.235+ initial-element element-type)))
1.236+
1.237+(declaim (inline check-initial-contents))
1.238+(defun check-initial-contents (length initial-contents)
1.239+ (let ((initial-contents-length (length initial-contents)))
1.240+ (when (/= length initial-contents-length)
1.241+ ;; FIXME: signal TYPE-ERROR
1.242+ (error "MAKE-STATIC-VECTOR: There are ~A elements in the :INITIAL-CONTENTS, ~
1.243+but requested vector length is ~A."
1.244+ initial-contents-length length))))
1.245+
1.246+(declaim (inline check-initialization-arguments))
1.247+(defun check-initialization-arguments (initial-element-p initial-contents-p)
1.248+ (when (and initial-element-p initial-contents-p)
1.249+ ;; FIXME: signal ARGUMENT-LIST-ERROR
1.250+ (error "MAKE-STATIC-VECTOR: You must not specify both ~
1.251+:INITIAL-ELEMENT and :INITIAL-CONTENTS")))
1.252+
1.253+(defun check-arguments (length element-type
1.254+ initial-element initial-element-p
1.255+ initial-contents initial-contents-p)
1.256+ (check-initialization-arguments initial-element-p initial-contents-p)
1.257+ (check-type length non-negative-fixnum)
1.258+ (when initial-element-p
1.259+ (check-initial-element element-type initial-element))
1.260+ (when initial-contents-p
1.261+ (check-initial-contents length initial-contents)))
1.262+
1.263+(defconstant +default-alignment+ 16)
1.264+(defconstant +max-alignment+ 4096)
1.265+
1.266+(declaim (inline make-static-vector))
1.267+(defun make-static-vector (length &key (element-type '(unsigned-byte 8))
1.268+ (initial-element nil initial-element-p)
1.269+ (initial-contents nil initial-contents-p)
1.270+ (alignment nil alignp))
1.271+ "Create a simple vector of length LENGTH and type ELEMENT-TYPE which will
1.272+not be moved by the garbage collector. The vector might be allocated in
1.273+foreign memory so you must always call FREE-STATIC-VECTOR to free it."
1.274+ (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)
1.275+ (optimize speed))
1.276+ (check-arguments length element-type initial-element initial-element-p
1.277+ initial-contents initial-contents-p)
1.278+ (when alignp
1.279+ ;; Check that the alignment is a power of 2 beteeen 16 and 4096.
1.280+ #+(and sbcl unix)
1.281+ (assert (and (<= +default-alignment+ alignment +max-alignment+)
1.282+ (= 1 (logcount alignment))))
1.283+ #-(and sbcl unix)
1.284+ (error "Allocation alignment not supported on this implementation."))
1.285+ ;; TODO: fix %allocate-static-vector for all implementations
1.286+ (let ((vector
1.287+ (%allocate-static-vector length element-type
1.288+ #+sbcl
1.289+ (or alignment +default-alignment+))))
1.290+ (if initial-element-p
1.291+ (fill vector initial-element)
1.292+ (replace vector initial-contents))))
1.293+
1.294+(defmacro with-static-vectors (((var length &rest args) &rest more-clauses)
1.295+ &body body)
1.296+ "Allocate multiple static vectors at once."
1.297+ `(with-static-vector (,var ,length ,@args)
1.298+ ,@(if more-clauses
1.299+ `((with-static-vectors ,more-clauses
1.300+ ,@body))
1.301+ body)))
1.302+
