[gambit-list] I/O issues (longish)

Christian christian at pflanze.mine.nu
Sun Jan 29 09:55:00 EST 2006


Hello

I'm trying to write a program which I can use as wrapper around gambit
in interactive sessions, especially in emacs, to provide more sensible
buffering for making output appear faster in emacs.

Here's how I start gambit under emacs currently:

    #!/bin/bash
    ulimit -S -v 300000
    gsc -:tE,d-,t8,f8 -i -e '(include "/home/chris/schemedevelopment/gambit/chj.scm")' -

and here's how I would like to run it once that wrapper is finished:

    #!/bin/bash
    ulimit -S -v 300000
    bufferi -:tE  gsc -:tE,d-,t8,f8 -i -e '(include "/home/chris/schemedevelopment/gambit/chj.scm")' -

The "bufferi" program forks off a child connected to the parent
through a pipe and exec'ing the given command-line. It then reads
input from the pipe into a buffer, which it only writes to stdout if
either the buffer is full or a certain time has passed. (In the code
pasted at the bottom of this mail, buflen is set to 10 bytes, and
timeout to .03 seconds.)

There are a few issues I've run into:

1. when using open-process, the subprocess doesn's seem to be
   connected to the original standard input anymore. why?
   (try it out by commenting out section "a)" in the
   bufferi-standalone.scm code and uncommenting the section "b)".)

2. when I use a self-written pipe/fork/dup2/exec infrastructure
   instead of open-process, I'm getting an "Invalid argument"
   exception unless I run ##char-ready? onto the current-input-port
   before dup'ing the pipe into it's position.
   Yes I'm changing fd 0 underneath the gambit runtime.
   How could I "cleanly" create a port from an existing unix fd
   instead?

2. when I use that self-written pipe/fork/dup2/exec infrastructure,
   the child actually *can* read from the original standard input, as
   it should, but it is getting an "Resource temporarily unavailable"
   error. I think it is because of O_NONBLOCK. I'm trying to switch
   that flag off, but with only marginal success (for more details see
   below).

