changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > demo / examples/db/xdb/io.lisp

changeset 41: 81b7333f27f8
author: Richard Westhaver <ellis@rwest.io>
date: Sun, 16 Jun 2024 22:15:04 -0400
permissions: -rw-r--r--
description: more examples 
     1 ;;; io/blob.lisp --- Blob Database IO
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (in-package :xdb)
     7 
     8 ;;; IO
     9 (defvar *fsync-data* nil)
    10 
    11 (defconstant +buffer-size+ 8192)
    12 
    13 (deftype word () 'sb-ext:word)
    14 
    15 (defstruct (input-stream
    16             (:predicate nil))
    17   (fd nil :type word)
    18   (left 0 :type word)
    19   (buffer-start (sb-sys:sap-int
    20                  (sb-alien::%make-alien (* sb-vm:n-byte-bits
    21                                            (+ +buffer-size+ 3))))
    22    :type word)
    23   (buffer-end 0 :type word)
    24   (buffer-position 0 :type word))
    25 
    26 (defstruct (output-stream
    27             (:predicate nil))
    28   (fd nil :type word)
    29   (buffer-start (sb-sys:sap-int
    30                  (sb-alien::%make-alien (* sb-vm:n-byte-bits
    31                                            (+ +buffer-size+ 3))))
    32                 :type word)
    33   (buffer-end 0 :type word)
    34   (buffer-position 0 :type word))
    35 
    36 (defun open-file (file-stream
    37                   &key direction)
    38   (if (eql direction :output)
    39       (let ((output (make-output-stream
    40                      :fd (sb-sys:fd-stream-fd file-stream))))
    41         (setf (output-stream-buffer-position output)
    42               (output-stream-buffer-start output)
    43               (output-stream-buffer-end output)
    44               (+ (output-stream-buffer-start output)
    45                  +buffer-size+))
    46         output)
    47       (make-input-stream
    48        :fd (sb-sys:fd-stream-fd file-stream)
    49        :left (file-length file-stream))))
    50 
    51 (defun close-input-stream (stream)
    52   (sb-alien:alien-funcall
    53    (sb-alien:extern-alien "free"
    54                           (function (values) sb-alien:long))
    55    (input-stream-buffer-start stream)))
    56 
    57 (defun close-output-stream (stream)
    58   (flush-buffer stream)
    59   (sb-alien:alien-funcall
    60    (sb-alien:extern-alien "free"
    61                           (function (values) sb-alien:long))
    62    (output-stream-buffer-start stream)))
    63 
    64 (declaim (inline stream-end-of-file-p))
    65 (defun stream-end-of-file-p (stream)
    66   (and (>= (input-stream-buffer-position stream)
    67            (input-stream-buffer-end stream))
    68        (zerop (input-stream-left stream))))
    69 
    70 (declaim (inline sap-ref-24))
    71 (defun sap-ref-24 (sap offset)
    72   (declare (optimize speed (safety 0))
    73            (fixnum offset))
    74   (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
    75 
    76 (declaim (inline n-sap-ref))
    77 (defun n-sap-ref (n sap &optional (offset 0))
    78   (funcall (ecase n
    79              (1 #'sb-sys:sap-ref-8)
    80              (2 #'sb-sys:sap-ref-16)
    81              (3 #'sap-ref-24)
    82              (4 #'sb-sys:sap-ref-32))
    83            sap
    84            offset))
    85 
    86 (declaim (inline unix-read))
    87 (defun unix-read (fd buf len)
    88   (declare (optimize (sb-c::float-accuracy 0)
    89                      (space 0)))
    90   (declare (type sb-unix::unix-fd fd)
    91            (type word len))
    92   (sb-alien:alien-funcall
    93    (sb-alien:extern-alien "read"
    94                           (function sb-alien:int
    95                                     sb-alien:int sb-alien:long sb-alien:int))
    96    fd buf len))
    97 
    98 (declaim (inline unix-read))
    99 (defun unix-write (fd buf len)
   100   (declare (optimize (sb-c::float-accuracy 0)
   101                      (space 0)))
   102   (declare (type sb-unix::unix-fd fd)
   103            (type word len))
   104   (sb-alien:alien-funcall
   105    (sb-alien:extern-alien "write"
   106                           (function sb-alien:int
   107                                     sb-alien:int sb-alien:long sb-alien:int))
   108    fd buf len))
   109 
   110 (defun fill-buffer (stream offset)
   111   (let ((length (unix-read (input-stream-fd stream)
   112                            (+ (input-stream-buffer-start stream) offset)
   113                            (- +buffer-size+ offset))))
   114     (setf (input-stream-buffer-end stream)
   115           (+ (input-stream-buffer-start stream) (+ length offset)))
   116     (decf (input-stream-left stream) length))
   117   t)
   118 
   119 (defun refill-buffer (n stream)
   120   (declare (type word n)
   121            (input-stream stream))
   122   (let ((left-n-bytes (- (input-stream-buffer-end stream)
   123                          (input-stream-buffer-position stream))))
   124     (when (> (- n left-n-bytes)
   125              (input-stream-left stream))
   126       (error "End of file ~a" stream))
   127     (unless (zerop left-n-bytes)
   128       (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0)
   129             (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream)))))
   130     (fill-buffer stream left-n-bytes))
   131   (let ((start (input-stream-buffer-start stream)))
   132     (setf (input-stream-buffer-position stream)
   133           (+ start n)))
   134   t)
   135 
   136 (declaim (inline advance-input-stream))
   137 (defun advance-input-stream (n stream)
   138   (declare (optimize (space 0))
   139            (type word n)
   140            (type input-stream stream))
   141   (let* ((sap (input-stream-buffer-position stream))
   142          (new-sap (sb-ext:truly-the word (+ sap n))))
   143     (declare (word sap new-sap))
   144     (cond ((> new-sap (input-stream-buffer-end stream))
   145            (refill-buffer n stream)
   146            (sb-sys:int-sap (input-stream-buffer-start stream)))
   147           (t
   148            (setf (input-stream-buffer-position stream)
   149                  new-sap)
   150            (sb-sys:int-sap sap)))))
   151 
   152 (declaim (inline read-n-bytes))
   153 (defun read-n-bytes (n stream)
   154   (declare (optimize (space 0))
   155            (type word n))
   156   (n-sap-ref n (advance-input-stream n stream)))
   157 
   158 (declaim (inline read-n-signed-bytes))
   159 (defun read-n-signed-bytes (n stream)
   160   (declare (optimize speed)
   161            (sb-ext:muffle-conditions sb-ext:compiler-note)
   162            (type (integer 1 4) n))
   163   (funcall (ecase n
   164              (1 #'sb-sys:signed-sap-ref-8)
   165              (2 #'sb-sys:signed-sap-ref-16)
   166              ;; (3 )
   167              (4 #'sb-sys:signed-sap-ref-32))
   168            (advance-input-stream n stream)
   169            0))
   170 
   171 (declaim (inline write-n-signed-bytes))
   172 (defun write-n-signed-bytes (value n stream)
   173   (declare (optimize speed)
   174            (sb-ext:muffle-conditions sb-ext:compiler-note)
   175            (fixnum n))
   176   (ecase n
   177     (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0)
   178              value))
   179     (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0)
   180              value))
   181     ;; (3 )
   182     (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0)
   183              value)))
   184   t)
   185 
   186 (defun flush-buffer (stream)
   187   (unix-write (output-stream-fd stream)
   188               (output-stream-buffer-start stream)
   189               (- (output-stream-buffer-position stream)
   190                  (output-stream-buffer-start stream))))
   191 
   192 (declaim (inline advance-output-stream))
   193 (defun advance-output-stream (n stream)
   194   (declare (optimize (space 0) (safety 0))
   195            (type word n)
   196            (type output-stream stream)
   197            ((integer 1 4) n))
   198   (let* ((sap (output-stream-buffer-position stream))
   199          (new-sap (sb-ext:truly-the word (+ sap n))))
   200     (declare (word sap new-sap))
   201     (cond ((> new-sap (output-stream-buffer-end stream))
   202            (flush-buffer stream)
   203            (setf (output-stream-buffer-position stream)
   204                  (+ (output-stream-buffer-start stream)
   205                     n))
   206            (sb-sys:int-sap (output-stream-buffer-start stream)))
   207           (t
   208            (setf (output-stream-buffer-position stream)
   209                  new-sap)
   210            (sb-sys:int-sap sap)))))
   211 
   212 (declaim (inline write-n-bytes))
   213 (defun write-n-bytes (value n stream)
   214   (declare (optimize (space 0))
   215            (type word n))
   216   (setf (sb-sys:sap-ref-32
   217          (advance-output-stream n stream)
   218          0)
   219         value))
   220 ;;;
   221 
   222 (declaim (inline copy-mem))
   223 (defun copy-mem (from to length)
   224   (let ((words-end (- length (rem length sb-vm:n-word-bytes))))
   225     (loop for i by sb-vm:n-word-bytes below words-end
   226           do (setf (sb-sys:sap-ref-word to i)
   227                    (sb-sys:sap-ref-word from i)))
   228     (loop for i from words-end below length
   229           do (setf (sb-sys:sap-ref-8 to i)
   230                    (sb-sys:sap-ref-8 from i)))))
   231 
   232 (declaim (inline read-ascii-string-optimized))
   233 (defun read-ascii-string-optimized (length string stream)
   234   (declare (type fixnum length)
   235            (optimize (speed 3))
   236            )
   237   (sb-sys:with-pinned-objects (string)
   238     (let ((sap (advance-input-stream length stream))
   239           (string-sap (sb-sys:vector-sap string)))
   240       (copy-mem sap string-sap length)))
   241   string)
   242 (defmacro with-io-file ((stream file
   243                          &key append (direction :input))
   244                         &body body)
   245   (let ((fd-stream (gensym)))
   246     `(with-open-file (,fd-stream ,file
   247                                  :element-type '(unsigned-byte 8)
   248                                  :direction ,direction
   249                                  ,@(and (eql direction :output)
   250                                         `(:if-exists ,(if append
   251                                                           :append
   252                                                           :supersede)))
   253                                  ,@(and append
   254                                         `(:if-does-not-exist :create)))
   255        (let ((,stream (open-file ,fd-stream :direction ,direction)))
   256          (unwind-protect
   257               (progn ,@body)
   258            ,@(ecase direction
   259                (:output
   260                 `((close-output-stream ,stream)
   261                   (when *fsync-data*
   262                     (sb-posix:fdatasync
   263                      (sb-sys:fd-stream-fd ,fd-stream)))))
   264                (:input
   265                 `((close-input-stream ,stream)))))))))