# HG changeset patch # User Richard Westhaver # Date 1728072884 14400 # Node ID 2bad47888dbf0917701d602a795e12770f4791c5 # Parent a36280d2ef4e6ccf8920a37f12e87c96e6698942 add static-vector diff -r a36280d2ef4e -r 2bad47888dbf lisp/bin/skel.lisp --- a/lisp/bin/skel.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/bin/skel.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -181,7 +181,7 @@ (defcmd skc-make (let ((sk (find-skelfile #P"." :load t))) - (sb-ext:enable-debugger) + ;; (sb-ext:enable-debugger) (log:debug! "cli args" *args*) ;; (setq *no-exit* t) (if *args* diff -r a36280d2ef4e -r 2bad47888dbf lisp/ffi/sndfile/pkg.lisp --- a/lisp/ffi/sndfile/pkg.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/ffi/sndfile/pkg.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -13,6 +13,10 @@ (define-alien-loader "sndfile" t "/usr/lib/") +(define-opaque sndfile t) + +(define-opaque sf-chunk-iterator) + (define-alien-type sf-count long) (define-alien-type sf-info @@ -273,8 +277,6 @@ :set-add-dither-on-read #x1071) ;;; Functions -(define-opaque sndfile t) - (define-alien-routine sf-open (* sndfile) (path c-string) (mode int) (sfinfo (* sf-info))) (define-alien-routine sf-open-fd (* sndfile) (fd int) (mode int) (sfinfo (* sf-info))) (define-alien-routine sf-error int (sndfile (* sndfile))) @@ -309,8 +311,6 @@ (sndfile (* sndfile)) (chunk-info (* sf-chunk-info))) -(define-opaque sf-chunk-iterator) - (define-alien-routine sf-get-chunk-iterator (* sf-chunk-iterator) (sndfile (* sndfile)) (chunk-info (* sf-chunk-info))) diff -r a36280d2ef4e -r 2bad47888dbf lisp/lib/io/fast.lisp --- a/lisp/lib/io/fast.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/lib/io/fast.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -47,9 +47,10 @@ (type octet-vector vec) (type non-negative-fixnum pos vec-len new-pos)) ;; Only need to update if pos or new-pos is in stream range. - (when-let ((stream-update-needed? (or (> pos vec-len) - (> new-pos vec-len))) - (stream (input-buffer-stream buffer))) + (when-let ((stream (and + (or (> pos vec-len) + (> new-pos vec-len)) + (input-buffer-stream buffer)))) (let* ((stream-file-pos (file-position stream)) (pos-diff (- new-pos pos)) (stream-diff (cond ((and (> pos vec-len) @@ -78,12 +79,9 @@ (defun concat-buffer (buffer) (let* ((len (output-buffer-len buffer)) (array - #+fast-io-sv (if (eq :static (output-buffer-output buffer)) - (static-vectors:make-static-vector (the array-index len)) - (make-octet-vector len)) - #-fast-io-sv - (make-octet-vector len))) + (make-static-vector (the array-index len)) + (make-octet-vector len)))) (loop as i = 0 then (+ i (length a)) for a in (output-buffer-queue buffer) do (replace (the octet-vector array) @@ -369,7 +367,7 @@ ;; fast-stream -(defclass fast-io-stream (fundamental-stream) +(defclass fast-io-stream (sb-gray:fundamental-stream) ((openp :type boolean :initform t))) (defmethod stream-file-position ((stream fast-io-stream)) @@ -381,7 +379,7 @@ ;; fast-output-stream -(defclass fast-output-stream (fast-io-stream fundamental-output-stream) +(defclass fast-output-stream (fast-io-stream sb-gray:fundamental-output-stream) ((buffer :type output-buffer))) (defmethod initialize-instance ((self fast-output-stream) &key stream @@ -424,7 +422,7 @@ ;; fast-input-stream -(defclass fast-input-stream (fast-io-stream fundamental-input-stream) +(defclass fast-input-stream (fast-io-stream sb-gray:fundamental-input-stream) ((buffer :type input-buffer))) (defmethod initialize-instance ((self fast-input-stream) &key stream diff -r a36280d2ef4e -r 2bad47888dbf lisp/lib/io/pkg.lisp --- a/lisp/lib/io/pkg.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/lib/io/pkg.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -16,8 +16,26 @@ (:use :cl :std/condition) (:export :io-error)) +(defpackage :io/static-vector + (:use :cl :std :sb-alien) + (:shadow :constantp) + (:export + ;; Constructors and destructors + :make-static-vector + :free-static-vector + :with-static-vector + :with-static-vectors + ;; Accessors + :static-vector-pointer + ;; Alien wrapper type + :static-vector + ;; Foreign memory operations + :replace-foreign-memory + :fill-foreign-memory)) + (defpackage :io/fast (:use :cl :std :io/proto) + (:import-from :io/static-vector :make-static-vector) (:export #:fast-read-byte #:fast-write-byte #:fast-read-sequence #:fast-write-sequence diff -r a36280d2ef4e -r 2bad47888dbf lisp/lib/io/ring.lisp --- a/lisp/lib/io/ring.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/lib/io/ring.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -19,4 +19,3 @@ ;; (defun enter-io (ring)) ;; (defun exit-io (ring)) - 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))) + diff -r a36280d2ef4e -r 2bad47888dbf lisp/lib/packy/pkg.lisp --- a/lisp/lib/packy/pkg.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/lib/packy/pkg.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -4,7 +4,7 @@ ;;; Code: (defpackage :packy/core - (:use :cl :std :obj/id :dat/proto) + (:use :cl :std :obj/id :dat/proto :io/flate) (:export :*packy-url* :pack diff -r a36280d2ef4e -r 2bad47888dbf lisp/lib/skel/core/obj.lisp --- a/lisp/lib/skel/core/obj.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/lib/skel/core/obj.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -303,17 +303,6 @@ (write (sk-rule-source self) :stream stream) (write (sk-rule-recipe self) :stream stream))) -(defun sk-run-with-sources (obj rule) - (when-let ((sources (sk-rule-source rule))) - (mapcar - (lambda (src) - (if-let* ((sr (sk-find-rule src obj))) - ;; TODO: check if we need to rerun sources - (sk-make obj sr) - (warn! "unhandled source:" src "for rule:" rule))) - sources)) - (sk-run rule)) - (defun sk-make (obj &rest rules) (if rules (mapc @@ -325,6 +314,17 @@ (sk-make obj rule) (sk-run rule)))))) +(defun sk-run-with-sources (obj rule) + (when-let ((sources (sk-rule-source rule))) + (mapcar + (lambda (src) + (if-let* ((sr (sk-find-rule src obj))) + ;; TODO: check if we need to rerun sources + (sk-make obj sr) + (error "unhandled source: ~A for rule ~A" src rule))) + sources)) + (sk-run rule)) + ;;; Version Control (defstruct sk-vc-remote-meta (name :default :type keyword) diff -r a36280d2ef4e -r 2bad47888dbf lisp/lisp.sk --- a/lisp/lisp.sk Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/lisp.sk Fri Oct 04 16:14:44 2024 -0400 @@ -1,6 +1,5 @@ ;;; lisp.sk --- core/lisp skelfile -*- mode: skel; -*- :name "core/lisp" -:src "lisp" :description "CC Lisp Core" :components ((:asd "prelude") diff -r a36280d2ef4e -r 2bad47888dbf lisp/std/alien.lisp --- a/lisp/std/alien.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/std/alien.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -54,7 +54,8 @@ (defmacro define-opaque (ty &optional no-export foreign-type) `(prog1 - (define-alien-type ,ty (struct ,(or foreign-type (symbolicate ty '-t)))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (define-alien-type ,ty (struct ,(or foreign-type (symbolicate ty '-t))))) ,(unless no-export `(export '(,ty))))) (defun setfa (place from) @@ -216,3 +217,5 @@ (define-alien-type loff-t long-long) (define-alien-routine memset void (ptr (* t)) (constant int) (size size-t)) +(define-alien-routine memcpy void (dst (* t)) (src (* t)) (size size-t)) +(define-alien-routine posix-memalign int (box (* t)) (alignment size-t) (size size-t)) diff -r a36280d2ef4e -r 2bad47888dbf lisp/std/pkg.lisp --- a/lisp/std/pkg.lisp Thu Oct 03 21:54:07 2024 -0400 +++ b/lisp/std/pkg.lisp Fri Oct 04 16:14:44 2024 -0400 @@ -94,9 +94,84 @@ (:import-from :std/list :ensure-car) (:export :+default-element-type+ :array-index :array-length - :negative-integer :non-negative-integer - :positive-integer :octet - :octet-vector)) + #:negative-double-float + #:negative-fixnum-p + #:negative-float + #:negative-float-p + #:negative-long-float + #:negative-long-float-p + #:negative-rational + #:negative-rational-p + #:negative-real + #:negative-single-float-p + #:non-negative-double-float + #:non-negative-double-float-p + #:non-negative-fixnum + #:non-negative-fixnum-p + #:non-negative-float + #:non-negative-float-p + #:non-negative-integer-p + #:non-negative-long-float + #:non-negative-rational + #:non-negative-real-p + #:non-negative-short-float-p + #:non-negative-single-float + #:non-negative-single-float-p + #:non-positive-double-float + #:non-positive-double-float-p + #:non-positive-fixnum + #:non-positive-fixnum-p + #:non-positive-float + #:non-positive-float-p + #:non-positive-integer + #:non-positive-rational + #:non-positive-real + #:non-positive-real-p + #:non-positive-short-float + #:non-positive-short-float-p + #:non-positive-single-float-p + #:positive-double-float + #:positive-double-float-p + #:positive-fixnum + #:positive-fixnum-p + #:positive-float + #:positive-float-p + #:positive-integer + #:positive-rational + #:positive-real + #:positive-real-p + #:positive-short-float + #:positive-short-float-p + #:positive-single-float + #:positive-single-float-p + :negative-integer + #:negative-double-float-p + #:negative-fixnum + #:negative-integer + #:negative-integer-p + #:negative-real-p + #:negative-short-float + #:negative-short-float-p + #:negative-single-float + #:non-negative-integer + #:non-negative-long-float-p + #:non-negative-rational-p + #:non-negative-real + #:non-negative-short-float + #:non-positive-integer-p + #:non-positive-long-float + #:non-positive-long-float-p + #:non-positive-rational-p + #:non-positive-single-float + :coercef + :octet + :octet-vector + #:positive-integer-p + #:positive-long-float + #:positive-long-float-p + #:positive-rational-p + :of-type + :type=)) (defpkg :std/num (:use :cl) @@ -172,7 +247,9 @@ :num-cpus :*cpus* :loff-t - :memset)) + :memset + :memcpy + :posix-memalign)) (defpkg :std/mop (:use :cl :sb-mop :sb-pcl)