3. compiler warnings (those don't seem to disturb operation, but I
   thought I'd ask about them anyway)


First to issue # 3 since it's the easiest:

$ gscompile bufferi-standalone.scm   #gscompile is a script by myself
gsc -warnings bufferi-standalone
gcc -O3 -fomit-frame-pointer -mpreferred-stack-boundary=2 bufferi-standalone.c bufferi-standalone_.c -I/usr/local/Gambit-C/include -L/usr/local/Gambit-C/lib -lgambc -lm -lutil -ldl -o bufferi-standalone
bufferi-standalone.c: In function `___H__20_bufferi_2d_standalone_23_2':
bufferi-standalone.c:1734: warning: passing arg 2 of `___SCMOBJ_to_NONNULLLATIN1STRINGLIST' from incompatible pointer type
bufferi-standalone.c:1737: warning: passing arg 2 of `forkexec_with_pipe' from incompatible pointer type

line 1734 is:
___BEGIN_CFUN_maybe_latin1_string_list_to_charpp(___ARG3,___arg3,3)
line 1737 is:
___CFUN_CALL(___result,forkexec_with_pipe(___arg1,___arg2,___arg3))


Issue # 2:

$ ./bufferi-standalone -:tE,-u,tu,fu /bin/cat 
abcdefghijklmnopq<cr>
res=10
abcdefghijRSTUVWXYZ<cr>
res=10
klmnopq
RSres=10
TUVWXYZ
/bres=10
in/cat: -:res=10
 Resource res=10
temporarilres=10
y unavailares=4
ble

I think cat terminates because it is reading from an fd which is in
O_NONBLOCK mode. So I have written fd-nonblocking-set! and fd-nonb
functions. They work like this:

> (fd-nonblocking? 0)
#t
> (fd-nonblocking? 1)
#t
> (fd-nonblocking? 3)
#t
> (fd-nonblocking-set! 0 #f)
> (fd-nonblocking? 0)
#f
> (fd-nonblocking? 1)
#f
> (fd-nonblocking? 3)
#t
> (fd-nonblocking? 1)
#f

you can see that setting the O_NONBLOCK flag on one fd may also change
another one, probably because fd's 0/1/2 are actually all copies of
the same (as lsof shows):

gsc     28295 chris    0u   CHR 136,26              28 /dev/pts/26
gsc     28295 chris    1u   CHR 136,26              28 /dev/pts/26
gsc     28295 chris    2u   CHR 136,26              28 /dev/pts/26
gsc     28295 chris    3u   CHR    5,0          185218 /dev/tty

Unix also has sort of a design bug, as D.J.Bernstein has pointed out
(http://cr.yp.to/unix/nonblock.html). So the best solution which is
possible with what unix offers is probably to make sure that an fd is
not being used by different programs at the same time. So gambit would
need a function which releases an fd from it's control (and restores
the previous O_NONBLOCK setting), but doesn't close it.(*)

Back to "bufferi-standalone": here are relevant parts of strace output
of the gambit process: one can see that some party is adding
O_NONBLOCK again (after the child is already running), which makes the
child (cat) fail soon.

    fcntl64(0, F_GETFL)                     = 0x8002 (flags O_RDWR|O_LARGEFILE)
    fcntl64(0, F_SETFL, O_RDWR|O_NONBLOCK|O_LARGEFILE) = 0

#that's probably from gambit itself? but no, gambit doesn't have
# O_LARGEFILE in it's sources.

    fcntl64(0, F_GETFL)                     = 0x8802 (flags O_RDWR|O_NONBLOCK|O_LARGEFILE)
    fcntl64(0, F_SETFL, O_RDWR|O_LARGEFILE) = 0
# this has probably been from my call.

    clone(child_stack=0, flags=CLONE_CHILD_CLEARTID|CLONE_CHILD_SETTID|SIGCHLD, child_tidptr=0xb7a322e8) = 21787

    fcntl64(0, F_GETFL)                     = 0 (flags O_RDONLY)
    fcntl64(0, F_SETFL, O_RDONLY)           = 0
# this has probably been from my call, too

    fcntl64(1, F_GETFL)                     = 0x8002 (flags O_RDWR|O_LARGEFILE)
    fcntl64(1, F_SETFL, O_RDWR|O_NONBLOCK|O_LARGEFILE) = 0
# this must have been from the gambit runtime.
# and, since fd 1 is still /dev/pts/26, it will also set fd 0 of cat.

    fcntl64(0, F_GETFL)                     = 0 (flags O_RDONLY)
    fcntl64(0, F_SETFL, O_RDONLY)           = 0

    --- SIGCHLD (Child exited) @ 0 (0) ---
# so cat has exited now

# (question: why is O_LARGEFILE not there anymore now?)

    fcntl64(0, F_GETFL)                     = 0 (flags O_RDONLY)
    fcntl64(0, F_SETFL, O_RDONLY)           = 0

    fcntl64(0, F_GETFL)                     = 0 (flags O_RDONLY)
    fcntl64(0, F_SETFL, O_RDONLY)           = 0

    ..

    fcntl64(1, F_SETFL, O_RDWR|O_LARGEFILE) = 0


(*) Well, I realize, that it's more difficult than only releasing an
fd out of gambit control. As seen in the above strace, it's enough for
gambit carrying the same open file as another fd (namely fd 1) and the
problem persists. The ugly thing is that I cannot remove fd 1 from
gambit's control as well, since I want to write output to it.

So I have another (more important, or additional) suggestion: could
gambit be instructed to not use O_NONBLOCK at all? Maybe it could even
transparently defer switching on O_NONBLOCK until it really has
multiple active threads at once.

(Maybe additionally D.J. Bernstein's approach could be cloned? Quoting
him:
    "Here's what I'm doing now:
       1. Call read() or write() without further ado if the descriptor
	  was originally provided in O_NONBLOCK mode or refers to a
	  regular file. (Of course, it's possible that somebody
	  subsequently turned O_NONBLOCK off; every program relying on
	  O_NONBLOCK is taking this risk.)
       2. Use poll(), if it's available and functioning, to check
          whether the descriptor is ready.
       3. Set an interval timer.
       4. Call read() or write().
       5. Turn the interval timer off."

but just being able to instruct gambit to not use O_NONBLOCK globally
would be enough for my case.)


Thanks
Christian.


Here are the two files for testing the above. "cj-fork-util.scm"
contains the lowlevel C stuff, "bufferi-standalone.scm" the
application code.

cj-fork-util.scm: --------------------------------------------------

; cj Sat, 28 Jan 2006 17:48:51 +0100

(declare
 (block)
 (standard-bindings)
 (extended-bindings)
)

(define-macro (thunk first . rest)
  `(lambda() ,first , at rest))


