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

Last change on this file since 11982 was 11982, checked in by sjamaan, 13 years ago

Implement fix for obvious small bug in syntax. Is this the fix meant in the comment?

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 num) (* num 1024))
118  (define (megabytes num)  (* (kilobytes num) 1024))
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.