Commit d1c604b5 authored by Stas Boukarev's avatar Stas Boukarev
Browse files

Rewrite SBCL I/O without using mmap(2).

parent bb17b380
......@@ -6,9 +6,7 @@
(defun save-test (type amount &key object-size)
(let ((object (create-test-object type :object-size object-size)))
(with-io-file (stream *test-file* :direction :output
:size (+ (object-size amount)
(* (object-size object) amount)))
(with-io-file (stream *test-file* :direction :output)
(write-object amount stream)
(loop repeat amount
do (write-object object stream)))))
......
......@@ -94,18 +94,6 @@
(find slot-name (class-slots class) :key #'slot-definition-name))
(defgeneric write-object (object stream))
(defgeneric object-size (object))
(defun measure-size ()
(let ((result +sequence-length+)) ;; number of classes
(map-data (lambda (class objects)
(when objects
(incf result (object-size class))
(dolist (object objects)
(incf result
(standard-object-size object))))))
(setf (fill-pointer *packages*) 0)
result))
(defun assign-ids ()
(let ((last-id 0))
......@@ -144,9 +132,6 @@
;;; NIL
(defmethod object-size ((object null))
1)
(defmethod write-object ((object null) stream)
(write-n-bytes #.(type-code 'null) 1 stream))
......@@ -188,21 +173,6 @@
(defun s-intern-existing (symbol symbols)
(vector-push-extend symbol symbols))
(defmethod object-size ((symbol symbol))
(+ 1 ;; type
(multiple-value-bind (package-id symbol-id
new-package new-symbol) (s-intern symbol)
(declare (ignore package-id symbol-id))
(cond ((and new-package new-symbol)
(+ (object-size (package-name (symbol-package symbol)))
(object-size (symbol-name symbol))))
(new-symbol
(+ +sequence-length+
(object-size (symbol-name symbol))))
(t
(+ +sequence-length+
+sequence-length+))))))
(defmethod write-object ((symbol symbol) stream)
(multiple-value-bind (package-id symbol-id
new-package new-symbol) (s-intern symbol)
......@@ -251,16 +221,6 @@
;;; Integer
(defmethod object-size ((object integer))
(+ 1 ;; tag
(typecase object
(storage-fixnum +fixnum-length+)
(t (+ 1 ;; sign
1 ;; size
(* (ceiling (integer-length (abs object))
(* +fixnum-length+ 8))
+fixnum-length+))))))
(declaim (inline sign))
(defun sign (n)
(if (minusp n)
......@@ -313,11 +273,6 @@
;;; Ratio
(defmethod object-size ((object ratio))
(+ 1
(object-size (numerator object))
(object-size (denominator object))))
(defmethod write-object ((object ratio) stream)
(write-n-bytes #.(type-code 'ratio) 1 stream)
(write-object (numerator object) stream)
......@@ -329,12 +284,6 @@
;;; Float
(defmethod object-size ((float float))
(+ 1
(etypecase float
(single-float 4)
(double-float 8))))
(defun write-8-bytes (n stream)
(write-n-bytes (ldb (byte 32 0) n) 4 stream)
(write-n-bytes (ldb (byte 64 32) n) 4 stream))
......@@ -360,11 +309,6 @@
;;; Complex
(defmethod object-size ((complex complex))
(+ 1
(object-size (realpart complex))
(object-size (imagpart complex))))
(defmethod write-object ((complex complex) stream)
(write-n-bytes #.(type-code 'complex) 1 stream)
(write-object (realpart complex) stream)
......@@ -376,9 +320,6 @@
;;; Characters
(defmethod object-size ((character character))
(+ 1 +char-length+))
(defmethod write-object ((character character) stream)
(write-n-bytes #.(type-code 'character) 1 stream)
(write-n-bytes (char-code character) +char-length+ stream))
......@@ -388,14 +329,6 @@
;;; Strings
(defmethod object-size ((string string))
(typecase string
((not simple-string) (call-next-method))
(ascii-string (+ 1 +sequence-length+ (length string)))
(t (+ 1 +sequence-length+
(* (length string)
+char-length+)))))
(defun write-ascii-string (string stream)
(declare (simple-string string))
(loop for char across string
......@@ -414,7 +347,7 @@
(simple-base-string
(write-n-bytes #.(type-code 'ascii-string) 1 stream)
(write-n-bytes (length string) +sequence-length+ stream)
(write-ascii-string-optimized (length string) string stream))
(write-ascii-string string stream))
(ascii-string
(write-n-bytes #.(type-code 'ascii-string) 1 stream)
(write-n-bytes (length string) +sequence-length+ stream)
......@@ -427,12 +360,12 @@
(declaim (inline read-ascii-string))
(defun read-ascii-string (length stream)
(let ((string (make-string length :element-type 'base-char)))
#-sbcl
;#-sbcl
(loop for i below length
do (setf (schar string i)
(code-char (read-n-bytes 1 stream))))
#+(and sbcl (or x86 x86-64))
(read-ascii-string-optimized length string stream)
;; #+(and sbcl (or x86 x86-64))
;; (read-ascii-string-optimized length string stream)
string))
(defreader ascii-string (stream)
......@@ -448,14 +381,6 @@
;;; Pathname
(defmethod object-size ((pathname pathname))
(+ 1
(object-size (pathname-name pathname))
(object-size (pathname-directory pathname))
(object-size (pathname-device pathname))
(object-size (pathname-type pathname))
(object-size (pathname-version pathname))))
(defmethod write-object ((pathname pathname) stream)
(write-n-bytes #.(type-code 'pathname) 1 stream)
(write-object (pathname-name pathname) stream)
......@@ -474,26 +399,8 @@
;;; Cons
(defun cons-size (cons)
(loop for cdr = cons then (cdr cdr)
sum (object-size (alexandria:ensure-car cdr))
while (consp cdr)))
(defmethod object-size ((list cons))
(cond ((and (alexandria:proper-list-p list)
(list-of-objects-p list))
(+ 1
(* (length list) +id-length+)
+sequence-length+))
((alexandria:circular-list-p list)
(error "Can't store circular lists"))
(t
(+ 1 (cons-size list)
1))))
(defmethod write-object ((list cons) stream)
(cond #-sbcl
((alexandria:circular-list-p list)
(cond ((alexandria:circular-list-p list)
(error "Can't store circular lists"))
((and (alexandria:proper-list-p list)
(list-of-objects-p list))
......@@ -540,15 +447,6 @@
;;; Simple-vector
(defmethod object-size ((vector vector))
(typecase vector
(simple-vector
(+ 1 ;; type
+sequence-length+
(reduce #'+ vector :key #'object-size)))
(t
(call-next-method))))
(defmethod write-object ((vector vector) stream)
(typecase vector
(simple-vector
......@@ -571,20 +469,6 @@
;;; Array
(defun array-size (array)
(loop for i below (array-total-size array)
sum (object-size (row-major-aref array i))))
(defmethod object-size ((array array))
(+ 1 ;; type
(object-size (array-dimensions array))
(if (array-has-fill-pointer-p array)
(+ 1 +sequence-length+)
2) ;; 0 + 0
(object-size (array-element-type array))
1 ;; adjustable-p
(array-size array)))
(defun boolify (x)
(if x
1
......@@ -630,20 +514,6 @@
hash-table test))
test-id))
(defun measure-hash-table-size (hash-table)
(loop for key being the hash-keys of hash-table
using (hash-value value)
sum (+ (object-size key)
(object-size value))))
(defmethod object-size ((hash-table hash-table))
(check-hash-table-test hash-table)
(+ 1
1 ;; test-id
+hash-table-length+
(measure-hash-table-size hash-table)
1)) ;; +end+
(defmethod write-object ((hash-table hash-table) stream)
(write-n-bytes #.(type-code 'hash-table) 1 stream)
(write-n-bytes (check-hash-table-test hash-table) 1 stream)
......@@ -667,17 +537,6 @@
;;; storable-class
(defmethod object-size ((class storable-class))
(unless (class-finalized-p class)
(finalize-inheritance class))
(+ 1 ;; type
(object-size (class-name class))
+sequence-length+ ;; list length
(reduce #'+ (slots-to-store class)
:key (lambda (x)
(object-size (slot-definition-name x))))
+id-length+)) ;; size of objects
(defmethod write-object ((class storable-class) stream)
(write-n-bytes #.(type-code 'storable-class) 1 stream)
(write-object (class-name class) stream)
......@@ -707,10 +566,6 @@
;;; identifiable
(defmethod object-size ((object identifiable))
(+ 1 ;; type
+id-length+))
(defmethod write-object ((object identifiable) stream)
(write-n-bytes #.(type-code 'identifiable) 1 stream)
(write-n-bytes (id object) +id-length+ stream))
......@@ -723,21 +578,7 @@
(get-instance (read-n-bytes +id-length+ stream)))
;;; standard-object
(defun standard-object-size (object)
(let ((slots (slot-locations-and-initforms (class-of object))))
(declare (simple-vector slots))
(+ 1 ;; data type
+id-length+ ;; id
(loop for (location . initform) across slots
sum (let ((value (standard-instance-access object
location)))
(if (eql value initform)
0
(+ 1 ;; slot id
(object-size value)))))
1))) ;; end-of-slots
;;;
;;; Can't use write-object method, because it would conflict with
;;; writing a pointer to a standard object
(defun write-standard-object (object stream)
......@@ -847,6 +688,5 @@
(when (storage-data storage)
(with-packages
(with-io-file (stream (or file (storage-file storage))
:direction :output
:size (measure-size))
:direction :output)
(dump-data stream))))))
;;; -*- Mode: Lisp -*-
;;; This software is in the public domain and is
;;; provided with absolutely no warranty.
(in-package #:storage-test)
(defun open-file (file-stream
&key direction size)
(declare (ignore size))
(when (eql direction :output)
(warn "Not implemented."))
(make-st-stream
:fd (sb-sys:fd-stream-fd file-stream)
:left (file-length file-stream)))
(defun close-file (stream)
(sb-alien:alien-funcall
(sb-alien:extern-alien "free"
(function (values) sb-alien:int))
(st-stream-buffer-start stream)))
(defconstant +buffer-size+ 8192)
(deftype word ()
'sb-vm:word)
(defstruct st-stream
(fd nil :type word)
(left 0 :type word)
(buffer-start (sb-sys:sap-int
(sb-alien::%make-alien (* sb-vm:n-byte-bits +buffer-size+)))
:type word)
(buffer-end 0 :type word)
(buffer-position 0 :type word))
(declaim (notinline sap-ref-24))
(defun sap-ref-24 (sap offset)
(declare (optimize speed (safety 0))
(fixnum offset))
(mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
(declaim (inline n-sap-ref))
(defun n-sap-ref (n sap &optional (offset 0))
(funcall (ecase n
(1 #'sb-sys:sap-ref-8)
(2 #'sb-sys:sap-ref-16)
(3 #'sap-ref-24)
(4 #'sb-sys:sap-ref-32))
(sb-sys:int-sap sap)
offset))
(declaim (inline unix-read))
(defun unix-read (fd buf len)
(declare (optimize (sb-c::float-accuracy 0)
(space 0)))
(declare (type sb-unix::unix-fd fd)
(type word len))
(sb-alien:alien-funcall
(sb-alien:extern-alien "read"
(function sb-alien:int
sb-alien:int sb-alien:int sb-alien:int))
fd buf len))
(defun unix-write (fd buf len)
(declare (type sb-unix::unix-fd fd)
(type word len))
(sb-alien:alien-funcall
(sb-alien:extern-alien "write"
(function sb-alien:int
sb-alien:int sb-alien:int sb-alien:int))
fd buf len))
(declaim (inline fill-buffer))
(defun fill-buffer (stream offset)
(let ((length (unix-read (st-stream-fd stream)
(+ (st-stream-buffer-start stream) offset)
(- +buffer-size+ offset))))
(setf (st-stream-buffer-end stream)
(+ (st-stream-buffer-start stream) (+ length offset)))
(decf (st-stream-left stream) length))
t)
(declaim (notinline refill-buffer))
(defun refill-buffer (n stream)
(declare (optimize speed (safety 0))
(type (integer 0 4) n)
(st-stream stream))
(let ((left-n-bytes (sb-ext:truly-the word (- (st-stream-buffer-end stream)
(st-stream-buffer-position stream)))))
(when (> (the word (- n left-n-bytes))
(st-stream-left stream))
(error "End of file ~a" stream))
(unless (zerop left-n-bytes)
(setf (sb-sys:sap-ref-word (sb-sys:int-sap (st-stream-buffer-start stream)) 0)
(n-sap-ref left-n-bytes (st-stream-buffer-position stream))))
(fill-buffer stream left-n-bytes))
(let ((start (st-stream-buffer-start stream)))
(setf (st-stream-buffer-position stream)
(sb-ext:truly-the u32 (+ start n))))
t)
(declaim (inline advance-stream))
(defun advance-stream (n stream)
(declare (optimize (space 0))
(type word n)
(type st-stream stream))
(let* ((sap (st-stream-buffer-position stream))
(new-sap (sb-ext:truly-the word (+ sap n))))
(declare (word sap new-sap))
(cond ((> new-sap (st-stream-buffer-end stream))
(- new-sap (st-stream-buffer-end stream))
(refill-buffer n stream)
(st-stream-buffer-start stream))
(t
(setf (st-stream-buffer-position stream)
new-sap)
sap))))
(declaim (inline read-n-bytes))
(defun read-n-bytes (n stream)
(declare (optimize (space 0))
(type word n))
(n-sap-ref n (advance-stream n stream)))
(defun flush-buffer (stream))
(defun write-n-bytes (n stream)
(declare (optimize (space 0))
(type word n))
(n-sap-ref n (advance-stream n stream)))
;;;
(defmacro with-io-file ((stream file &key (direction :input) size)
&body body)
(let ((fd-stream (gensym)))
`(with-open-file (,fd-stream ,file
:direction (if (eql ,direction :output)
:io
,direction)
:if-exists :supersede
:element-type '(unsigned-byte 8))
(let ((,stream (open-file ,fd-stream :direction ,direction :size ,size)))
(unwind-protect
(progn ,@body)
(close-file ,stream)
(when (eql ,direction :output)
(sb-posix:fdatasync
(sb-sys:fd-stream-fd ,fd-stream))))))))
(defun test ()
(declare (optimize speed (safety 0)))
(storage-test::with-io-file (stream "/home/stas/test-io-file")
(loop repeat 6276930
with count fixnum
if (evenp
(storage-test::read-n-bytes 1 stream))
do (setf count (sb-ext:truly-the fixnum (1+ count)))
finally (return count))))
(defun test-2 ()
(declare (optimize speed (safety 0)))
(storage::with-io-file (stream "/home/stas/test-io-file")
(loop repeat 6276930
with count fixnum
if (evenp
(storage::read-n-bytes 1 stream))
do (setf count (sb-ext:truly-the fixnum (1+ count)))
finally (return count))))
......@@ -3,93 +3,156 @@
;;; This software is in the public domain and is
;;; provided with absolutely no warranty.
(defpackage #:storage-test
(:use :cl))
(in-package #:storage)
(deftype word ()
'sb-vm:word)
(defstruct mmap-stream
(beginning)
(length 0 :type word :read-only t)
(sap 0 :type word)
(end 0 :type word :read-only t))
(defun scale-file (stream size)
(sb-posix:ftruncate (sb-sys:fd-stream-fd stream)
size))
(defun mmap (file-stream
&key direction size)
(when (eql direction :output)
(scale-file file-stream size))
(let* ((sap (sb-posix:mmap nil
(or size (file-length file-stream))
(ecase direction
(:input sb-posix:prot-read)
(:output sb-posix:prot-write))
sb-posix:map-shared
(sb-sys:fd-stream-fd file-stream)
0))
(sap-int (sb-sys:sap-int sap)))
(make-mmap-stream
:beginning sap
:sap sap-int
:length (or size (file-length file-stream))
:end (+ sap-int (or size (file-length file-stream))))))
(defun munmap (mmap-stream)
(sb-posix:munmap (mmap-stream-beginning mmap-stream)
(mmap-stream-length mmap-stream))
(setf (mmap-stream-sap mmap-stream) 0))
(defun open-file (file-stream
&key direction)
(if (eql direction :output)
(let ((output (make-output-stream
:fd (sb-sys:fd-stream-fd file-stream))))
(setf (output-stream-buffer-position output)
(output-stream-buffer-start output)
(output-stream-buffer-end output)
(+ (output-stream-buffer-start output)
+buffer-size+))
output)
(make-input-stream
:fd (sb-sys:fd-stream-fd file-stream)
:left (file-length file-stream))))
(defun close-input-stream (stream)
(sb-alien:alien-funcall
(sb-alien:extern-alien "free"
(function (values) sb-alien:long))
(input-stream-buffer-start stream)))
(defun close-output-stream (stream)
(flush-buffer stream)
(sb-alien:alien-funcall
(sb-alien:extern-alien "free"
(function (values) sb-alien:long))
(output-stream-buffer-start stream)))
(defconstant +buffer-size+ (* 8192 2))
(deftype word () 'sb-vm:word)
(defstruct (input-stream
(:predicate nil))
(fd nil :type word)
(left 0 :type word)
(buffer-start (sb-sys:sap-int
(sb-alien::%make-alien (* sb-vm:n-byte-bits +buffer-size+)))
:type word)
(buffer-end 0 :type word)
(buffer-position 0 :type word))
(declaim (inline stream-end-of-file-p))
(defun stream-end-of-file-p (stream)
(>= (mmap-stream-sap stream)
(mmap-stream-end stream)))
(and (>= (input-stream-buffer-position stream)
(input-stream-buffer-end stream))
(zerop (input-stream-left stream))))
;;;
(defstruct (output-stream
(:predicate nil))
(fd nil :type word)
(buffer-start (sb-sys:sap-int
(sb-alien::%make-alien (* sb-vm:n-byte-bits +buffer-size+)))
:type word)
(buffer-end 0 :type word)
(buffer-position 0 :type word))
(declaim (inline sap-ref-24 (setf sap-ref-24)))
(declaim (inline sap-ref-24))
(defun sap-ref-24 (sap offset)
(declare (optimize speed (safety 0))
(fixnum offset))
(logior (ash (sb-sys:sap-ref-16 sap (1+ offset)) 8)
(sb-sys:sap-ref-8 sap offset)))
(mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
(defun (setf sap-ref-24) (value sap offset)
(declare (optimize speed (safety 0))
(fixnum offset)
((unsigned-byte 24) value))
(setf (sb-sys:sap-ref-16 sap offset) (mask-field (byte 16 0) value))
(setf (sb-sys:sap-ref-8 sap (+ offset 2)) (ash value -16)))
(declaim (inline n-sap-ref))
(defun n-sap-ref (n sap &optional (offset 0))
(funcall (ecase n
(1 #'sb-sys:sap-ref-8)
(2 #'sb-sys:sap-ref-16)
(3 #'sap-ref-24)
(4 #'sb-sys:sap-ref-32))
(sb-sys:int-sap sap)
offset))
(defun signal-end-of-file (stream)
(error "End of file ~a" stream))
(declaim (inline unix-read))
(defun unix-read (fd buf len)
(declare (optimize (sb-c::float-accuracy 0)
(space 0)))
(declare (type sb-unix::unix-fd fd)
(type word len))