Mercurial > core / lisp/lib/io/fast.lisp
changeset 690: |
90417ae14b21 |
child: |
2bad47888dbf |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Tue, 01 Oct 2024 23:34:01 -0400 |
permissions: |
-rw-r--r-- |
description: |
added io/fast, moved obj/music -> aud/music |
1 ;;; fast.lisp --- Fast Octet Streams 3 ;; based on https://github.com/rpav/fast-io/tree/master 10 (defvar *default-output-buffer-size* 16) 12 (declaim (ftype (function (array-index) octet-vector) make-octet-vector) 13 (inline make-octet-vector)) 14 (defun make-octet-vector (len) 15 (make-array (the array-index len) :element-type 'octet)) 17 (declaim (inline output-buffer-vector output-buffer-fill output-buffer-len)) 18 (defstruct output-buffer 19 (vector (make-octet-vector *default-output-buffer-size*) 21 (fill 0 :type array-index) 22 (len 0 :type array-index) 23 (queue nil :type list) 27 (defstruct input-buffer 28 (vector nil :type (or null octet-vector)) 29 (pos 0 :type array-index) 32 (defun buffer-position (buffer) 33 "Return the number of bytes read (for an INPUT-BUFFER) or written 34 (for an OUTPUT-BUFFER)" 36 (input-buffer (input-buffer-pos buffer)) 37 (output-buffer (output-buffer-len buffer)))) 39 ;; Sometimes it is usefull just to skip the buffer instead of reading from it. 40 (defun (setf buffer-position) (new-pos buffer) 41 "Set the buffer position for input-buffer" 42 (check-type buffer input-buffer) 43 (let* ((pos (input-buffer-pos buffer)) 44 (vec (input-buffer-vector buffer)) 45 (vec-len (length vec))) 46 (declare (optimize (speed 3) (safety 1)) 47 (type octet-vector vec) 48 (type non-negative-fixnum pos vec-len new-pos)) 49 ;; Only need to update if pos or new-pos is in stream range. 50 (when-let ((stream-update-needed? (or (> pos vec-len) 52 (stream (input-buffer-stream buffer))) 53 (let* ((stream-file-pos (file-position stream)) 54 (pos-diff (- new-pos pos)) 55 (stream-diff (cond ((and (> pos vec-len) 57 ;; branch for pos in stream and new-pos 62 ;; branch for pos in vector. and new-pos 64 (- pos-diff (- vec-len pos))) 65 ;; otherwise stream-diff = pos-diff. 67 (new-stream-pos (+ stream-file-pos stream-diff))) 68 (declare (type non-negative-fixnum stream-file-pos new-stream-pos) 69 (type fixnum pos-diff stream-diff)) 70 (file-position stream new-stream-pos)))) 71 (setf (slot-value buffer 'pos) new-pos)) 73 (defun octets-from (sequence) 74 (let ((vec (make-octet-vector (length sequence)))) 75 (replace vec sequence) 78 (defun concat-buffer (buffer) 79 (let* ((len (output-buffer-len buffer)) 82 (if (eq :static (output-buffer-output buffer)) 83 (static-vectors:make-static-vector (the array-index len)) 84 (make-octet-vector len)) 86 (make-octet-vector len))) 87 (loop as i = 0 then (+ i (length a)) 88 for a in (output-buffer-queue buffer) do 89 (replace (the octet-vector array) 90 (the octet-vector a) :start1 i) 92 (replace (the octet-vector array) 93 (output-buffer-vector buffer) 95 :end2 (output-buffer-fill buffer))) 98 (defun flush (output-buffer) 99 (when (> (output-buffer-fill output-buffer) 0) 100 (write-sequence (output-buffer-vector output-buffer) 101 (output-buffer-output output-buffer) 102 :start 0 :end (output-buffer-fill output-buffer)) 103 (prog1 (output-buffer-fill output-buffer) 104 (setf (output-buffer-fill output-buffer) 0)))) 106 (defun extend (buffer &optional (min 1)) 107 (let ((vector (output-buffer-vector buffer))) 108 (setf (output-buffer-last buffer) 109 (nconc (output-buffer-last buffer) 111 (output-buffer-vector buffer) 112 (make-octet-vector (max min (1+ (* 2 (length vector))))) 113 (output-buffer-fill buffer) 0) 114 (unless (output-buffer-queue buffer) 115 (setf (output-buffer-queue buffer) 116 (output-buffer-last buffer))))) 118 (defun fast-write-byte (byte output-buffer) 119 (declare (type octet byte) 120 (type output-buffer output-buffer) 121 (optimize (speed 3) (safety 1))) 122 (when (= (output-buffer-fill output-buffer) 123 (array-dimension (output-buffer-vector output-buffer) 0)) 124 (if (streamp (output-buffer-output output-buffer)) 125 (flush output-buffer) 126 (extend output-buffer))) 128 (setf (aref (output-buffer-vector output-buffer) 129 (output-buffer-fill output-buffer)) 131 (incf (output-buffer-fill output-buffer)) 132 (incf (output-buffer-len output-buffer)))) 134 (defun fast-read-byte (input-buffer &optional (eof-error-p t) eof-value) 135 (declare (type input-buffer input-buffer)) 136 (when-let ((vec (input-buffer-vector input-buffer)) 137 (pos (input-buffer-pos input-buffer))) 138 (when (< pos (length vec)) 139 (incf (input-buffer-pos input-buffer)) 140 (return-from fast-read-byte (aref vec pos)))) 141 (when-let ((stream (input-buffer-stream input-buffer))) 142 (let ((byte (read-byte stream eof-error-p eof-value))) 143 (unless (equal byte eof-value) 144 (incf (input-buffer-pos input-buffer))) 145 (return-from fast-read-byte byte))) 147 (error 'end-of-file :stream input-buffer) 150 (defun fast-peek-byte (input-buffer &optional peek-type (eof-error-p t) eof-value) 151 "This is like `peek-byte' only for fast-io input-buffers." 152 (declare (type input-buffer input-buffer)) 153 (loop :for octet = (fast-read-byte input-buffer eof-error-p :eof) 154 :for new-pos :from (input-buffer-pos input-buffer) 155 :until (cond ((eq octet :eof) 160 ((= octet peek-type))) 161 :finally (setf (buffer-position input-buffer) new-pos) 164 (defun fast-write-sequence (sequence output-buffer &optional (start 0) end) 165 (if (streamp (output-buffer-output output-buffer)) 167 (flush output-buffer) 168 (write-sequence sequence (output-buffer-output output-buffer) :start start :end end)) 170 (let* ((start2 start) 173 (- (length sequence) start))) 175 (- (length (output-buffer-vector output-buffer)) 176 (output-buffer-fill output-buffer)))) 177 (when (> buffer-remaining 0) 178 (replace (output-buffer-vector output-buffer) 179 (the octet-vector sequence) 180 :start1 (output-buffer-fill output-buffer) 183 (incf start2 buffer-remaining) 184 (incf (output-buffer-fill output-buffer) 185 (min buffer-remaining len))) 186 (let ((sequence-remaining (- (or end (length sequence)) start2))) 187 (when (> sequence-remaining 0) 188 (extend output-buffer sequence-remaining) 189 (replace (output-buffer-vector output-buffer) 190 (the octet-vector sequence) 193 (incf (output-buffer-fill output-buffer) sequence-remaining))) 194 (incf (output-buffer-len output-buffer) len) 197 (defun fast-read-sequence (sequence input-buffer &optional (start 0) end) 198 (declare (type octet-vector sequence) 199 (type input-buffer input-buffer)) 203 (- (length sequence) start)))) 204 (when-let ((vec (input-buffer-vector input-buffer)) 205 (pos (input-buffer-pos input-buffer))) 206 (when (< pos (length vec)) 207 (let ((len (min total-len (- (length vec) pos)))) 208 (replace sequence vec 212 (incf (input-buffer-pos input-buffer) len) 214 (when (< start1 total-len) 215 (when-let ((stream (input-buffer-stream input-buffer))) 216 (let ((bytes-read (read-sequence sequence stream 218 :end (+ total-len start1)))) 219 (incf (input-buffer-pos input-buffer) bytes-read) 220 (return-from fast-read-sequence bytes-read)))) 223 (defun finish-output-buffer (output-buffer) 224 "Finish an output buffer. If it is backed by a vector (static or otherwise) 225 it returns the final octet vector. If it is backed by a stream it ensures that 226 all data has been flushed to the stream." 227 (if (streamp (output-buffer-output output-buffer)) 228 (flush output-buffer) 229 (concat-buffer output-buffer))) 231 (defmacro with-fast-output ((buffer &optional output) &body body) 232 "Create `BUFFER`, optionally outputting to `OUTPUT`." 233 `(let ((,buffer (make-output-buffer :output ,output))) 235 (if (streamp (output-buffer-output ,buffer)) 237 (finish-output-buffer ,buffer)))) 239 (defmacro with-fast-input ((buffer vector &optional stream (offset 0)) &body body) 240 `(let ((,buffer (make-input-buffer :vector ,vector :stream ,stream :pos ,offset))) 244 ;;; WRITE-UNSIGNED-BE, READ-UNSIGNED-BE, etc taken from PACK, which is 245 ;;; in the public domain. 247 (defmacro write-unsigned-be (value size buffer) 248 (once-only (value buffer) 250 ,@(loop for i from (* (1- size) 8) downto 0 by 8 251 collect `(fast-write-byte (ldb (byte 8 ,i) ,value) ,buffer))))) 253 (defmacro read-unsigned-be (size buffer) 254 (with-gensyms (value) 257 ,@(loop for i from (* (1- size) 8) downto 0 by 8 258 collect `(setf (ldb (byte 8 ,i) ,value) (fast-read-byte ,buffer))) 261 (defmacro write-unsigned-le (value size buffer) 262 (once-only (value buffer) 264 ,@(loop for i from 0 below (* 8 size) by 8 265 collect `(fast-write-byte (ldb (byte 8 ,i) ,value) ,buffer))))) 267 (defmacro read-unsigned-le (size buffer) 268 (with-gensyms (value) 271 ,@(loop for i from 0 below (* 8 size) by 8 272 collect `(setf (ldb (byte 8 ,i) ,value) (fast-read-byte ,buffer))) 275 (declaim (inline unsigned-to-signed)) 276 (defun unsigned-to-signed (value size) 277 (let ((max-signed (expt 2 (1- (* 8 size)))) 278 (to-subtract (expt 2 (* 8 size)))) 279 (if (>= value max-signed) 280 (- value to-subtract) 283 (declaim (inline signed-to-unsigned)) 284 (defun signed-to-unsigned (value size) 286 (+ value (expt 2 (* 8 size))) 289 (defmacro make-readers (&rest bitlens) 290 (let ((names (mapcar (lambda (n) 291 (mapcar (lambda (m) (symbolicate (format nil m n))) 292 '("READ~A-BE" "READU~A-BE" 293 "READ~A-LE" "READU~A-LE"))) 295 `(eval-when (:compile-toplevel :load-toplevel :execute) 296 (declaim (inline ,@(flatten names))) 297 ,@(loop for fun in names 299 as bytes = (truncate bits 8) 302 (defun ,(first fun) (buffer) 303 (unsigned-to-signed (read-unsigned-be ,bytes buffer) ,bytes)) 304 (defun ,(second fun) (buffer) 305 (read-unsigned-be ,bytes buffer)) 306 (defun ,(third fun) (buffer) 307 (unsigned-to-signed (read-unsigned-le ,bytes buffer) ,bytes)) 308 (defun ,(fourth fun) (buffer) 309 (read-unsigned-le ,bytes buffer))))))) 311 (defmacro make-writers (&rest bitlens) 312 (let ((names (mapcar (lambda (n) 313 (mapcar (lambda (m) (symbolicate (format nil m n))) 314 '("WRITE~A-BE" "WRITEU~A-BE" 315 "WRITE~A-LE" "WRITEU~A-LE"))) 317 `(eval-when (:compile-toplevel :load-toplevel :execute) 318 (declaim (notinline ,@(flatten names))) 319 ,@(loop for fun in names 321 as bytes = (truncate bits 8) 324 (defun ,(first fun) (value buffer) 325 (declare (type (signed-byte ,bits) value)) 326 (write-unsigned-be (the (unsigned-byte ,bits) 327 (signed-to-unsigned value ,bytes)) ,bytes buffer)) 328 (defun ,(second fun) (value buffer) 329 (declare (type (unsigned-byte ,bits) value)) 330 (write-unsigned-be (the (unsigned-byte ,bits) value) 332 (defun ,(third fun) (value buffer) 333 (declare (type (signed-byte ,bits) value)) 334 (write-unsigned-le (the (unsigned-byte ,bits) 335 (signed-to-unsigned value ,bytes)) ,bytes buffer)) 336 (defun ,(fourth fun) (value buffer) 337 (declare (type (unsigned-byte ,bits) value)) 338 (write-unsigned-le (the (unsigned-byte ,bits) value) 341 (make-writers 16 24 32 64 128) 342 (make-readers 16 24 32 64 128) 344 (declaim (inline write8 writeu8 read8 readu8)) 345 (defun write8 (value buffer) 346 (declare (type (signed-byte 8) value)) 347 (fast-write-byte (signed-to-unsigned value 1) buffer)) 349 (defun writeu8 (value buffer) 350 (declare (type (unsigned-byte 8) value)) 351 (fast-write-byte value buffer)) 354 (defun read8 (buffer) 355 (unsigned-to-signed (fast-read-byte buffer) 1)) 357 (defun readu8 (buffer) 358 (fast-read-byte buffer)) 360 (setf (symbol-function 'write8-le) #'write8) 361 (setf (symbol-function 'write8-be) #'write8) 362 (setf (symbol-function 'writeu8-le) #'writeu8) 363 (setf (symbol-function 'writeu8-be) #'writeu8) 365 (setf (symbol-function 'read8-le) #'read8) 366 (setf (symbol-function 'read8-be) #'read8) 367 (setf (symbol-function 'readu8-le) #'readu8) 368 (setf (symbol-function 'readu8-be) #'readu8) 372 (defclass fast-io-stream (fundamental-stream) 373 ((openp :type boolean :initform t))) 375 (defmethod stream-file-position ((stream fast-io-stream)) 376 (with-slots (buffer) stream 377 (buffer-position buffer))) 379 (defmethod open-stream-p ((stream fast-io-stream)) 380 (slot-value stream 'openep)) 382 ;; fast-output-stream 384 (defclass fast-output-stream (fast-io-stream fundamental-output-stream) 385 ((buffer :type output-buffer))) 387 (defmethod initialize-instance ((self fast-output-stream) &key stream 388 buffer-size &allow-other-keys) 390 (let ((*default-output-buffer-size* (or buffer-size *default-output-buffer-size*))) 391 (with-slots (buffer) self 392 (setf buffer (make-output-buffer :output stream))))) 394 (defmethod output-stream-p ((stream fast-output-stream)) 395 (with-slots (buffer) stream 396 (and (typep buffer 'output-buffer)))) 398 (defmethod stream-element-type ((stream fast-output-stream)) 399 "Return the underlying array element-type. 400 Should always return '(unsigned-byte 8)." 401 (with-slots (buffer) stream 402 (array-element-type (output-buffer-vector buffer)))) 404 (defmethod stream-write-byte ((stream fast-output-stream) byte) 405 (with-slots (buffer) stream 406 (fast-write-byte byte buffer))) 408 (defmethod stream-write-sequence ((stream fast-output-stream) sequence start end 409 &key &allow-other-keys) 410 (with-slots (buffer) stream 411 (fast-write-sequence sequence buffer start end)) 414 (defun finish-output-stream (stream) 415 (with-slots (buffer) stream 416 (if (streamp (output-buffer-output buffer)) 418 (finish-output-buffer buffer)))) 420 (defmethod close ((stream fast-output-stream) &key abort) 421 (declare (ignore abort)) 422 (finish-output-stream stream) 423 (setf (slot-value stream 'openp) nil)) 427 (defclass fast-input-stream (fast-io-stream fundamental-input-stream) 428 ((buffer :type input-buffer))) 430 (defmethod initialize-instance ((self fast-input-stream) &key stream 431 vector &allow-other-keys) 433 (with-slots (buffer) self 434 (setf buffer (make-input-buffer :vector vector :stream stream)))) 436 (defmethod input-stream-p ((stream fast-input-stream)) 437 (with-slots (buffer) stream 438 (and (typep buffer 'input-buffer)))) 440 (defmethod stream-element-type ((stream fast-input-stream)) 441 "Return element-type of the underlying vector or stream. 442 Return NIL if none are present." 443 (with-slots (buffer) stream 444 (if-let ((vec (input-buffer-vector buffer))) 445 (array-element-type vec) 446 (when-let ((stream (input-buffer-stream buffer))) 447 (stream-element-type stream))))) 449 (defmethod (setf stream-file-position) (new-pos (stream fast-input-stream)) 450 (with-slots (buffer) stream 451 (setf (buffer-position buffer) new-pos))) 453 (defmethod peek-byte ((stream fast-input-stream) &optional peek-type (eof-error-p t) eof-value) 454 (with-slots (buffer) stream 455 (fast-peek-byte buffer peek-type eof-error-p eof-value))) 457 (defmethod stream-read-byte ((stream fast-input-stream)) 458 (with-slots (buffer) stream 459 (fast-read-byte buffer))) 461 (defmethod stream-read-sequence ((stream fast-input-stream) sequence start end 462 &key &allow-other-keys) 463 (with-slots (buffer) stream 464 (fast-read-sequence sequence buffer start end))) 466 (defmethod close ((stream fast-input-stream) &key abort) 467 (declare (ignore abort)) 468 (setf (slot-value stream 'openp) nil))