io-sbcl.lisp 13.3 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

Stas Boukarev's avatar
Stas Boukarev committed
8
9
10
11
(defconstant +buffer-size+ 8192)

(deftype word () 'sb-vm:word)

12
13
14
(defun allocate-buffer ()
  (sb-sys:sap-int
   (sb-alien:alien-sap
15
16
17
18
    (sb-alien:make-alien char
                         ;; alignment
                         (+ +buffer-size+
                            (1- sb-vm:n-word-bytes))))))
19

Stas Boukarev's avatar
Stas Boukarev committed
20
21
22
23
(defstruct (input-stream
            (:predicate nil))
  (fd nil :type word)
  (left 0 :type word)
24
  (buffer-start (allocate-buffer)
Stas Boukarev's avatar
Stas Boukarev committed
25
26
27
28
29
30
31
   :type word)
  (buffer-end 0 :type word)
  (buffer-position 0 :type word))

(defstruct (output-stream
            (:predicate nil))
  (fd nil :type word)
32
  (buffer-start (allocate-buffer)
Stas Boukarev's avatar
Stas Boukarev committed
33
34
35
36
                :type word)
  (buffer-end 0 :type word)
  (buffer-position 0 :type word))

37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
(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)))

65
66
(declaim (inline stream-end-of-file-p))
(defun stream-end-of-file-p (stream)
67
68
69
  (and (>= (input-stream-buffer-position stream)
           (input-stream-buffer-end stream))
       (zerop (input-stream-left stream))))
70

71
(declaim (inline sap-ref-24))
Stas Boukarev's avatar
Stas Boukarev committed
72
73
74
(defun sap-ref-24 (sap offset)
  (declare (optimize speed (safety 0))
           (fixnum offset))
75
  (mask-field (byte 24 0) (sb-sys:sap-ref-32 sap offset)))
76

77
78
79
80
81
82
83
(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))
Stas Boukarev's avatar
Stas Boukarev committed
84
           sap
85
           offset))
Stas Boukarev's avatar
Stas Boukarev committed
86

87
88
(declaim (inline unix-read))
(defun unix-read (fd buf len)
89
  (declare (type word fd len))
90
91
92
93
94
  (sb-alien:alien-funcall
   (sb-alien:extern-alien "read"
                          (function sb-alien:int
                                    sb-alien:int sb-alien:long sb-alien:int))
   fd buf len))
Stas Boukarev's avatar
Stas Boukarev committed
95

96
(declaim (inline unix-write))
97
(defun unix-write (fd buf len)
98
  (declare (type word fd len))
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
  (sb-alien:alien-funcall
   (sb-alien:extern-alien "write"
                          (function sb-alien:int
                                    sb-alien:int sb-alien:long sb-alien:int))
   fd buf len))

(defun fill-buffer (stream offset)
  (let ((length (unix-read (input-stream-fd stream)
                           (+ (input-stream-buffer-start stream) offset)
                           (- +buffer-size+ offset))))
    (setf (input-stream-buffer-end stream)
          (+ (input-stream-buffer-start stream) (+ length offset)))
    (decf (input-stream-left stream) length))
  t)

(defun refill-buffer (n stream)
  (declare (type word n)
           (input-stream stream))
  (let ((left-n-bytes (- (input-stream-buffer-end stream)
                         (input-stream-buffer-position stream))))
    (when (> (- n left-n-bytes)
             (input-stream-left stream))
      (error "End of file ~a" stream))
    (unless (zerop left-n-bytes)
123
124
125
126
      (setf (sb-sys:sap-ref-word
             (sb-sys:int-sap (input-stream-buffer-start stream)) 0)
            (n-sap-ref left-n-bytes
                       (sb-sys:int-sap (input-stream-buffer-position stream)))))
127
128
129
130
131
132
133
134
    (fill-buffer stream left-n-bytes))
  (let ((start (input-stream-buffer-start stream)))
    (setf (input-stream-buffer-position stream)
          (+ start n)))
  t)

(declaim (inline advance-input-stream))
(defun advance-input-stream (n stream)
135
  (declare (type (and (integer 1) word) n)
136
137
138
139
140
141
           (type input-stream stream))
  (let* ((sap (input-stream-buffer-position stream))
         (new-sap (sb-ext:truly-the word (+ sap n))))
    (declare (word sap new-sap))
    (cond ((> new-sap (input-stream-buffer-end stream))
           (refill-buffer n stream)
Stas Boukarev's avatar
Stas Boukarev committed
142
           (sb-sys:int-sap (input-stream-buffer-start stream)))
143
144
145
          (t
           (setf (input-stream-buffer-position stream)
                 new-sap)
Stas Boukarev's avatar
Stas Boukarev committed
146
           (sb-sys:int-sap sap)))))
