source: project/release/3/sendfile/trunk/sendfile.scm @ 11953

Last change on this file since 11953 was 11953, checked in by certainty, 13 years ago

parameterize the chunksize.
prepare c-impl of sendfile so that we can distinguish errors from
waits for io so that we can yield control to other threads.

File size: 12.9 KB
Line 
1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;; Sendfile Egg for the Chicken Scheme system.
3;;             
4;; This eggs provides a capability to utilize
5;; the sendfile system-call. However it is
6;; not a mere wrapper to call this function if
7;; available, but rather its semantics may be stated as:
8;;
9;; "Send the file as fast as possible to its destination."
10;;
11;; Please report bugs to <http://trac.callcc.org/>
12;;
13;; Copyright (c) 2007 David Krentzlin
14;;
15;;
16;; Thanks to Peter Bex for supplying patches and testing it on NetBSD
17;;
18;; Permission is hereby granted, free of charge, to any person obtaining a
19;; copy of this software and associated documentation files (the "Software"),
20;; to deal in the Software without restriction, including without limitation
21;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
22;; and/or sell copies of the Software, and to permit persons to whom the
23;; Software is furnished to do so, subject to the following conditions:
24;;
25;; The above copyright notice and this permission notice shall be included
26;; in all copies or substantial portions of the Software.
27;;
28;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
29;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
30;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
31;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
32;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
33;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
34;; OTHER DEALINGS IN THE SOFTWARE.
35;;
36;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37
38
39
40
41;;sendfile attempts to send a file from the sourcefile out to a tcp-socket
42;;as fast as possible. On systems that provide sendfile(2) syscalls
43;;this syscall will be used if apropriate on other systems memory-mapped write
44;;will be used to emulate this. And if even this fails a normal system-write
45;;will be used to send the data
46
47
48;;TODO
49;;add -D_FILE_OFFSET_BITS=64 -D_LARGEFILE_SOURCE -D_LARGE_FILES to sendfile.setup
50
51(declare
52 (usual-integrations)
53 (uses extras scheduler srfi-13)
54
55 (no-procedure-checks-for-usual-bindings)
56 (export
57  sendfile:force-implementation
58  *sendfile:last-selected-implementation*
59  sendfile:read-write-buffer-size
60  sendfile:implementation-selector
61  sendfile:mmapped
62  sendfile:sendfile
63  sendfile:read-write-loop/port
64  sendfile:read-write-loop/fd
65  sendfile:os-dep:sendfile-available?
66  sendfile:os-dep:mmap-available?
67  sendfile:write-timeout
68  sendfile))
69
70(foreign-declare #<<EOL
71#include "os-dep.h"
72EOL
73)
74(use posix lolevel srfi-4)
75
76(define strerror (foreign-lambda c-string "strerror" int))
77
78
79
80;;what type of system do we have?
81(define-foreign-variable %sendfile:word-size int "C_WORD_SIZE")
82
83
84;;is the syscall present?
85(define-foreign-variable %sendfile:have-native-sendfile int "HAVE_SENDFILE")
86
87;;do we have mmap?
88(define-foreign-variable %sendfile:have-mmap int "HAVE_MMAP")
89(define-foreign-variable %sendfile:have-madvise int "HAVE_MADVISE")
90(define-foreign-variable %sendfile:madvise-sequential int "MADV_SEQUENTIAL")
91
92
93(define-foreign-variable %sendfile:bufsize int "BUFSIZ")
94
95;;the sendfile implementation
96;;the off_t parameter is a flonum
97;;as file-size returns a flonum on big files
98(define %sendfile:sendfile-implementation
99  (foreign-lambda double "sendfile_implementation" int int double unsigned-integer))
100
101
102(define sendfile:os-dep:sendfile-available? (= %sendfile:have-native-sendfile 1))
103(define sendfile:os-dep:mmap-available? (= %sendfile:have-mmap 1))
104
105;;the buffer used in read write loops
106;;the client may adjust this to meet its need
107(define sendfile:read-write-buffer-size (make-parameter %sendfile:bufsize))
108
109
110;;biggest unsigned integer
111;(define *sendfile:chunk-size* (inexact->exact (- (expt 2 (- %sendfile:word-size 3)) 1)))
112
113(define (kilobytes what) (* what 1024))
114(define (megabytes what) (* (kilobytes what) 1024))
115
116
117(define sendfile:chunk-size (make-parameter 512))
118
119(define (sendfile:madvise buff len behav)
120  (if (= %sendfile:have-madvise 1)
121      ((foreign-lambda int "madvise" (pointer char) unsigned-integer int) buff len behav)))
122     
123
124;;compute the next chunk to send
125;;if total-length - offset is bigger than the biggest
126;;integer on the system we send the biggest integer
127;;otherwise we send the difference
128(define (sendfile:next-chunk-size len offset)
129    (if (> (- len offset) (sendfile:chunk-size))
130        (sendfile:chunk-size)
131        (- len offset)))
132
133
134(define (make-exn-condition location message arguments)
135  (apply make-property-condition
136    'exn
137    (append
138     (if location (list 'location location) '())
139     (if message (list 'message message) '())
140     (if (and arguments (not (null? arguments))) (list 'arguments arguments) '()))) )
141
142(define (make-sendfile-condition location message arguments)
143  (make-composite-condition
144   (make-exn-condition location message arguments)
145   (make-property-condition 'sendfile)) )
146
147(define (errno-argument)
148  (let ((err (errno)))
149    (if (zero? err)
150        '()
151        (let ((str (strerror err)))
152          (if (or (not str) (zero? (string-length str)))
153              (list (number->string err))
154              (list str) ) ) ) ) )
155
156(define (sendfile:error msg . args)
157  (abort (make-sendfile-condition #f msg (append (errno-argument) args))))
158
159
160(define *sendfile:last-selected-implementation* #f)
161
162
163;;copied from tcp
164(define (sendfile:yield)
165  (##sys#call-with-current-continuation
166   (lambda (return)
167     (let ((ct ##sys#current-thread))
168       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
169       (##sys#schedule) ) ) ) )
170
171
172(define sendfile:write-timeout (make-parameter #f))
173
174;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
175;; Implementations
176;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
177
178;;posix mmapped send
179;;as we're working with non-blocking IO
180;;EAGAIN is equal to EWOULDBLOCK
181(define (sendfile:mmapped src dst len)
182  (set!  *sendfile:last-selected-implementation* 'mmapped)
183 
184  (unless sendfile:os-dep:mmap-available?
185    (sendfile:error "mmap is not available on this system"))
186
187  (define sys-write (foreign-lambda integer "write" integer c-pointer unsigned-integer))
188
189  ;;TODO adjust this to send BUFSIZE blocks at once
190  ;;to minimize the waits
191  (define (send-chunk size ptr write-timeout)
192    (when (> size (kilobytes 64))
193        (sendfile:madvise ptr size %sendfile:madvise-willneed))
194   
195    (let loop ((left size) (work-ptr (pointer-offset ptr 0)))
196      (cond
197       ((zero? left) #t)
198       (else
199        (let ((result (sys-write dst work-ptr left)))
200          (cond
201           ((and (negative? result) (= errno/again (##sys#update-errno)))
202            (when write-timeout
203              (##sys#thread-block-for-timeout!
204               ##sys#current-thread
205               (fx+ (##sys#fudge 16) write-timeout)))
206            (##sys#thread-block-for-i/o! ##sys#current-thread dst #f)
207            (sendfile:yield)
208            (when (##sys#slot ##sys#current-thread 13)
209              (sendfile:error "write operation timed out"))
210            (loop left work-ptr))
211           ((negative? result) #f)
212           (else
213            (loop (- left result) (pointer-offset work-ptr result)))))))))
214
215 
216  (parameterize ((sendfile:chunk-size (kilobytes 512)))
217    (let loop ((offset 0.0))
218      (cond
219       ((= offset len) len)
220       (else
221        (let* ((next-chunk (sendfile:next-chunk-size len offset))
222               (mem-file (map-file-to-memory #f next-chunk prot/read map/shared src offset))
223               (write-timeout (sendfile:write-timeout)))
224          (unless (send-chunk next-chunk (memory-mapped-file-pointer mem-file) write-timeout)
225            (unmap-file-from-memory mem-file)
226            (##sys#update-errno)
227            (sendfile:error "write failed"))
228          (unmap-file-from-memory mem-file)
229          (loop (+ offset next-chunk))))))))
230             
231                       
232;;the interface to the sendfile-implementation
233;;as we're working with non-blocking IO
234;;EAGAIN is equal to EWOULDBLOCK
235;;MAKE THE WRITE LOOP AN INNER LOOP
236;;SO THAT ONLY THE ACTUAL SYSCALL IS REDONE AND NOT THE CALCULATION
237(define (sendfile:sendfile src dst len )
238  (set!  *sendfile:last-selected-implementation* 'sendfile)
239 
240  (unless sendfile:os-dep:sendfile-available?
241    (sendfile:error "sendfile is not available on this system"))
242  (parameterize ((sendfile:chunk-size (inexact->exact (- (expt 2 (- %sendfile:word-size 3)) 1))))
243    (let loop ((offset 0.0))
244      (cond
245       ((= offset len)  len)
246       (else
247        (let* ((next-chunk (sendfile:next-chunk-size len offset))
248               (new-offset (%sendfile:sendfile-implementation src dst offset next-chunk)))
249          (cond
250           ((negative? new-offset)
251            (##sys#update-errno)
252            (sendfile:error "sendfile failed"))
253           (else
254            (loop new-offset)))))))))
255       
256
257     
258;;as we're working with non-blocking IO
259;;EAGAIN is equal to EWOULDBLOCK
260;;TODO: get rid of the copy due to (substring)/ (substring/shared)
261
262(define (sendfile:read-write-loop/port src dst len)
263   (set!  *sendfile:last-selected-implementation* 'read-write-loop)
264   
265    (let* ((buffsize (sendfile:read-write-buffer-size))
266           (buffer (make-string buffsize)))
267      (let loop ((n len))
268        (if (not (positive? n))
269            len
270            (let* ((to-read (fxmin buffsize (inexact->exact n)))
271                   (read-bytes (cadr (file-read src to-read buffer))))
272              (display (substring buffer 0 read-bytes) dst)
273              (loop (- n read-bytes)))))))
274
275 
276(define (sendfile:read-write-loop/fd src dst len )
277  (set!  *sendfile:last-selected-implementation* 'read-write-loop)
278 
279  (let* ((buff-size (sendfile:read-write-buffer-size))
280         (buffer (make-string buff-size))
281         (write-timeout (sendfile:write-timeout))
282         (write/offset (foreign-lambda* int ((int dst) (c-string buff) (unsigned-integer offset) (unsigned-integer bytes))
283                                        "C_return(write(dst,buff + offset,bytes));")))
284   
285     (define (write-bytes size)
286       (let loop ((left size) (offset 0))
287        (let ((written-bytes (write/offset dst buffer offset left)))
288          (cond
289           ((= 0 left) #t)
290           ((and (negative? written-bytes) (= errno/again (##sys#update-errno)))
291            (when write-timeout
292              (##sys#thread-block-for-timeout!
293               ##sys#current-thread
294               (fx+ (##sys#fudge 16) write-timeout)))
295            (##sys#thread-block-for-i/o! ##sys#current-thread dst #f)
296            (sendfile:yield)
297            (when (##sys#slot ##sys#current-thread 13)
298              (sendfile:error "write operation timed out"))
299            (loop left offset)) ;;try again
300           ((negative? written-bytes)
301            (##sys#update-errno)
302            (sendfile:error "write failed"))
303           (else
304            (loop (- left written-bytes) (+ offset written-bytes)))))))
305   
306    (let loop ((n len))
307      (cond
308       ((not (positive? n)) len)
309       (else
310        (let* ((shall-read (if (> n buff-size) buff-size (inexact->exact n)))
311               (read-bytes (cadr (file-read src shall-read buffer))))
312          (write-bytes read-bytes)
313          (loop (- n read-bytes))))))))
314
315;;=============================== HIGHER LEVEL INTERFACE =======================================================
316
317(define (sendfile:default-selector len)
318  (cond
319   ((< (megabytes 1)) sendfile:read-write-loop/fd)
320   (sendfile:os-dep:sendfile-available? sendfile:sendfile)
321   (sendfile:os-dep:mmap-available? sendfile:mmapped)
322   (else sendfile:read-write-loop/fd)))
323
324
325(define (sendfile:port-has-fd? obj)
326  (unless (port? obj)
327    (sendfile:error "supplied argument is not a port"))
328  (handle-exceptions exn #f (port->fileno obj) #t))
329
330(define (->fileno obj)
331    (cond
332     ((fixnum? obj) obj)
333     ((port? obj) (port->fileno obj))
334     (else (sendfile:error "supplied argument is neither port nor descriptor"))))
335
336;;set to either 'sendfile 'mmapped 'read-write or 'nothing
337(define sendfile:force-implementation (make-parameter 'nothing))
338
339(define sendfile:implementation-selector (make-parameter sendfile:default-selector))
340
341(define (sendfile src dst)
342  (let ((size (file-size src)))
343    (if (and (port? dst) (not (sendfile:port-has-fd? dst)))
344        (impl:read-write-loop/port src dst size)
345        (let ((src (->fileno src))
346              (dst (->fileno dst)))
347          (case (sendfile:force-implementation)
348            ((sendfile) (sendfile:sendfile src dst size))
349            ((mmapped) (sendfile:mmapped src dst size))
350            ((read-write) (sendfile:read-write-loop/fd src dst size))
351            ((nothing)
352             (let ((impl ((sendfile:implementation-selector) size)))
353               (impl src dst size)))
354            (else
355             (sendfile:error "invalid implementation forced. Allowed values are (sendfile mmapped read-write nothing)")))))))
356
357
358 
359
360                         
361                         
362
363
364     
365
366
367
368                             
369                         
370 
371
372
373                           
374
375
376
377
378 
379   
Note: See TracBrowser for help on using the repository browser.