1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/examples/db/xdb/io.lisp Sun Jun 16 22:15:04 2024 -0400
1.3@@ -0,0 +1,265 @@
1.4+;;; io/blob.lisp --- Blob Database IO
1.5+
1.6+;;
1.7+
1.8+;;; Code:
1.9+(in-package :xdb)
1.10+
1.11+;;; IO
1.12+(defvar *fsync-data* nil)
1.13+
1.14+(defconstant +buffer-size+ 8192)
1.15+
1.16+(deftype word () 'sb-ext:word)
1.17+
1.18+(defstruct (input-stream
1.19+ (:predicate nil))
1.20+ (fd nil :type word)
1.21+ (left 0 :type word)
1.22+ (buffer-start (sb-sys:sap-int
1.23+ (sb-alien::%make-alien (* sb-vm:n-byte-bits
1.24+ (+ +buffer-size+ 3))))
1.25+ :type word)
1.26+ (buffer-end 0 :type word)
1.27+ (buffer-position 0 :type word))
1.28+
1.29+(defstruct (output-stream
1.30+ (:predicate nil))
1.31+ (fd nil :type word)
1.32+ (buffer-start (sb-sys:sap-int
1.33+ (sb-alien::%make-alien (* sb-vm:n-byte-bits
1.34+ (+ +buffer-size+ 3))))
1.35+ :type word)
1.36+ (buffer-end 0 :type word)
1.37+ (buffer-position 0 :type word))
1.38+
1.39+(defun open-file (file-stream
1.40+ &key direction)
1.41+ (if (eql direction :output)
1.42+ (let ((output (make-output-stream
1.43+ :fd (sb-sys:fd-stream-fd file-stream))))
1.44+ (setf (output-stream-buffer-position output)
1.45+ (output-stream-buffer-start output)
1.46+ (output-stream-buffer-end output)
1.47+ (+ (output-stream-buffer-start output)
1.48+ +buffer-size+))
1.49+ output)
1.50+ (make-input-stream
1.51+ :fd (sb-sys:fd-stream-fd file-stream)
1.52+ :left (file-length file-stream))))
1.53+
1.54+(defun close-input-stream (stream)
1.55+ (sb-alien:alien-funcall
1.56+ (sb-alien:extern-alien "free"
1.57+ (function (values) sb-alien:long))
1.58+ (input-stream-buffer-start stream)))
1.59+
1.60+(defun close-output-stream (stream)
1.61+ (flush-buffer stream)
1.62+ (sb-alien:alien-funcall
1.63+ (sb-alien:extern-alien "free"
1.64+ (function (values) sb-alien:long))
1.65+ (output-stream-buffer-start stream)))
1.66+
1.67+(declaim (inline stream-end-of-file-p))
1.68+(defun stream-end-of-file-p (stream)
1.69+ (and (>= (input-stream-buffer-position stream)
1.70+ (input-stream-buffer-end stream))
1.71+ (zerop (input-stream-left stream))))
1.72+
1.73+(declaim (inline sap-ref-24))
1.74+(defun sap-ref-24 (sap offset)
1.75+ (declare (optimize speed (safety 0))
1.76+ (fixnum offset))
1.77+ (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
1.78+
1.79+(declaim (inline n-sap-ref))
1.80+(defun n-sap-ref (n sap &optional (offset 0))
1.81+ (funcall (ecase n
1.82+ (1 #'sb-sys:sap-ref-8)
1.83+ (2 #'sb-sys:sap-ref-16)
1.84+ (3 #'sap-ref-24)
1.85+ (4 #'sb-sys:sap-ref-32))
1.86+ sap
1.87+ offset))
1.88+
1.89+(declaim (inline unix-read))
1.90+(defun unix-read (fd buf len)
1.91+ (declare (optimize (sb-c::float-accuracy 0)
1.92+ (space 0)))
1.93+ (declare (type sb-unix::unix-fd fd)
1.94+ (type word len))
1.95+ (sb-alien:alien-funcall
1.96+ (sb-alien:extern-alien "read"
1.97+ (function sb-alien:int
1.98+ sb-alien:int sb-alien:long sb-alien:int))
1.99+ fd buf len))
1.100+
1.101+(declaim (inline unix-read))
1.102+(defun unix-write (fd buf len)
1.103+ (declare (optimize (sb-c::float-accuracy 0)
1.104+ (space 0)))
1.105+ (declare (type sb-unix::unix-fd fd)
1.106+ (type word len))
1.107+ (sb-alien:alien-funcall
1.108+ (sb-alien:extern-alien "write"
1.109+ (function sb-alien:int
1.110+ sb-alien:int sb-alien:long sb-alien:int))
1.111+ fd buf len))
1.112+
1.113+(defun fill-buffer (stream offset)
1.114+ (let ((length (unix-read (input-stream-fd stream)
1.115+ (+ (input-stream-buffer-start stream) offset)
1.116+ (- +buffer-size+ offset))))
1.117+ (setf (input-stream-buffer-end stream)
1.118+ (+ (input-stream-buffer-start stream) (+ length offset)))
1.119+ (decf (input-stream-left stream) length))
1.120+ t)
1.121+
1.122+(defun refill-buffer (n stream)
1.123+ (declare (type word n)
1.124+ (input-stream stream))
1.125+ (let ((left-n-bytes (- (input-stream-buffer-end stream)
1.126+ (input-stream-buffer-position stream))))
1.127+ (when (> (- n left-n-bytes)
1.128+ (input-stream-left stream))
1.129+ (error "End of file ~a" stream))
1.130+ (unless (zerop left-n-bytes)
1.131+ (setf (sb-sys:sap-ref-word (sb-sys:int-sap (input-stream-buffer-start stream)) 0)
1.132+ (n-sap-ref left-n-bytes (sb-sys:int-sap (input-stream-buffer-position stream)))))
1.133+ (fill-buffer stream left-n-bytes))
1.134+ (let ((start (input-stream-buffer-start stream)))
1.135+ (setf (input-stream-buffer-position stream)
1.136+ (+ start n)))
1.137+ t)
1.138+
1.139+(declaim (inline advance-input-stream))
1.140+(defun advance-input-stream (n stream)
1.141+ (declare (optimize (space 0))
1.142+ (type word n)
1.143+ (type input-stream stream))
1.144+ (let* ((sap (input-stream-buffer-position stream))
1.145+ (new-sap (sb-ext:truly-the word (+ sap n))))
1.146+ (declare (word sap new-sap))
1.147+ (cond ((> new-sap (input-stream-buffer-end stream))
1.148+ (refill-buffer n stream)
1.149+ (sb-sys:int-sap (input-stream-buffer-start stream)))
1.150+ (t
1.151+ (setf (input-stream-buffer-position stream)
1.152+ new-sap)
1.153+ (sb-sys:int-sap sap)))))
1.154+
1.155+(declaim (inline read-n-bytes))
1.156+(defun read-n-bytes (n stream)
1.157+ (declare (optimize (space 0))
1.158+ (type word n))
1.159+ (n-sap-ref n (advance-input-stream n stream)))
1.160+
1.161+(declaim (inline read-n-signed-bytes))
1.162+(defun read-n-signed-bytes (n stream)
1.163+ (declare (optimize speed)
1.164+ (sb-ext:muffle-conditions sb-ext:compiler-note)
1.165+ (type (integer 1 4) n))
1.166+ (funcall (ecase n
1.167+ (1 #'sb-sys:signed-sap-ref-8)
1.168+ (2 #'sb-sys:signed-sap-ref-16)
1.169+ ;; (3 )
1.170+ (4 #'sb-sys:signed-sap-ref-32))
1.171+ (advance-input-stream n stream)
1.172+ 0))
1.173+
1.174+(declaim (inline write-n-signed-bytes))
1.175+(defun write-n-signed-bytes (value n stream)
1.176+ (declare (optimize speed)
1.177+ (sb-ext:muffle-conditions sb-ext:compiler-note)
1.178+ (fixnum n))
1.179+ (ecase n
1.180+ (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0)
1.181+ value))
1.182+ (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0)
1.183+ value))
1.184+ ;; (3 )
1.185+ (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0)
1.186+ value)))
1.187+ t)
1.188+
1.189+(defun flush-buffer (stream)
1.190+ (unix-write (output-stream-fd stream)
1.191+ (output-stream-buffer-start stream)
1.192+ (- (output-stream-buffer-position stream)
1.193+ (output-stream-buffer-start stream))))
1.194+
1.195+(declaim (inline advance-output-stream))
1.196+(defun advance-output-stream (n stream)
1.197+ (declare (optimize (space 0) (safety 0))
1.198+ (type word n)
1.199+ (type output-stream stream)
1.200+ ((integer 1 4) n))
1.201+ (let* ((sap (output-stream-buffer-position stream))
1.202+ (new-sap (sb-ext:truly-the word (+ sap n))))
1.203+ (declare (word sap new-sap))
1.204+ (cond ((> new-sap (output-stream-buffer-end stream))
1.205+ (flush-buffer stream)
1.206+ (setf (output-stream-buffer-position stream)
1.207+ (+ (output-stream-buffer-start stream)
1.208+ n))
1.209+ (sb-sys:int-sap (output-stream-buffer-start stream)))
1.210+ (t
1.211+ (setf (output-stream-buffer-position stream)
1.212+ new-sap)
1.213+ (sb-sys:int-sap sap)))))
1.214+
1.215+(declaim (inline write-n-bytes))
1.216+(defun write-n-bytes (value n stream)
1.217+ (declare (optimize (space 0))
1.218+ (type word n))
1.219+ (setf (sb-sys:sap-ref-32
1.220+ (advance-output-stream n stream)
1.221+ 0)
1.222+ value))
1.223+;;;
1.224+
1.225+(declaim (inline copy-mem))
1.226+(defun copy-mem (from to length)
1.227+ (let ((words-end (- length (rem length sb-vm:n-word-bytes))))
1.228+ (loop for i by sb-vm:n-word-bytes below words-end
1.229+ do (setf (sb-sys:sap-ref-word to i)
1.230+ (sb-sys:sap-ref-word from i)))
1.231+ (loop for i from words-end below length
1.232+ do (setf (sb-sys:sap-ref-8 to i)
1.233+ (sb-sys:sap-ref-8 from i)))))
1.234+
1.235+(declaim (inline read-ascii-string-optimized))
1.236+(defun read-ascii-string-optimized (length string stream)
1.237+ (declare (type fixnum length)
1.238+ (optimize (speed 3))
1.239+ )
1.240+ (sb-sys:with-pinned-objects (string)
1.241+ (let ((sap (advance-input-stream length stream))
1.242+ (string-sap (sb-sys:vector-sap string)))
1.243+ (copy-mem sap string-sap length)))
1.244+ string)
1.245+(defmacro with-io-file ((stream file
1.246+ &key append (direction :input))
1.247+ &body body)
1.248+ (let ((fd-stream (gensym)))
1.249+ `(with-open-file (,fd-stream ,file
1.250+ :element-type '(unsigned-byte 8)
1.251+ :direction ,direction
1.252+ ,@(and (eql direction :output)
1.253+ `(:if-exists ,(if append
1.254+ :append
1.255+ :supersede)))
1.256+ ,@(and append
1.257+ `(:if-does-not-exist :create)))
1.258+ (let ((,stream (open-file ,fd-stream :direction ,direction)))
1.259+ (unwind-protect
1.260+ (progn ,@body)
1.261+ ,@(ecase direction
1.262+ (:output
1.263+ `((close-output-stream ,stream)
1.264+ (when *fsync-data*
1.265+ (sb-posix:fdatasync
1.266+ (sb-sys:fd-stream-fd ,fd-stream)))))
1.267+ (:input
1.268+ `((close-input-stream ,stream)))))))))
