[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