(c-declare #<<END
#include <stdio.h>
#include <sys/types.h>
#include <unistd.h>
#include <string.h>
#include <errno.h>
#include <stdlib.h> /* exit */
#include <fcntl.h>

extern char **environ; // man 5/7 environ 

static int our_errno=0;
#define OUR_BUFSIZ 8192
static char* our_childerrmsg;
#define ERR(n) { our_errno=errno; return n; }

 // (btw: do we need to do some close-on-exec control on gambit fd's?)
 
static pid_t
forkexec_with_pipe (char* filename, char*const argv[], char*const envp[]) {
    int data[2];
    int errmsg[2];
    if (!our_childerrmsg) {
	/* allocate once */
	our_childerrmsg= malloc(OUR_BUFSIZ);
	if (!our_childerrmsg)
	    ERR(-10);
    }
    our_childerrmsg[0]=0;
    if (pipe(data))
	ERR(-1);
    if (pipe(errmsg))
	ERR(-1);
    //    if (fcntl(data[0],F_SETFL,O_NONBLOCK|O_ASYNC)<0)
	/* "... Linux this command can only change the O_APPEND, O_NONBLOCK, O_ASYNC, and  O_DIRECT flags."
	   but: which ones is gambit using? do we switch off the other(s)?
	*/
	//ERR(-13);
    // (the above isn't essential for me)
    {
	pid_t pid= fork();
	if (pid<0) {
	    close(data[0]);
	    close(data[1]);
	    close(errmsg[0]);
	    close(errmsg[1]);
	    ERR(-2);
	}
	if (pid) {
	    if (close(data[1]))
		ERR(-3);
	    if (close(errmsg[1]))
		ERR(-3);
	    if (dup2(data[0],0))
		ERR(-4);
	    if (close(data[0]))
		ERR(-5);
	    {
		ssize_t n_read= read(errmsg[0], our_childerrmsg, OUR_BUFSIZ);
		our_childerrmsg[OUR_BUFSIZ-1]=0;
		our_childerrmsg[OUR_BUFSIZ-2]='.';
		our_childerrmsg[OUR_BUFSIZ-3]='.';
		our_childerrmsg[OUR_BUFSIZ-4]='.';
		if (close(errmsg[0]))
		    ERR(-12);
		if (n_read<0)
		    ERR(-11);
		if (n_read>0)
		    ERR(-100);
	    }
	    return pid;
	} else {
	    #define CHILDERR(exitcode, msg, args...) \
                   { snprintf(our_childerrmsg, OUR_BUFSIZ, msg, ##args); \
                     write(errmsg[1], our_childerrmsg, OUR_BUFSIZ); /* just write whole buf */ \
                     exit(exitcode); } /* well since we are not returning but exiting, could have written function instead of macro */
	    if (close(data[0]))
		CHILDERR(33,"close(data[0]): %s",strerror(errno));
	    if (dup2(data[1],1)<0)
		CHILDERR(34,"dup2 fd 1: %s",strerror(errno));
	    if (dup2(data[1],2)<0)
		CHILDERR(35,"dup2 fd 2: %s",strerror(errno));
	    if (close(data[1]))
		CHILDERR(36,"close: %s",strerror(errno));
	    if (fcntl(errmsg[1], F_SETFD, FD_CLOEXEC))
		CHILDERR(37,"fcntl: %s",strerror(errno));
		//close(errmsg[1]);
	    execve(filename,argv,envp ? envp : environ);
	    CHILDERR(127,"could not exec '%s': %s", filename, strerror(errno));
	}
    }
}

#define ___BEGIN_CFUN_maybe_latin1_string_list_to_charpp(s, c, i) \
 { \
    int do_not_create_list= (___FAL == s); \
    if (do_not_create_list) { c=NULL; } \
    if (do_not_create_list || ((___err= ___SCMOBJ_to_NONNULLLATIN1STRINGLIST(s,&c,i))== ___FIX(___NO_ERR))) { \

#define ___END_CFUN_maybe_latin1_string_list_to_charpp(s, c, i) \
        if (c && ! do_not_create_list) ___EXT(___release_string_list)(c); \
    } \
 }

END
 )

(c-define-type maybe-latin1-string-list "char**" ; (pointer (pointer "char"))
	       "NOTIMPLEMENTED" "maybe_latin1_string_list_to_charpp"
	       #t; from scheme to C  todo find out finally
	       )

(define our-os-errstr (c-lambda () latin1-string "___result= strerror(our_errno);"))
(define our-childerrmsg (c-lambda () latin1-string "___result= our_childerrmsg;"))

(define (fork-exec/pipe filename argument-list #!optional maybe-env-list)
  (let ((res ((c-lambda (nonnull-latin1-string
			 nonnull-latin1-string-list
			 maybe-latin1-string-list)
			int
			"forkexec_with_pipe")
	      filename
	      argument-list
	      maybe-env-list)))
    (cond ((>= res 0)
	   res)
	  ((assoc res '((-1 "pipe:" #t)
			(-2 "fork:" #t)
			(-3 "close(filedes[1]):" #t)
			(-4 "dup2:" #t)
			(-5 "close(filedes[0]):" #t)
			(-10 "malloc:" #t)
			(-11 "reading from error message pipe:" #t)
			(-12 "close(errmsg[0]):" #t)
			(-13 "fcntl(data[0]):" #t)
			))
	   => (lambda (p)
		(error (string-append "fork-exec/pipe: "
				      (cadr p)
				      (if (caddr p)
					  (our-os-errstr)
					  "")))))
	  ((= res -100)
	   (error (string-append "fork-exec/pipe: child said: "
				 (our-childerrmsg))))
	  (else
	   (error "fork-exec/pipe: unknown error code" res)))))


; ---  other more direct posix stuff: ----
(c-declare "#include <signal.h>")

(define (->string obj)
  ;; oo sys?.
  (cond ((string? obj)
	 obj)
	((number? obj)
	 (number->string obj))
	((boolean? obj)
	 (if obj "#t" "#f"))
	(else
	 (error "->string: unknown type of:" obj))))

(define (posix-kill pid sig
		    #!optional
		    error-cont 
		    (success-cont (thunk (if error-cont #t #!void))))
  (let ((error-cont (or error-cont
			(thunk
			 (error (string-append "posix-kill(" (->string pid) ", " (->string sig) "): "
					       (our-os-errstr)))))))
    ((if ((c-lambda (int ;; actually pid_t
		     int)
		    scheme-object
		    "if (kill(___arg1,___arg2)<0) {
                            our_errno=errno; ___result= ___FAL;
                         } else {
                             ___result= ___TRU;
                         }")
	  pid sig)
	 success-cont
	 error-cont))))


(define (fd-nonblocking? fd)
  (let ((res ((c-lambda (int)
			scheme-object
			"{int res= fcntl(___arg1,F_GETFL);
                          if (res<0) { our_errno=errno; ___result= ___VOID; }
                          else ___result= (res & O_NONBLOCK) ? ___TRU : ___FAL;}")
	      fd)))
    (if (boolean? res)
	res
	(error (string-append "(fd-nonblocking? "
			      (->string fd)
			      "): "
			      (our-os-errstr))))))
	
(define (fd-nonblocking-set! fd yes?)
  (let ((res ((c-lambda (int
			 bool)
			scheme-object
			"{ int res= fcntl(___arg1,F_GETFL);
               if (res<0) { our_errno=errno; ___result= ___FIX(-1); }
               else { int res2= fcntl(___arg1,F_SETFL, (___arg2 ? (res|O_NONBLOCK) : (res & (~ O_NONBLOCK))));
                      if (res2<0) { our_errno=errno; ___result= ___FIX(-2); }
                      else { ___result= ___FIX(0); }
                    }
             }")
	      fd yes?))
	(err (lambda (msg)
	       (error (string-append "(fd-nonblocking-set! "
				     (->string fd)
				     " "
				     (->string yes?)
				     "): "
				     msg
				     (our-os-errstr))))))
    (case res
      ((0) ;; success
       #!void)
      ((-1)
       (err "fcntl get: "))
      ((-2)
       (err "fcntl set: "))
      (else
       (err "at UNKNOWN place: ")))))
    

bufferi-standalone.scm: ----------------------------------------------

(include "cj-fork-util.scm")

(define buflen 10)
(define timeout .03)

(define (Do in out)
  (let ((buf (make-u8vector buflen))
	(is-timeout #f))
    (letrec ((timeout-set! (thunk
			    (input-port-timeout-set! in timeout timeout-set!)
			    (set! is-timeout #t)
			    #f)))
      (dynamic-wind
	  timeout-set!
	  (thunk
	   (let lp ()
	     (set! is-timeout #f)
	     (fd-nonblocking-set! 0 #f);;;;
	     (let ((res (read-subu8vector buf 0 buflen in)))
	       (if (= res 0)
		   (if is-timeout
		       (lp)
		       #!eof)
		   (begin
		     (display (list "res=" res "\n"))
		     (write-subu8vector buf 0 res out)
		     (lp))))))
	  (thunk
	   (input-port-timeout-set! in +inf.))))))


(define in (current-input-port))
(define out (current-output-port))

(define (Run cmd)
  (##char-ready? in) ;; helps against "*** ERROR IN Do -- Invalid argument \n (read-subu8vector '#u8(0 0 0 0 0 0 0 0 0 0) 0 10 '#<input-port #2 (stdin)>)"
  (fd-nonblocking-set! 0 #f) ;; helps for a short time to enable cat to read from stdin, but only in the fork-exec/pipe case, not in the open-process case

  ;; comment out one of the following two code versions a) or b):

  ;; a) using my lowlevel stuff from cj-fork-util.scm:
  (let* ((cmd-port (current-input-port))
	 (childpid (fork-exec/pipe (car cmd) cmd)))

  ;; b) using open-process and process-pid:
;   (let* ((cmd-port (open-process (list path: (car cmd)
; 				       arguments: (cdr cmd)
; 				       stderr-redirection: #t
; 				       )))
; 	 (childpid (process-pid cmd-port)))

    ;; common code:
    (parameterize ((current-user-interrupt-handler (thunk
						   (display "got signal, proxying\n")
						   (posix-kill childpid 2)
						   #f)))
		  (Do cmd-port (current-output-port)))))


(Run (cdr (command-line)))





More information about the Gambit-list mailing list