147
148
149

(declaim (inline read-n-bytes))
(defun read-n-bytes (n stream)
150
  (declare (type (integer 1 4) n))
151
  (n-sap-ref n (advance-input-stream n stream)))
152

153
154
155
156
157
158
159
160
161
162
(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))
Stas Boukarev's avatar
Stas Boukarev committed
163
           (advance-input-stream n stream)
164
165
166
167
168
           0))

(declaim (inline write-n-signed-bytes))
(defun write-n-signed-bytes (value n stream)
  (declare (optimize speed)
169
           (sb-ext:muffle-conditions sb-ext:compiler-note)
170
171
           (fixnum n))
  (ecase n
Stas Boukarev's avatar
Stas Boukarev committed
172
    (1 (setf (sb-sys:signed-sap-ref-8 (advance-output-stream n stream) 0)
173
             value))
Stas Boukarev's avatar
Stas Boukarev committed
174
    (2 (setf (sb-sys:signed-sap-ref-16 (advance-output-stream n stream) 0)
175
176
             value))
    ;; (3 )
Stas Boukarev's avatar
Stas Boukarev committed
177
    (4 (setf (sb-sys:signed-sap-ref-32 (advance-output-stream n stream) 0)
178
179
180
             value)))
  t)

181
182
183
184
185
186
187
188
(defun flush-buffer (stream)
  (unix-write (output-stream-fd stream)
              (output-stream-buffer-start stream)
              (- (output-stream-buffer-position stream)
                 (output-stream-buffer-start stream))))

(declaim (inline advance-output-stream))
(defun advance-output-stream (n stream)
189
  (declare (optimize (safety 0))
190
191
192
193
194
195
196
197
198
199
200
           (type word n)
           (type output-stream stream)
           ((integer 1 4) n))
  (let* ((sap (output-stream-buffer-position stream))
         (new-sap (sb-ext:truly-the word (+ sap n))))
    (declare (word sap new-sap))
    (cond ((> new-sap (output-stream-buffer-end stream))
           (flush-buffer stream)
           (setf (output-stream-buffer-position stream)
                 (+ (output-stream-buffer-start stream)
                    n))
Stas Boukarev's avatar
Stas Boukarev committed
201
           (sb-sys:int-sap (output-stream-buffer-start stream)))
202
203
204
          (t
           (setf (output-stream-buffer-position stream)
                 new-sap)
Stas Boukarev's avatar
Stas Boukarev committed
205
           (sb-sys:int-sap sap)))))
206
207
208
209
210
211

(declaim (inline write-n-bytes))
(defun write-n-bytes (value n stream)
  (declare (optimize (space 0))
           (type word n))
  (setf (sb-sys:sap-ref-32
Stas Boukarev's avatar
Stas Boukarev committed
212
         (advance-output-stream n stream)
213
214
215
216
         0)
        value))
;;;

217
(declaim (inline copy-mem))
218
(defun copy-mem (from to length)
219
  (declare (word length))
220
221
222
  (loop for i fixnum by sb-vm:n-word-bytes to length
        do (setf (sb-sys:sap-ref-word to i)
                 (sb-sys:sap-ref-word from i))))
223

Stas Boukarev's avatar
Stas Boukarev committed
224
(declaim (inline read-ascii-string-optimized))
225
(defun read-ascii-string-optimized (length string stream)
226
227
228
  (declare (type word length)
           (optimize speed)
           (sb-ext:muffle-conditions sb-ext:compiler-note))
229
  (sb-sys:with-pinned-objects (string)
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
    (let* ((sap (input-stream-buffer-position stream))
           (string-sap (sb-sys:vector-sap string))
           (new-sap (sb-ext:truly-the word (+ sap length))))
      (declare (type word sap new-sap))
      (cond ((<= new-sap (input-stream-buffer-end stream))
             (copy-mem (sb-sys:int-sap sap) string-sap length)
             (setf (input-stream-buffer-position stream)
                   new-sap))
            ((<= length +buffer-size+)
             (let* ((start (input-stream-buffer-start stream))
                    (left (- (input-stream-buffer-end stream) sap))
                    (left-length (sb-ext:truly-the word (- length left))))
               (declare (word left left-length))
               (when (> left-length (input-stream-left stream))
                 (error "End of file ~a" stream))
               (copy-mem (sb-sys:int-sap sap) string-sap left)
               (fill-buffer stream 0)
               (copy-mem (sb-sys:int-sap start)
                         (sb-sys:sap+ string-sap left) left-length)
               (setf (input-stream-buffer-position stream)
                     (sb-ext:truly-the word (+ start left-length)))))
            (t
             (error "Strings of more than ~a are not supported yet."
                    +buffer-size+)))))
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
  string)

