source: project/release/4/sendfile/trunk/sendfile.scm @ 11954

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

prepare c-impl so that we can distinguish errors from waits
so that we can pass control to other threads.

File size: 14.5 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(require-library lolevel posix extras srfi-13 srfi-4)
52(foreign-declare "#include \"os-dep.h\"\n")
53
54(module sendfile
55  (force-implementation
56   *last-selected-implementation*
57   read-write-buffer-size
58   implementation-selector
59   impl:mmapped
60   impl:sendfile
61   impl:read-write-loop/fd
62   impl:read-write-loop/port
63   os-dep:sendfile-available?
64   os-dep:mmap-available?
65   sendfile)
66  (import scheme chicken posix srfi-4 (only lolevel pointer-offset))
67         
68;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
69  ;; Helpers
70;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
71
72  ;;we need to know the wordsize to calculate the
73  ;;biggest representable fixnum. This is used as the
74  ;;size to be passed to sendfile
75  (define-foreign-variable %word-size int "C_WORD_SIZE")
76
77  ;;is the sendfile(2) avilable?
78  (define-foreign-variable %have-native-sendfile int "HAVE_SENDFILE")
79  (define os-dep:sendfile-available? (= %have-native-sendfile 1))
80
81  ;;is mmap nativly available?
82  (define-foreign-variable %have-mmap int "HAVE_MMAP")
83  (define os-dep:mmap-available? (= %have-mmap 1))
84
85 
86  ;;system-specific defines that are used to fine-tune somethings if
87  ;;they are available
88  (define-foreign-variable %have-madvise int "HAVE_MADVISE")
89  (define-foreign-variable %madvise-sequential int "MADV_SEQUENTIAL")
90  (define-foreign-variable %madvise-will-need int "MADV_WILLNEED")
91
92 
93  (define-foreign-variable %bufsize int "BUFSIZ")
94
95 
96  ;;the buffer used in read write loops
97  ;;the client may adjust this to meet its need
98  (define read-write-buffer-size (make-parameter %bufsize))
99
100  ;;advise the kernel for a specific buffer
101  ;;this is used in  mmapped io if supported
102  (define (%madvise buff len behav)
103    (if (= %have-madvise 1)
104        ((foreign-lambda int "madvise" (pointer char) unsigned-integer int) buff len behav)))
105
106 
107  ;;the sendfile implementation
108  ;;note that we pass a flonum instead of an integer as we need
109  ;;to be able to represent abritrary sizes on non-64bit systems as well
110  ;;also (file-size) currently returns a float for big-files
111  (define %sendfile-implementation
112    (foreign-lambda double "sendfile_implementation" int int double unsigned-integer))
113
114
115
116  ;;some helpers that make things cleaner
117  (define (kilobytes bytes) (* bytes 1024))
118  (define (megabytes bytes)  (* (kilobytes bytes) 1014))
119
120  ;;the current chunk-size specifies how big the slices are that
121  ;;we read/write in the three scenarios. This is parameterized
122  ;;because different methods to send the file may work better with
123  ;;differently sized chunks
124  (define %current-chunk-size (make-parameter (kilobytes 512)))
125
126  ;;compute the next chunk to send out of offset and the length
127  ;;of the remaining buffer. This is really just a convenience-procedure
128  ;;that uses (the possibly parameterized) (chunk-zize)
129  (define (%next-chunk-size len offset)
130    (if (> (- len offset) (%current-chunk-size))
131        (%current-chunk-size)
132        (- len offset)))
133
134  (define *last-selected-implementation* #f)
135
136  (define write-timeout (make-parameter #f))
137
138  ;;copied from tcp
139  (define (%yield)
140    (##sys#call-with-current-continuation
141     (lambda (return)
142       (let ((ct ##sys#current-thread))
143         (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
144         (##sys#schedule) ) ) ) )
145
146;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
147  ;; Conditions
148;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
149  (define strerror (foreign-lambda c-string "strerror" int))
150
151  (define (make-exn-condition location message arguments)
152    (apply make-property-condition
153           'exn
154           (append
155            (if location (list 'location location) '())
156            (if message (list 'message message) '())
157            (if (and arguments (not (null? arguments))) (list 'arguments arguments) '()))) )
158
159  (define (make-sendfile-condition location message arguments)
160    (make-composite-condition
161     (make-exn-condition location message arguments)
162     (make-property-condition 'sendfile)) )
163
164  (define (errno-argument)
165    (let ((err (errno)))
166      (if (zero? err)
167          '()
168          (let ((str (strerror err)))
169            (if (or (not str) (zero? (string-length str)))
170                (list (number->string err))
171                (list str) ) ) ) ) )
172
173  (define (%error msg . args)
174    (abort (make-sendfile-condition #f msg (append (errno-argument) args))))
175
176
177
178;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
179;; The three implementations follow now.
180;; sendfile implements three distinct strategies to send the file over the wire.
181;; Which method is used depends on the system's capabilities and the size of the file
182;; 1) it uses sendfile(2)
183;; 2) it uses mmapped-io. This means chunks of the file are mmapped into the process-memory
184;;    and written to the socket
185;; 3) it uses read-writes repeatetly. This is the simplest (NOT the slowest in all cases) strategy.
186;;    It simply reads a chunk of the file and writes it out to the socket
187;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188
189;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
190;;MMAPPED-SEND
191;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
192  (define (impl:mmapped src dst len)
193    (set!  *last-selected-implementation* 'mmapped)
194   
195    (unless os-dep:mmap-available?
196      (%error  "mmap is not available on this system"))
197   
198    (define sys:write (foreign-lambda integer "write" integer c-pointer unsigned-integer))
199
200    (define (send-chunk ptr size write-timeout)
201      ;;don't bother adivices for data smaller than 64k
202      (when (> size (kilobytes 64)) (%madvise ptr size %madvise-will-need))
203      (let loop ((bytes-left size) (work-ptr (pointer-offset ptr 0)))
204        (if (zero? bytes-left)
205            #t
206            (let ((result (sys:write dst work-ptr bytes-left)))
207              (cond
208               ((and (negative? result) (= errno/again (##sys#update-errno)))
209                (when write-timeout
210                  (##sys#thread-block-for-timeout!
211                   ##sys#current-thread
212                   (fx+ (##sys#fudge 16) write-timeout)))
213                (##sys#thread-block-for-i/o! ##sys#current-thread dst #f)
214                (%yield)
215                (when (##sys#slot ##sys#current-thread 13)
216                  (%error "write operation timed out"))
217                (loop bytes-left work-ptr)) ;retry
218               ((negative? result) #f)
219               (else
220                (loop (- bytes-left result) (pointer-offset work-ptr result))))))))
221   
222    (parameterize ((%current-chunk-size (kilobytes 512)))
223      (let loop ((offset 0.0))
224        (cond
225         ((= offset len) len)
226         (else
227          (let* ((next-chunk (%next-chunk-size len offset))
228                 (mem-file (map-file-to-memory #f next-chunk prot/read map/shared src offset))
229                 (write-timeout (write-timeout)))
230            (unless (send-chunk (memory-mapped-file-pointer mem-file) next-chunk write-timeout)
231              (unmap-file-from-memory mem-file)
232              (##sys#update-errno)
233              (%error "write-failed"))
234            (unmap-file-from-memory mem-file)
235            (loop (+ offset next-chunk))))))))
236 
237;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
238;; SENDFILE(2)
239;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
240  (define (impl:sendfile src dst len )
241    (set!  *last-selected-implementation* 'sendfile)
242   
243    (unless os-dep:sendfile-available?
244      (%error "sendfile is not available on this system"))
245   
246    (parameterize ((%current-chunk-size (inexact->exact (- (expt 2 (- %word-size 3)) 1))))
247      (let loop ((offset 0.0))
248        (cond
249         ((= offset len)  len)
250         (else
251          (let* ((next-chunk (%next-chunk-size len offset))
252                 (new-offset (%sendfile-implementation src dst offset next-chunk)))
253            (cond
254             ;;TODO yield control to other threads if new-offset is -2
255             ((negative? new-offset)
256              (##sys#update-errno)
257              (%error "sendfile failed"))
258             (else
259              (loop new-offset)))))))))
260
261
262;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
263;;READ-WRITE-LOOP
264;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
265  (define (impl:read-write-loop/port src dst len)
266    (set!  *last-selected-implementation* 'read-write-loop)
267   
268    (let* ((buffsize (read-write-buffer-size))
269           (buffer (make-string buffsize)))
270      (let loop ((n len))
271        (if (not (positive? n))
272            len
273            (let* ((to-read (fxmin buffsize (inexact->exact n)))
274                   (read-bytes (cadr (file-read src to-read buffer))))
275              ;(display (substring buffer 0 (sub1 read-bytes)))
276              (display (substring buffer 0 read-bytes) dst)
277              (loop (- n read-bytes)))))))
278
279 
280  (define (impl:read-write-loop/fd src dst len)
281    (set!  *last-selected-implementation* 'read-write-loop)
282   
283    (let* ((buffsize (read-write-buffer-size))
284           (buffer (make-string buffsize))
285           (write-timeout (write-timeout))
286           (write/offset (foreign-lambda* int ((int dst) (c-string buff) (unsigned-integer offset) (unsigned-integer bytes))
287                                          "C_return(write(dst,buff + offset,bytes));"))
288           (write-bytes (lambda (size)
289                          (let loop ((left size) (offset 0))
290                            (let ((written-bytes (write/offset dst buffer offset left)))
291                              (cond
292                               ((zero? left) #t)
293                               ((and (negative? written-bytes) (= errno/again (##sys#update-errno)))
294                                (when write-timeout
295                                  (##sys#thread-block-for-timeout!
296                                   ##sys#current-thread
297                                   (fx+ (##sys#fudge 16) write-timeout)))
298                                (##sys#thread-block-for-i/o! ##sys#current-thread dst #f)
299                                (%yield)
300                                (when (##sys#slot ##sys#current-thread 13)
301                                  (%error "write operation timed out"))
302                                (loop left offset))
303                               ((negative? written-bytes)
304                                (##sys#update-errno)
305                                (%error "write failed"))
306                               (else (loop (fx- left written-bytes) (fx+ offset written-bytes)))))))))
307      (let loop ((n len))
308        (if (not (positive? n))
309            len
310            (let* ((to-read (fxmin buffsize (inexact->exact n)))
311                   (read-bytes (cadr (file-read src to-read buffer))))
312              (write-bytes read-bytes)
313              (loop (- n read-bytes)))))))
314
315
316
317
318;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
319;; The single interface procedure
320;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
321  (define (default-selector len)
322    (cond
323     ((< len (megabytes 1)) impl:read-write-loop/fd)
324     (os-dep:sendfile-available? impl:sendfile)
325     (os-dep:mmap-available? impl:mmapped)
326     (else impl:read-write-loop/fd)))
327 
328 
329  (define (port-has-fd? obj)
330    (unless (port? obj)
331      (%error "supplied argument is not a port"))
332    (handle-exceptions exn #f (port->fileno obj) #t))
333
334  (define (->fileno obj)
335    (cond
336     ((fixnum? obj) obj)
337     ((port? obj) (port->fileno obj))
338     (else (%error "supplied argument is neither port nor descriptor"))))
339 
340  ;;set to either 'sendfile 'mmapped 'read-write or 'nothing
341  (define force-implementation (make-parameter 'nothing))
342
343  (define implementation-selector (make-parameter default-selector))
344
345  ;;FIX THIS
346  (define (sendfile src dst)
347    (let ((size (file-size src)))
348      (if (and (port? dst) (not port-has-fd? dst))
349          (impl:read-write-loop/port src dst size)
350          (let ((src (->fileno src))
351                (dst (->fileno dst)))
352            (case (force-implementation)
353              ((sendfile)   (impl:sendfile src dst size))
354              ((mmapped)    (impl:mmapped src dst size))
355              ((read-write) (impl:read-write-loop/fd src dst size))
356              ((nothing)
357               (let ((impl ((implementation-selector) size)))
358                 (impl src dst size)))
359              (else
360               (%error "invalid implementation forced. Allowed values are (sendfile mmapped read-write nothing)")))))))
361;;module
362 
363)
Note: See TracBrowser for help on using the repository browser.