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

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

parent bb17b380

benchmarks.lisp

+1 −3
Original line number Diff line number Diff line
@@ -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)))))

disk.lisp

+7 −167
Original line number Diff line number Diff line
@@ -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))))))

io-sbcl-2.lisp

deleted100644 → 0
+0 −171
Original line number Diff line number Diff line 
;;; -*- 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))))

io-sbcl.lisp

+192 −105

File changed.

Preview size limit exceeded, changes collapsed.