io-sbcl.lisp 5.16 KB
Newer Older
Stas Boukarev's avatar
Stas Boukarev committed
1
2
3
4
5
;;; -*- Mode: Lisp -*-

;;; This software is in the public domain and is
;;; provided with absolutely no warranty.

6
(in-package #:storage)
Stas Boukarev's avatar
Stas Boukarev committed
7

8
9
10
(deftype word ()
  'sb-vm:word)

Stas Boukarev's avatar
Stas Boukarev committed
11
(defstruct mmap-stream
12
13
14
15
  (beginning)
  (length 0 :type word :read-only t)
  (sap 0 :type word)
  (end 0 :type word :read-only t))
Stas Boukarev's avatar
Stas Boukarev committed
16

Stas Boukarev's avatar
Stas Boukarev committed
17
18
19
20
21
22
23
24
25
(defun scale-file (stream size)
  (file-position stream (1- size))
  (write-byte 0 stream)
  (finish-output stream))

(defun mmap (file-stream
             &key direction size)
  (when (eql direction :output)
    (scale-file file-stream size))
26
27
28
29
30
31
32
33
34
35
36
37
38
39
  (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))))))
Stas Boukarev's avatar
Stas Boukarev committed
40
41

(defun munmap (mmap-stream)
42
  (sb-posix:munmap (mmap-stream-beginning mmap-stream)
43
                   (mmap-stream-length mmap-stream))
44
  (setf (mmap-stream-sap mmap-stream) 0))
45

46
47
48
49
(declaim (inline stream-end-of-file-p))
(defun stream-end-of-file-p (stream)
  (>= (mmap-stream-sap stream)
      (mmap-stream-end stream)))
50
51
52

;;;

Stas Boukarev's avatar
Stas Boukarev committed
53
54
55
56
57
58
(declaim (inline 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)))

Stas Boukarev's avatar
Stas Boukarev committed
59
60
61
(defun signal-end-of-file (stream)
  (error "End of file ~a" stream))

62
63
(declaim (inline advance-stream))
(defun advance-stream (n stream)
64
65
66
67
  (declare (optimize (space 0))
           (type word n))
  (let* ((sap (mmap-stream-sap stream))
         (new-position (sb-ext:truly-the word (+ sap n))))
68
    (when (> new-position
69
             (mmap-stream-end stream))
Stas Boukarev's avatar
Stas Boukarev committed
70
      (signal-end-of-file stream))
71
72
    (setf (mmap-stream-sap stream) new-position)
    (sb-sys:int-sap sap)))
73
74
75

(declaim (inline read-n-bytes))
(defun read-n-bytes (n stream)
Stas Boukarev's avatar
Stas Boukarev committed
76
77
  (declare (optimize speed)
           (sb-ext:muffle-conditions sb-ext:compiler-note)
78
           (type (integer 1 4) n))
Stas Boukarev's avatar
Stas Boukarev committed
79
80
81
82
83
84
85
  (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))
           (advance-stream n stream)
           0))
86

87
88
89
90
91
92
93
94
95
96
97
98
99
(declaim (inline read-n-signed-bytes))
(defun read-n-signed-bytes (n stream)
  (declare (optimize speed)
           (sb-ext:muffle-conditions sb-ext:compiler-note)
           (type (integer 1 4) n))
  (funcall (ecase n
             (1 #'sb-sys:signed-sap-ref-8)
             (2 #'sb-sys:signed-sap-ref-16)
             ;; (3 )
             (4 #'sb-sys:signed-sap-ref-32))
           (advance-stream n stream)
           0))

Stas Boukarev's avatar
Stas Boukarev committed
100
101
102
103
(declaim (inline write-n-bytes))
(defun write-n-bytes (value n stream)
  (declare (optimize speed)
           (fixnum n))
Stas Boukarev's avatar
Stas Boukarev committed
104
  (setf (sb-sys:sap-ref-32 (advance-stream n stream) 0) value)
105
  t)
Stas Boukarev's avatar
Stas Boukarev committed
106

107
108
109
(declaim (inline write-n-signed-bytes))
(defun write-n-signed-bytes (value n stream)
  (declare (optimize speed)
110
           (sb-ext:muffle-conditions sb-ext:compiler-note)
111
112
113
114
115
116
117
118
119
120
121
           (fixnum n))
  (ecase n
    (1 (setf (sb-sys:signed-sap-ref-8 (advance-stream n stream) 0)
             value))
    (2 (setf (sb-sys:signed-sap-ref-16 (advance-stream n stream) 0)
             value))
    ;; (3 )
    (4 (setf (sb-sys:signed-sap-ref-32 (advance-stream n stream) 0)
             value)))
  t)

122
(declaim (inline copy-mem))
123
124
(defun copy-mem (from to length)
  (loop for i below length by sb-vm:n-word-bytes
125
126
        do (setf (sb-sys:sap-ref-word to i)
                 (sb-sys:sap-ref-word from i))))
127

Stas Boukarev's avatar
Stas Boukarev committed
128
(declaim (inline read-ascii-string-optimized))
129
130
131
(defun read-ascii-string-optimized (length string stream)
  (declare (type fixnum length))
  (sb-sys:with-pinned-objects (string)
Stas Boukarev's avatar
Stas Boukarev committed
132
133
134
    (let ((mmap-sap (advance-stream length stream))
          (string-sap (sb-sys:vector-sap string)))
      (copy-mem mmap-sap string-sap length)))
135
  string)
136

Stas Boukarev's avatar
Stas Boukarev committed
137
(defun write-ascii-string-optimized (length string stream)
138
  (declare (type fixnum length))
139
  (sb-sys:with-pinned-objects (string)
Stas Boukarev's avatar
Stas Boukarev committed
140
141
142
    (let ((mmap-sap (advance-stream length stream))
          (string-sap (sb-sys:vector-sap string)))
      (copy-mem string-sap mmap-sap length))))
143

Stas Boukarev's avatar
Stas Boukarev committed
144
145
(defmacro with-io-file ((stream file &key (direction :input) size)
                        &body body)
146
  (let ((fd-stream (gensym)))
Stas Boukarev's avatar
Stas Boukarev committed
147
148
149
150
151
152
153
    `(with-open-file (,fd-stream ,file
                                 :direction (if (eql ,direction :output)
                                                :io
                                                ,direction)
                                 :if-exists :supersede
                                 :element-type '(unsigned-byte 8))
       (let ((,stream (mmap ,fd-stream :direction ,direction :size ,size)))
154
155
         (unwind-protect
              (progn ,@body)
Stas Boukarev's avatar
Stas Boukarev committed
156
157
158
159
           (progn (munmap ,stream)
                  (when (eql ,direction :output)
                    (sb-posix:fdatasync
                     (sb-sys:fd-stream-fd ,fd-stream)))))))))