[gambit-list] Strange Networking Bug on MinGW (LONG)
François Magnan
francois.magnan at licef.ca
Fri Apr 4 15:10:04 EDT 2008
Regarding this previous problem I submitted, I worked on isolating it
to simpler terms. I found another IO problem on Gambit 4.2.5 on
WindowsXP (MinGW). I don't know if they are related in any way.
The problem occurs when I do an open-process on a dummy bat script
that: outputs two lines and loop indefinitely. I read the the lines in
the process port and after that, all IO is blocked in Gambit. To show
this, I run a dummy tcp server and a loop of clients calls to this
server concurrently and this loop gets stuck when all IO is blocked.
Strangely, if I send a (read-line) in the process port; It unblocks
the IO even if there is actually nothing to read in the port.
Here is the code to reproduce it on Windows (MingW):
----- Simple BAT script ---------------------------
@ECHO OFF
ECHO A
ECHO B
:loop
IF 1==1 GOTO loop
--------------------------------------------------------
----- Gambit 4.2.5 Code ---------------------------
(define n 0)
;;;
;;;; main
;;;
(define (main)
(start-server)
(start-open-process)
(start-clients))
;;;
;;;; Minimal Server
;;;
(define (start-server)
(let ((rpc-command-queue (open-tcp-server
(list port-number: 8001))))
(thread-start!
(make-thread
(lambda ()
(let loop ()
(let ((incoming-connection (read rpc-command-queue)))
(serve-connection incoming-connection))
(loop)))))))
(define (serve-connection incoming-connection)
(thread-start!
(make-thread
(lambda ()
(let* ((line (read-line incoming-connection)))
(pp (list "read in server" line))
(force-output)
(set! n (+ 1 n))
(display (string-append "connection " (number->string n)
"\n") incoming-connection)
(close-port incoming-connection))))))
;;;
;;;; Client
;;;
(define (start-clients)
(let loop ()
(let ((p (open-tcp-client (list server-address: "127.0.0.1"
port-number: 8001))))
(display "anything\n" p)
(force-output p)
(pp (list "read from server" (read-line p)))
(force-output)
(close-port p))
(thread-sleep! 0.1)
(if (< n 50)
(loop))))
;;;
;;;; start-open-process
;;;
(define (start-open-process)
(thread-start!
(make-thread
(lambda ()
(let ((p (open-process (list
path: "processDos.bat"
pseudo-terminal: #t
stderr-redirection: #f
eol-encoding: 'cr-lf
))))
(pp (list (read-line p) "1"))
(pp (list (read-line p) "2"))
; Uncomment the following line to unblock IO
;(pp (list (read-line p) "3"))
)))))
;;;
;;;; start main
;;;
(main)
--------------------------------------------------------
This phenomenon is not present on MacOSX version.
Thank you,
Francois Magnan
On 8-Feb-08, at 4:51 PM, François Magnan wrote:
> 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\"")))
>
>
> (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)
>
>
> _______________________________________________
> Gambit-list mailing list
> Gambit-list at iro.umontreal.ca
> https://webmail.iro.umontreal.ca/mailman/listinfo/gambit-list
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mailman.iro.umontreal.ca/pipermail/gambit-list/attachments/20080404/5a90b862/attachment.htm>
More information about the Gambit-list
mailing list