1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/lisp/lib/io/fast.lisp Tue Oct 01 23:34:01 2024 -0400
1.3@@ -0,0 +1,468 @@
1.4+;;; fast.lisp --- Fast Octet Streams
1.5+
1.6+;; based on https://github.com/rpav/fast-io/tree/master
1.7+
1.8+;;; Code:
1.9+(in-package :io/fast)
1.10+
1.11+ ;; Vector buffer
1.12+
1.13+(defvar *default-output-buffer-size* 16)
1.14+
1.15+(declaim (ftype (function (array-index) octet-vector) make-octet-vector)
1.16+ (inline make-octet-vector))
1.17+(defun make-octet-vector (len)
1.18+ (make-array (the array-index len) :element-type 'octet))
1.19+
1.20+(declaim (inline output-buffer-vector output-buffer-fill output-buffer-len))
1.21+(defstruct output-buffer
1.22+ (vector (make-octet-vector *default-output-buffer-size*)
1.23+ :type octet-vector)
1.24+ (fill 0 :type array-index)
1.25+ (len 0 :type array-index)
1.26+ (queue nil :type list)
1.27+ (last nil :type list)
1.28+ (output nil))
1.29+
1.30+(defstruct input-buffer
1.31+ (vector nil :type (or null octet-vector))
1.32+ (pos 0 :type array-index)
1.33+ (stream nil))
1.34+
1.35+(defun buffer-position (buffer)
1.36+ "Return the number of bytes read (for an INPUT-BUFFER) or written
1.37+ (for an OUTPUT-BUFFER)"
1.38+ (etypecase buffer
1.39+ (input-buffer (input-buffer-pos buffer))
1.40+ (output-buffer (output-buffer-len buffer))))
1.41+
1.42+;; Sometimes it is usefull just to skip the buffer instead of reading from it.
1.43+(defun (setf buffer-position) (new-pos buffer)
1.44+ "Set the buffer position for input-buffer"
1.45+ (check-type buffer input-buffer)
1.46+ (let* ((pos (input-buffer-pos buffer))
1.47+ (vec (input-buffer-vector buffer))
1.48+ (vec-len (length vec)))
1.49+ (declare (optimize (speed 3) (safety 1))
1.50+ (type octet-vector vec)
1.51+ (type non-negative-fixnum pos vec-len new-pos))
1.52+ ;; Only need to update if pos or new-pos is in stream range.
1.53+ (when-let ((stream-update-needed? (or (> pos vec-len)
1.54+ (> new-pos vec-len)))
1.55+ (stream (input-buffer-stream buffer)))
1.56+ (let* ((stream-file-pos (file-position stream))
1.57+ (pos-diff (- new-pos pos))
1.58+ (stream-diff (cond ((and (> pos vec-len)
1.59+ (< new-pos vec-len))
1.60+ ;; branch for pos in stream and new-pos
1.61+ ;; is in vector.
1.62+ (- vec-len pos))
1.63+ ((and (< pos vec-len)
1.64+ (> new-pos vec-len))
1.65+ ;; branch for pos in vector. and new-pos
1.66+ ;; is in stream.
1.67+ (- pos-diff (- vec-len pos)))
1.68+ ;; otherwise stream-diff = pos-diff.
1.69+ (t pos-diff)))
1.70+ (new-stream-pos (+ stream-file-pos stream-diff)))
1.71+ (declare (type non-negative-fixnum stream-file-pos new-stream-pos)
1.72+ (type fixnum pos-diff stream-diff))
1.73+ (file-position stream new-stream-pos))))
1.74+ (setf (slot-value buffer 'pos) new-pos))
1.75+
1.76+(defun octets-from (sequence)
1.77+ (let ((vec (make-octet-vector (length sequence))))
1.78+ (replace vec sequence)
1.79+ vec))
1.80+
1.81+(defun concat-buffer (buffer)
1.82+ (let* ((len (output-buffer-len buffer))
1.83+ (array
1.84+ #+fast-io-sv
1.85+ (if (eq :static (output-buffer-output buffer))
1.86+ (static-vectors:make-static-vector (the array-index len))
1.87+ (make-octet-vector len))
1.88+ #-fast-io-sv
1.89+ (make-octet-vector len)))
1.90+ (loop as i = 0 then (+ i (length a))
1.91+ for a in (output-buffer-queue buffer) do
1.92+ (replace (the octet-vector array)
1.93+ (the octet-vector a) :start1 i)
1.94+ finally
1.95+ (replace (the octet-vector array)
1.96+ (output-buffer-vector buffer)
1.97+ :start1 i
1.98+ :end2 (output-buffer-fill buffer)))
1.99+ array))
1.100+
1.101+(defun flush (output-buffer)
1.102+ (when (> (output-buffer-fill output-buffer) 0)
1.103+ (write-sequence (output-buffer-vector output-buffer)
1.104+ (output-buffer-output output-buffer)
1.105+ :start 0 :end (output-buffer-fill output-buffer))
1.106+ (prog1 (output-buffer-fill output-buffer)
1.107+ (setf (output-buffer-fill output-buffer) 0))))
1.108+
1.109+(defun extend (buffer &optional (min 1))
1.110+ (let ((vector (output-buffer-vector buffer)))
1.111+ (setf (output-buffer-last buffer)
1.112+ (nconc (output-buffer-last buffer)
1.113+ (cons vector nil))
1.114+ (output-buffer-vector buffer)
1.115+ (make-octet-vector (max min (1+ (* 2 (length vector)))))
1.116+ (output-buffer-fill buffer) 0)
1.117+ (unless (output-buffer-queue buffer)
1.118+ (setf (output-buffer-queue buffer)
1.119+ (output-buffer-last buffer)))))
1.120+
1.121+(defun fast-write-byte (byte output-buffer)
1.122+ (declare (type octet byte)
1.123+ (type output-buffer output-buffer)
1.124+ (optimize (speed 3) (safety 1)))
1.125+ (when (= (output-buffer-fill output-buffer)
1.126+ (array-dimension (output-buffer-vector output-buffer) 0))
1.127+ (if (streamp (output-buffer-output output-buffer))
1.128+ (flush output-buffer)
1.129+ (extend output-buffer)))
1.130+ (prog1
1.131+ (setf (aref (output-buffer-vector output-buffer)
1.132+ (output-buffer-fill output-buffer))
1.133+ byte)
1.134+ (incf (output-buffer-fill output-buffer))
1.135+ (incf (output-buffer-len output-buffer))))
1.136+
1.137+(defun fast-read-byte (input-buffer &optional (eof-error-p t) eof-value)
1.138+ (declare (type input-buffer input-buffer))
1.139+ (when-let ((vec (input-buffer-vector input-buffer))
1.140+ (pos (input-buffer-pos input-buffer)))
1.141+ (when (< pos (length vec))
1.142+ (incf (input-buffer-pos input-buffer))
1.143+ (return-from fast-read-byte (aref vec pos))))
1.144+ (when-let ((stream (input-buffer-stream input-buffer)))
1.145+ (let ((byte (read-byte stream eof-error-p eof-value)))
1.146+ (unless (equal byte eof-value)
1.147+ (incf (input-buffer-pos input-buffer)))
1.148+ (return-from fast-read-byte byte)))
1.149+ (if eof-error-p
1.150+ (error 'end-of-file :stream input-buffer)
1.151+ eof-value))
1.152+
1.153+(defun fast-peek-byte (input-buffer &optional peek-type (eof-error-p t) eof-value)
1.154+ "This is like `peek-byte' only for fast-io input-buffers."
1.155+ (declare (type input-buffer input-buffer))
1.156+ (loop :for octet = (fast-read-byte input-buffer eof-error-p :eof)
1.157+ :for new-pos :from (input-buffer-pos input-buffer)
1.158+ :until (cond ((eq octet :eof)
1.159+ (return eof-value))
1.160+ ((null peek-type))
1.161+ ((eq peek-type 't)
1.162+ (plusp octet))
1.163+ ((= octet peek-type)))
1.164+ :finally (setf (buffer-position input-buffer) new-pos)
1.165+ (return octet)))
1.166+
1.167+(defun fast-write-sequence (sequence output-buffer &optional (start 0) end)
1.168+ (if (streamp (output-buffer-output output-buffer))
1.169+ (progn
1.170+ (flush output-buffer)
1.171+ (write-sequence sequence (output-buffer-output output-buffer) :start start :end end))
1.172+ (progn
1.173+ (let* ((start2 start)
1.174+ (len (if end
1.175+ (- end start)
1.176+ (- (length sequence) start)))
1.177+ (buffer-remaining
1.178+ (- (length (output-buffer-vector output-buffer))
1.179+ (output-buffer-fill output-buffer))))
1.180+ (when (> buffer-remaining 0)
1.181+ (replace (output-buffer-vector output-buffer)
1.182+ (the octet-vector sequence)
1.183+ :start1 (output-buffer-fill output-buffer)
1.184+ :start2 start2
1.185+ :end2 end)
1.186+ (incf start2 buffer-remaining)
1.187+ (incf (output-buffer-fill output-buffer)
1.188+ (min buffer-remaining len)))
1.189+ (let ((sequence-remaining (- (or end (length sequence)) start2)))
1.190+ (when (> sequence-remaining 0)
1.191+ (extend output-buffer sequence-remaining)
1.192+ (replace (output-buffer-vector output-buffer)
1.193+ (the octet-vector sequence)
1.194+ :start2 start2
1.195+ :end2 end)
1.196+ (incf (output-buffer-fill output-buffer) sequence-remaining)))
1.197+ (incf (output-buffer-len output-buffer) len)
1.198+ len))))
1.199+
1.200+(defun fast-read-sequence (sequence input-buffer &optional (start 0) end)
1.201+ (declare (type octet-vector sequence)
1.202+ (type input-buffer input-buffer))
1.203+ (let ((start1 start)
1.204+ (total-len (if end
1.205+ (- end start)
1.206+ (- (length sequence) start))))
1.207+ (when-let ((vec (input-buffer-vector input-buffer))
1.208+ (pos (input-buffer-pos input-buffer)))
1.209+ (when (< pos (length vec))
1.210+ (let ((len (min total-len (- (length vec) pos))))
1.211+ (replace sequence vec
1.212+ :start1 start1
1.213+ :start2 pos
1.214+ :end2 (+ pos len))
1.215+ (incf (input-buffer-pos input-buffer) len)
1.216+ (incf start1 len))))
1.217+ (when (< start1 total-len)
1.218+ (when-let ((stream (input-buffer-stream input-buffer)))
1.219+ (let ((bytes-read (read-sequence sequence stream
1.220+ :start start1
1.221+ :end (+ total-len start1))))
1.222+ (incf (input-buffer-pos input-buffer) bytes-read)
1.223+ (return-from fast-read-sequence bytes-read))))
1.224+ start1))
1.225+
1.226+(defun finish-output-buffer (output-buffer)
1.227+ "Finish an output buffer. If it is backed by a vector (static or otherwise)
1.228+it returns the final octet vector. If it is backed by a stream it ensures that
1.229+all data has been flushed to the stream."
1.230+ (if (streamp (output-buffer-output output-buffer))
1.231+ (flush output-buffer)
1.232+ (concat-buffer output-buffer)))
1.233+
1.234+(defmacro with-fast-output ((buffer &optional output) &body body)
1.235+ "Create `BUFFER`, optionally outputting to `OUTPUT`."
1.236+ `(let ((,buffer (make-output-buffer :output ,output)))
1.237+ ,@body
1.238+ (if (streamp (output-buffer-output ,buffer))
1.239+ (flush ,buffer)
1.240+ (finish-output-buffer ,buffer))))
1.241+
1.242+(defmacro with-fast-input ((buffer vector &optional stream (offset 0)) &body body)
1.243+ `(let ((,buffer (make-input-buffer :vector ,vector :stream ,stream :pos ,offset)))
1.244+ ,@body))
1.245+
1.246+ ;; READx and WRITEx
1.247+;;; WRITE-UNSIGNED-BE, READ-UNSIGNED-BE, etc taken from PACK, which is
1.248+;;; in the public domain.
1.249+
1.250+(defmacro write-unsigned-be (value size buffer)
1.251+ (once-only (value buffer)
1.252+ `(progn
1.253+ ,@(loop for i from (* (1- size) 8) downto 0 by 8
1.254+ collect `(fast-write-byte (ldb (byte 8 ,i) ,value) ,buffer)))))
1.255+
1.256+(defmacro read-unsigned-be (size buffer)
1.257+ (with-gensyms (value)
1.258+ (once-only (buffer)
1.259+ `(let ((,value 0))
1.260+ ,@(loop for i from (* (1- size) 8) downto 0 by 8
1.261+ collect `(setf (ldb (byte 8 ,i) ,value) (fast-read-byte ,buffer)))
1.262+ ,value))))
1.263+
1.264+(defmacro write-unsigned-le (value size buffer)
1.265+ (once-only (value buffer)
1.266+ `(progn
1.267+ ,@(loop for i from 0 below (* 8 size) by 8
1.268+ collect `(fast-write-byte (ldb (byte 8 ,i) ,value) ,buffer)))))
1.269+
1.270+(defmacro read-unsigned-le (size buffer)
1.271+ (with-gensyms (value)
1.272+ (once-only (buffer)
1.273+ `(let ((,value 0))
1.274+ ,@(loop for i from 0 below (* 8 size) by 8
1.275+ collect `(setf (ldb (byte 8 ,i) ,value) (fast-read-byte ,buffer)))
1.276+ ,value))))
1.277+
1.278+(declaim (inline unsigned-to-signed))
1.279+(defun unsigned-to-signed (value size)
1.280+ (let ((max-signed (expt 2 (1- (* 8 size))))
1.281+ (to-subtract (expt 2 (* 8 size))))
1.282+ (if (>= value max-signed)
1.283+ (- value to-subtract)
1.284+ value)))
1.285+
1.286+(declaim (inline signed-to-unsigned))
1.287+(defun signed-to-unsigned (value size)
1.288+ (if (minusp value)
1.289+ (+ value (expt 2 (* 8 size)))
1.290+ value))
1.291+
1.292+(defmacro make-readers (&rest bitlens)
1.293+ (let ((names (mapcar (lambda (n)
1.294+ (mapcar (lambda (m) (symbolicate (format nil m n)))
1.295+ '("READ~A-BE" "READU~A-BE"
1.296+ "READ~A-LE" "READU~A-LE")))
1.297+ bitlens)))
1.298+ `(eval-when (:compile-toplevel :load-toplevel :execute)
1.299+ (declaim (inline ,@(flatten names)))
1.300+ ,@(loop for fun in names
1.301+ for bits in bitlens
1.302+ as bytes = (truncate bits 8)
1.303+ collect
1.304+ `(progn
1.305+ (defun ,(first fun) (buffer)
1.306+ (unsigned-to-signed (read-unsigned-be ,bytes buffer) ,bytes))
1.307+ (defun ,(second fun) (buffer)
1.308+ (read-unsigned-be ,bytes buffer))
1.309+ (defun ,(third fun) (buffer)
1.310+ (unsigned-to-signed (read-unsigned-le ,bytes buffer) ,bytes))
1.311+ (defun ,(fourth fun) (buffer)
1.312+ (read-unsigned-le ,bytes buffer)))))))
1.313+
1.314+(defmacro make-writers (&rest bitlens)
1.315+ (let ((names (mapcar (lambda (n)
1.316+ (mapcar (lambda (m) (symbolicate (format nil m n)))
1.317+ '("WRITE~A-BE" "WRITEU~A-BE"
1.318+ "WRITE~A-LE" "WRITEU~A-LE")))
1.319+ bitlens)))
1.320+ `(eval-when (:compile-toplevel :load-toplevel :execute)
1.321+ (declaim (notinline ,@(flatten names)))
1.322+ ,@(loop for fun in names
1.323+ for bits in bitlens
1.324+ as bytes = (truncate bits 8)
1.325+ collect
1.326+ `(progn
1.327+ (defun ,(first fun) (value buffer)
1.328+ (declare (type (signed-byte ,bits) value))
1.329+ (write-unsigned-be (the (unsigned-byte ,bits)
1.330+ (signed-to-unsigned value ,bytes)) ,bytes buffer))
1.331+ (defun ,(second fun) (value buffer)
1.332+ (declare (type (unsigned-byte ,bits) value))
1.333+ (write-unsigned-be (the (unsigned-byte ,bits) value)
1.334+ ,bytes buffer))
1.335+ (defun ,(third fun) (value buffer)
1.336+ (declare (type (signed-byte ,bits) value))
1.337+ (write-unsigned-le (the (unsigned-byte ,bits)
1.338+ (signed-to-unsigned value ,bytes)) ,bytes buffer))
1.339+ (defun ,(fourth fun) (value buffer)
1.340+ (declare (type (unsigned-byte ,bits) value))
1.341+ (write-unsigned-le (the (unsigned-byte ,bits) value)
1.342+ ,bytes buffer)))))))
1.343+
1.344+(make-writers 16 24 32 64 128)
1.345+(make-readers 16 24 32 64 128)
1.346+
1.347+(declaim (inline write8 writeu8 read8 readu8))
1.348+(defun write8 (value buffer)
1.349+ (declare (type (signed-byte 8) value))
1.350+ (fast-write-byte (signed-to-unsigned value 1) buffer))
1.351+
1.352+(defun writeu8 (value buffer)
1.353+ (declare (type (unsigned-byte 8) value))
1.354+ (fast-write-byte value buffer))
1.355+
1.356+
1.357+(defun read8 (buffer)
1.358+ (unsigned-to-signed (fast-read-byte buffer) 1))
1.359+
1.360+(defun readu8 (buffer)
1.361+ (fast-read-byte buffer))
1.362+
1.363+(setf (symbol-function 'write8-le) #'write8)
1.364+(setf (symbol-function 'write8-be) #'write8)
1.365+(setf (symbol-function 'writeu8-le) #'writeu8)
1.366+(setf (symbol-function 'writeu8-be) #'writeu8)
1.367+
1.368+(setf (symbol-function 'read8-le) #'read8)
1.369+(setf (symbol-function 'read8-be) #'read8)
1.370+(setf (symbol-function 'readu8-le) #'readu8)
1.371+(setf (symbol-function 'readu8-be) #'readu8)
1.372+
1.373+;; fast-stream
1.374+
1.375+(defclass fast-io-stream (fundamental-stream)
1.376+ ((openp :type boolean :initform t)))
1.377+
1.378+(defmethod stream-file-position ((stream fast-io-stream))
1.379+ (with-slots (buffer) stream
1.380+ (buffer-position buffer)))
1.381+
1.382+(defmethod open-stream-p ((stream fast-io-stream))
1.383+ (slot-value stream 'openep))
1.384+
1.385+ ;; fast-output-stream
1.386+
1.387+(defclass fast-output-stream (fast-io-stream fundamental-output-stream)
1.388+ ((buffer :type output-buffer)))
1.389+
1.390+(defmethod initialize-instance ((self fast-output-stream) &key stream
1.391+ buffer-size &allow-other-keys)
1.392+ (call-next-method)
1.393+ (let ((*default-output-buffer-size* (or buffer-size *default-output-buffer-size*)))
1.394+ (with-slots (buffer) self
1.395+ (setf buffer (make-output-buffer :output stream)))))
1.396+
1.397+(defmethod output-stream-p ((stream fast-output-stream))
1.398+ (with-slots (buffer) stream
1.399+ (and (typep buffer 'output-buffer))))
1.400+
1.401+(defmethod stream-element-type ((stream fast-output-stream))
1.402+ "Return the underlying array element-type.
1.403+ Should always return '(unsigned-byte 8)."
1.404+ (with-slots (buffer) stream
1.405+ (array-element-type (output-buffer-vector buffer))))
1.406+
1.407+(defmethod stream-write-byte ((stream fast-output-stream) byte)
1.408+ (with-slots (buffer) stream
1.409+ (fast-write-byte byte buffer)))
1.410+
1.411+(defmethod stream-write-sequence ((stream fast-output-stream) sequence start end
1.412+ &key &allow-other-keys)
1.413+ (with-slots (buffer) stream
1.414+ (fast-write-sequence sequence buffer start end))
1.415+ sequence)
1.416+
1.417+(defun finish-output-stream (stream)
1.418+ (with-slots (buffer) stream
1.419+ (if (streamp (output-buffer-output buffer))
1.420+ (flush buffer)
1.421+ (finish-output-buffer buffer))))
1.422+
1.423+(defmethod close ((stream fast-output-stream) &key abort)
1.424+ (declare (ignore abort))
1.425+ (finish-output-stream stream)
1.426+ (setf (slot-value stream 'openp) nil))
1.427+
1.428+ ;; fast-input-stream
1.429+
1.430+(defclass fast-input-stream (fast-io-stream fundamental-input-stream)
1.431+ ((buffer :type input-buffer)))
1.432+
1.433+(defmethod initialize-instance ((self fast-input-stream) &key stream
1.434+ vector &allow-other-keys)
1.435+ (call-next-method)
1.436+ (with-slots (buffer) self
1.437+ (setf buffer (make-input-buffer :vector vector :stream stream))))
1.438+
1.439+(defmethod input-stream-p ((stream fast-input-stream))
1.440+ (with-slots (buffer) stream
1.441+ (and (typep buffer 'input-buffer))))
1.442+
1.443+(defmethod stream-element-type ((stream fast-input-stream))
1.444+ "Return element-type of the underlying vector or stream.
1.445+ Return NIL if none are present."
1.446+ (with-slots (buffer) stream
1.447+ (if-let ((vec (input-buffer-vector buffer)))
1.448+ (array-element-type vec)
1.449+ (when-let ((stream (input-buffer-stream buffer)))
1.450+ (stream-element-type stream)))))
1.451+
1.452+(defmethod (setf stream-file-position) (new-pos (stream fast-input-stream))
1.453+ (with-slots (buffer) stream
1.454+ (setf (buffer-position buffer) new-pos)))
1.455+
1.456+(defmethod peek-byte ((stream fast-input-stream) &optional peek-type (eof-error-p t) eof-value)
1.457+ (with-slots (buffer) stream
1.458+ (fast-peek-byte buffer peek-type eof-error-p eof-value)))
1.459+
1.460+(defmethod stream-read-byte ((stream fast-input-stream))
1.461+ (with-slots (buffer) stream
1.462+ (fast-read-byte buffer)))
1.463+
1.464+(defmethod stream-read-sequence ((stream fast-input-stream) sequence start end
1.465+ &key &allow-other-keys)
1.466+ (with-slots (buffer) stream
1.467+ (fast-read-sequence sequence buffer start end)))
1.468+
1.469+(defmethod close ((stream fast-input-stream) &key abort)
1.470+ (declare (ignore abort))
1.471+ (setf (slot-value stream 'openp) nil))
