Hi,
I worked hard to isolate one of my bugs and I found a rather disturbing minimal example that reproduces the bug. It can be observed in all the latests versions of Gambit (including 4.2.1).
Basically, I start a minimal multithread web server and in another thread I start a loop that calls a serie of open-tcp-client to different ips in the local network. The default web browser is launched to get the page served by the web server.
On MacOSX Leopard everything is fine. On WindowsXP (MingW compiled version of Gambit) the page takes an unnaceptable loooong time to load. The website index.html must require multiple HTTP GET to render (a page with multiple pictures for example).
What is the most disturbing is that if I replace the calls to "read-u8- line" by simple "read-line", the bug disapears. The bug is therefore somehow related to "read-u8".
Here is the sample code. You have to define "Server-ROOT" at the top so it points to a website on your local hard-drive. I didn't try on Linux but to try it the code will have to be adapted a little bit (how to launch the default browser on Linux?).
What could lead to this huge difference between a sequence of read-u8 and read-line on WinXP???
Thank you, Francois Magnan
;;; Gambit Networking Test Example ;;; ;;; Minimal web server that gets incredibly slow on WinXP (MinGW) if it is run in parallel with another thread that does a network scan. ;;; ;;; If the "read-u8-line" calls are replaced by "read-line" the bug disapears. ;;; ;;; On MacOSX Leopard the bug is not present. ;;; ;;; Was tested with versions: Gambit-C 4.0.1, 4.1.2, 4.2.1 ;;;
;;; ;;;; Server-ROOT ;;;
;;; ******************* ;;; Put here the path to a static website with many files to load to render index.html ;;; *******************
;(define Server-ROOT "/Users/magnan/TELOS/interface/TELOS-Desktop") (define Server-ROOT "C:/TELOS/interface/TELOS-Desktop")
;;; ;;;; main ;;;
(define (main) (start-server) (start-broadcast) (start-client) )
;;; ;;;; Minimal Web Server ;;;
(define (start-server) (let ((rpc-command-queue (open-tcp-server (list port-number: 8000)))) (thread-start! (make-thread (lambda () (let loop () (let ((incoming-connection (read rpc-command-queue))) (force-output) (serve-connection incoming-connection)) (loop)))))))
(define (serve-connection incoming-connection) (thread-start! (make-thread (lambda () (let* ((line (read-u8-line incoming-connection)) (splitted (split-string line #\space)) (path (cadr splitted))) (read-all-headers incoming-connection) (force-output) (with-exception-catcher (lambda (e) (##display-exception e (current-output-port))) (lambda () (serve-file path incoming-connection))))))))
(define (read-all-headers incoming-connection) (let ((line (read-u8-line incoming-connection))) (pp (list "read header line" line)) (force-output) (if (not (equal? line "")) (read-all-headers incoming-connection))))
(define (split-string str sep-char) (call-with-input-string str (lambda (p) (read-fields p sep-char #f))))
(define (read-fields port sep inc-sep?) (read-all port (lambda (p) (read-line p sep inc-sep?))))
(define (serve-file path incoming-connection) (let* ((complete-path (string-append Server-ROOT path)) (fileInfo (file-info complete-path)) (size (file-info-size fileInfo)) (mimetype (compute-mimetype complete-path)) (header (compute-get-result-header size mimetype))) (display header incoming-connection) (output-file-data complete-path incoming-connection) (close-port incoming-connection)))
(define (compute-get-result-header size mimetype) (string-append "HTTP/1.0 200 OK\r\n" "Content-type: " mimetype "\r\n" "Content-length: " (number->string size) "\r\n" "\r\n"))
(define (output-file-data filePath connection) (with-input-from-file filePath (lambda () (letrec ((output-file-data-rec (lambda () (let ((rc (read-char))) (if (not (equal? rc #!eof)) (begin (write-char rc connection) (output-file-data-rec))))))) (output-file-data-rec)))))
(define (compute-mimetype filePath) (let* ((ext (path-extension filePath)) (rext (and (string? ext) (substring ext 1 (string-length ext))))) (case (string->symbol rext) ((jpg jpeg JPG JPEG) "image/jpeg") ((gif GIF) "image/gif") ((png PNG) "image/png") ((html HTML htm HTM) "text/html") ((js JS) "text/javascript") ((css CSS) "text/css") (else "application/octet-stream" ))))
;;; ;;;; start-broadcast ;;;
(define (start-broadcast) (thread-start! (make-thread (lambda () (let* ((hostname (host-name)) (hi (host-info hostname)) (host-ips (host-info-addresses hi)) (host-ip (car host-ips))) (letrec ((network-broadcast (lambda (i) (if (= i 255) #t (begin (u8vector-set! host-ip 3 i) (call-addr host-ip) (thread-sleep! 0.2) (network-broadcast (+ i 1))))))) (network-broadcast 1)))))))
(define (call-addr target-addr) (pp (list "trying to reach" target-addr)) (with-exception-catcher (lambda (e) #f) (lambda () (let ((port (open-tcp-client (list server-address: target-addr port-number: 5000)))) (with-exception-catcher (lambda (e) #f) (lambda () (input-port-timeout-set! port 0.1) (output-port-timeout-set! port 0.1) (write (list 1 2 3) port))) (close-port port)))))
;;; ;;;; Client ;;;
(define (start-client) (if (equal? (get-host-os) "WinXP") (shell-command "start http://localhost:8000/index.html") (shell-command "open "http://localhost:8000/index.html%5C"")))
(define (get-host-os) (with-exception-handler (lambda (e) "WinXP") (lambda () (let* ((p (open-process '(path: "/usr/bin/uname" arguments: ("-s")))) (r (read-line p))) (close-port p) r))))
;;; ;;;; read-u8-line ;;;
(define (read-u8-line port) (letrec ((read-loop (lambda (acc) (let ((b (read-u8 port))) (if (or (equal? b 13) (equal? b 10) (equal? b #!eof)) (begin (read-u8 port) acc) (read-loop (string-append acc (list-
string (list (integer->char b))))))))))
(read-loop "")))
;;; ;;;; start main ;;;
(main)