Re: [Chicken-users] Re: An alternative thread system?

[F. Wittenberger]

Am Montag, den 11.08.2008, 10:25 +0400 schrieb Aleksej Saushev:
> Pipes are not that simple actually, to pass some complex structure
> through pipe, you need to pack it to some structure on one end, 
> parse and unpack on the other end (note all those XML/YAML encodings),
> while with _some_ shared memory you could just pass the reference.

Below I'll include such a pipe abstraction for use between chicken
threads.  It provides "normal" ports, thus your comment about
serialising/parsing applies here.

But it would be very easy to remove so much from the code that the
"read!" procedure would simply return the next element from the queue,
not the next character from the first string in the queue.  Voila:
you've got a pipe wich passes complex structures without serialising.
(Be warned: either the receiver must not mutate these structures or the
sender must no longer access it.)

/Jörg

(define string-ref++
  (foreign-lambda*
   char
   ((scheme-pointer buf) ((c-pointer integer) i))
   "char *p=(char *)buf; return(p[(*i)++]);"))

(define make-internal-pipe
  (let ([make-input-port make-input-port]
        [make-output-port make-output-port]
        [make-mutex make-mutex]
        [make-queue make-queue]
        [make-condition-variable make-condition-variable]
        [string-length string-length]
        [string-ref string-ref]
        (nothing (lambda () #t)))
    (lambda args
      (define name (or (and (pair? args) (car args))
                       'internal-pipe))
      (let-location
       ((off integer 0))
       (let ((mutex (make-mutex name))
             (condition (make-condition-variable name))
             (queue (make-queue))
             (buf #f))
         (define (eof?) (eq? #!eof buf))
         (define (buf-empty?) (or (not buf) (fx>= off (string-length buf))))
         (define (read!)
           (let loop ()
             (if (eof?) buf
                 (if (buf-empty?)
                     (begin
                       (mutex-lock! mutex)
                       (if (buf-empty?)
                           (if (queue-empty? queue)
                               (begin
                                 (mutex-unlock! mutex condition)
                                 (loop))
                               (begin
                                 (set! buf #f)
                                 (set! buf (queue-remove! queue))
                                 (set! off 1)
                                 (if (eof-object? buf) buf
                                     (let ((c (string-ref buf 0)))
                                       (mutex-unlock! mutex)
                                       c))))
                           (let ((c (string-ref buf off)))
                             (set! off (add1 off))
                             (mutex-unlock! mutex)
                             c)))
                     (string-ref++ buf (location off))))))
         (define (ready?)
           (and (not (eof?))
                (or (not (buf-empty?))
                    (not (queue-empty? queue)))))
         (define (write! s)
           (if (or (and (string? s) (fx> (string-length s) 0))
                   (eof-object? s))
               (begin
                 (mutex-lock! mutex)
                 (queue-add! queue s)
                 (condition-variable-signal! condition)
                 (mutex-unlock! mutex) )))
         (values
          (make-input-port read! ready? nothing)
          (make-output-port write! (lambda () (write! #!eof)))))))))