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 ,@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)))