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%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)
Gambit-list mailing list Gambit-list@iro.umontreal.ca https://webmail.iro.umontreal.ca/mailman/listinfo/gambit-list