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