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

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

added code to give control to other threads, so sendfile behaves coorporative.
At the moment only read-write-loop/fd and mmapped has this. For sendfile-impl
we need to rewrite the c-code first.

File size: 12.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(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
114(define (sendfile:madvise buff len behav)
115  (if (= %sendfile:have-madvise 1)
116      ((foreign-lambda int "madvise" (pointer char) unsigned-integer int) buff len behav)))
117     
118
119;;compute the next chunk to send
120;;if total-length - offset is bigger than the biggest
121;;integer on the system we send the biggest integer
122;;otherwise we send the difference
123(define (sendfile:next-chunk-size len offset)
124    (if (> (- len offset) *sendfile:chunk-size*)
125        *sendfile:chunk-size*
126        (- len offset)))
127
128
129(define (make-exn-condition location message arguments)
130  (apply make-property-condition
131    'exn
132    (append
133     (if location (list 'location location) '())
134     (if message (list 'message message) '())
135     (if (and arguments (not (null? arguments))) (list 'arguments arguments) '()))) )
136
137(define (make-sendfile-condition location message arguments)
138  (make-composite-condition
139   (make-exn-condition location message arguments)
140   (make-property-condition 'sendfile)) )
141
142(define (errno-argument)
143  (let ((err (errno)))
144    (if (zero? err)
145        '()
146        (let ((str (strerror err)))
147          (if (or (not str) (zero? (string-length str)))
148              (list (number->string err))
149              (list str) ) ) ) ) )
150
151(define (sendfile:error msg . args)
152  (abort (make-sendfile-condition #f msg (append (errno-argument) args))))
153
154
155(define *sendfile:last-selected-implementation* #f)
156
157
158;;copied from tcp
159(define (sendfile:yield)
160  (##sys#call-with-current-continuation
161   (lambda (return)
162     (let ((ct ##sys#current-thread))
163       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
164       (##sys#schedule) ) ) ) )
165
166
167(define sendfile:write-timeout (make-parameter #f))
168
169;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
170;; Implementations
171;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
172
173;;posix mmapped send
174;;as we're working with non-blocking IO
175;;EAGAIN is equal to EWOULDBLOCK
176(define (sendfile:mmapped src dst len)
177  (set!  *sendfile:last-selected-implementation* 'mmapped)
178 
179  (unless sendfile:os-dep:mmap-available?
180    (sendfile:error "mmap is not available on this system"))
181
182  (define sys-write (foreign-lambda integer "write" integer c-pointer unsigned-integer))
183
184  (define (send-chunk size ptr write-timeout)
185    (sendfile:madvise ptr size %sendfile:madvise-sequential)
186   
187    (let loop ((left size) (work-ptr (pointer-offset ptr 0)))
188      (cond
189       ((= left 0) #t)
190       (else
191        (let ((result (sys-write dst work-ptr left)))
192          (cond
193           ((and (negative? result) (= errno/again (##sys#update-errno)))
194            (when write-timeout
195              (##sys#thread-block-for-timeout!
196               ##sys#current-thread
197               (fx+ (##sys#fudge 16) write-timeout)))
198            (##sys#thread-block-for-i/o! ##sys#current-thread dst #f)
199            (sendfile:yield)
200            (when (##sys#slot ##sys#current-thread 13)
201              (sendfile:error "write operation timed out"))
202            (loop left work-ptr))
203           ((negative? result) #f)
204           (else
205            (loop (- left result) (pointer-offset work-ptr result)))))))))
206
207  (let loop ((offset 0.0))
208    (cond
209     ((= offset len) len)
210     (else
211      (let* ((next-chunk (sendfile:next-chunk-size len offset))
212             (mem-file (map-file-to-memory #f next-chunk prot/read (bitwise-ior map/shared map/file) src offset))
213             (write-timeout (sendfile:write-timeout)))
214        (unless (send-chunk next-chunk (memory-mapped-file-pointer mem-file) write-timeout)
215          (unmap-file-from-memory mem-file)
216          (##sys#update-errno)
217          (sendfile:error "write failed"))
218        (unmap-file-from-memory mem-file)
219        (loop (+ offset next-chunk)))))))
220             
221                       
222;;the interface to the sendfile-implementation
223;;as we're working with non-blocking IO
224;;EAGAIN is equal to EWOULDBLOCK
225;;MAKE THE WRITE LOOP AN INNER LOOP
226;;SO THAT ONLY THE ACTUAL SYSCALL IS REDONE AND NOT THE CALCULATION
227(define (sendfile:sendfile src dst len )
228  (set!  *sendfile:last-selected-implementation* 'sendfile)
229 
230  (unless sendfile:os-dep:sendfile-available?
231    (sendfile:error "sendfile is not available on this system"))
232 
233  (let loop ((offset 0.0))
234    (cond
235     ((= offset len)  len)
236     (else
237      (let* ((next-chunk (sendfile:next-chunk-size len offset))
238             (new-offset (%sendfile:sendfile-implementation src dst offset next-chunk)))
239        (cond
240         ((negative? new-offset)
241          (##sys#update-errno)
242          (sendfile:error "sendfile failed"))
243         (else
244          (loop new-offset))))))))
245       
246
247     
248;;as we're working with non-blocking IO
249;;EAGAIN is equal to EWOULDBLOCK
250;;TODO: get rid of the copy due to (substring)/ (substring/shared)
251
252(define (sendfile:read-write-loop/port src dst len)
253   (set!  *sendfile:last-selected-implementation* 'read-write-loop)
254   
255    (let* ((buffsize (sendfile:read-write-buffer-size))
256           (buffer (make-string buffsize)))
257      (let loop ((n len))
258        (if (not (positive? n))
259            len
260            (let* ((to-read (fxmin buffsize (inexact->exact n)))
261                   (read-bytes (cadr (file-read src to-read buffer))))
262              (display (substring buffer 0 read-bytes) dst)
263              (loop (- n read-bytes)))))))
264
265 
266(define (sendfile:read-write-loop/fd src dst len )
267  (set!  *sendfile:last-selected-implementation* 'read-write-loop)
268 
269  (let* ((buff-size (sendfile:read-write-buffer-size))
270         (buffer (make-string buff-size))
271         (write-timeout (sendfile:write-timeout))
272         (write/offset (foreign-lambda* int ((int dst) (c-string buff) (unsigned-integer offset) (unsigned-integer bytes))
273                                        "C_return(write(dst,buff + offset,bytes));")))
274   
275     (define (write-bytes size)
276       (let loop ((left size) (offset 0))
277        (let ((written-bytes (write/offset dst buffer offset left)))
278          (cond
279           ((= 0 left) #t)
280           ((and (negative? written-bytes) (= errno/again (##sys#update-errno)))
281            (when write-timeout
282              (##sys#thread-block-for-timeout!
283               ##sys#current-thread
284               (fx+ (##sys#fudge 16) write-timeout)))
285            (##sys#thread-block-for-i/o! ##sys#current-thread dst #f)
286            (sendfile:yield)
287            (when (##sys#slot ##sys#current-thread 13)
288              (sendfile:error "write operation timed out"))
289            (loop left offset)) ;;try again
290           ((negative? written-bytes)
291            (##sys#update-errno)
292            (sendfile:error "write failed"))
293           (else
294            (loop (- left written-bytes) (+ offset written-bytes)))))))
295   
296    (let loop ((n len))
297      (cond
298       ((not (positive? n)) len)
299       (else
300        (let* ((shall-read (if (> n buff-size) buff-size (inexact->exact n)))
301               (read-bytes (cadr (file-read src shall-read buffer))))
302          (write-bytes read-bytes)
303          (loop (- n read-bytes))))))))
304
305;;=============================== HIGHER LEVEL INTERFACE =======================================================
306
307(define (sendfile:default-selector len)
308  (cond
309   ((< len 1024) sendfile:read-write-loop/fd)
310   (sendfile:os-dep:sendfile-available? sendfile:sendfile)
311   (sendfile:os-dep:mmap-available? sendfile:mmapped)
312   (else sendfile:read-write-loop/fd)))
313
314
315(define (sendfile:port-has-fd? obj)
316  (unless (port? obj)
317    (sendfile:error "supplied argument is not a port"))
318  (handle-exceptions exn #f (port->fileno obj) #t))
319
320(define (->fileno obj)
321    (cond
322     ((fixnum? obj) obj)
323     ((port? obj) (port->fileno obj))
324     (else (sendfile:error "supplied argument is neither port nor descriptor"))))
325
326;;set to either 'sendfile 'mmapped 'read-write or 'nothing
327(define sendfile:force-implementation (make-parameter 'nothing))
328
329(define sendfile:implementation-selector (make-parameter sendfile:default-selector))
330
331(define (sendfile src dst)
332  (let ((size (file-size src)))
333    (if (and (port? dst) (not (sendfile:port-has-fd? dst)))
334        (impl:read-write-loop/port src dst size)
335        (let ((src (->fileno src))
336              (dst (->fileno dst)))
337          (case (sendfile:force-implementation)
338            ((sendfile) (sendfile:sendfile src dst size))
339            ((mmapped) (sendfile:mmapped src dst size))
340            ((read-write) (sendfile:read-write-loop/fd src dst size))
341            ((nothing)
342             (let ((impl ((sendfile:implementation-selector) size)))
343               (impl src dst size)))
344            (else
345             (sendfile:error "invalid implementation forced. Allowed values are (sendfile mmapped read-write nothing)")))))))
346
347
348 
349
350                         
351                         
352
353
354     
355
356
357
358                             
359                         
360 
361
362
363                           
364
365
366
367
368 
369   
Note: See TracBrowser for help on using the repository browser.