(declaim (inline write-ascii-string-optimized))
(defun write-ascii-string-optimized (string stream)
  (declare (optimize speed)
           (simple-base-string string)
           (sb-ext:muffle-conditions sb-ext:compiler-note))
  (sb-sys:with-pinned-objects (string)
    (let* ((length (length string))
           (position (output-stream-buffer-position stream))
           (string-sap (sb-sys:vector-sap string))
           (new-position (sb-ext:truly-the word (+ position length))))
      (declare (type word position new-position))
      (cond ((<= new-position (output-stream-buffer-end stream))
             (copy-mem string-sap (sb-sys:int-sap position) length)
             (setf (output-stream-buffer-position stream)
                   new-position))
            ((<= length +buffer-size+)
             (let* ((start (output-stream-buffer-start stream))
                    (left (- (output-stream-buffer-end stream) position))
                    (left-length (sb-ext:truly-the word (- length left))))
               (declare (word left left-length))
               (copy-mem string-sap (sb-sys:int-sap position) left)
277
278
               (setf (output-stream-buffer-position stream)
                     (output-stream-buffer-end stream))
279
280
281
282
283
284
285
286
               (flush-buffer stream)
               (copy-mem (sb-sys:sap+ string-sap left)
                         (sb-sys:int-sap start) left-length)
               (setf (output-stream-buffer-position stream)
                     (sb-ext:truly-the word (+ start left-length)))))
            (t
             (error "Strings of more than ~a are not supported yet."
                    +buffer-size+)))))
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
  string)

(declaim (inline copy-mem-non-base-string))
(defun copy-mem-non-base-string (from to length)
  (declare (word length)
           (optimize (safety 0)))
  (loop for string-index fixnum by 4
        for i fixnum below length
        do (setf (sb-sys:sap-ref-8 to i)
                 (sb-sys:sap-ref-8 from string-index))))

(declaim (inline write-ascii-non-base-string-optimized))
(defun write-ascii-non-base-string-optimized (string stream)
  (declare (optimize speed)
           (simple-string string)
           (sb-ext:muffle-conditions sb-ext:compiler-note))
  (sb-sys:with-pinned-objects (string)
    (let* ((length (length string))
           (position (output-stream-buffer-position stream))
           (string-sap (sb-sys:vector-sap string))
           (new-position (sb-ext:truly-the word (+ position length))))
      (declare (type word position new-position))
      (cond ((<= new-position (output-stream-buffer-end stream))
             (copy-mem-non-base-string string-sap (sb-sys:int-sap position) length)
             (setf (output-stream-buffer-position stream)
                   new-position))
            ((<= length +buffer-size+)
             (let* ((start (output-stream-buffer-start stream))
                    (left (- (output-stream-buffer-end stream) position))
                    (left-length (sb-ext:truly-the word (- length left))))
               (declare (word left left-length))
               (copy-mem-non-base-string string-sap (sb-sys:int-sap position) left)
               (setf (output-stream-buffer-position stream)
                     (output-stream-buffer-end stream))
               (flush-buffer stream)
               (copy-mem-non-base-string (sb-sys:sap+ string-sap left)
                                         (sb-sys:int-sap start) left-length)
               (setf (output-stream-buffer-position stream)
                     (sb-ext:truly-the word (+ start left-length)))))
            (t
             (error "Strings of more than ~a are not supported yet."
                    +buffer-size+)))))
329
  string)
330

331
;;;
332

333
334
(defmacro with-io-file ((stream file
                         &key append (direction :input))
Stas Boukarev's avatar
Stas Boukarev committed
335
                        &body body)
336
  (let ((fd-stream (gensym)))
Stas Boukarev's avatar
Stas Boukarev committed
337
    `(with-open-file (,fd-stream ,file
338
339
340
341
342
343
344
                                 :element-type '(unsigned-byte 8)
                                 :direction ,direction
                                 ,@(and (eql direction :output)
                                        `(:if-exists ,(if append
                                                          :append
                                                          :supersede))))
       (let ((,stream (open-file ,fd-stream :direction ,direction)))
345
346
         (unwind-protect
              (progn ,@body)
347
348
349
350
351
352
353
           ,@(ecase direction
               (:output
                `((close-output-stream ,stream)
                  (sb-posix:fdatasync
                   (sb-sys:fd-stream-fd ,fd-stream))))
               (:input
                `((close-input-stream ,stream)))))))))