chicken-users
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: [Chicken-users] Chicken callbacks


From: chi
Subject: Re: [Chicken-users] Chicken callbacks
Date: Fri, 05 Jun 2015 12:37:43 -0700
User-agent: Mozilla/5.0 (X11; Linux x86_64; rv:31.0) Gecko/20100101 Thunderbird/31.7.0

So it /is/ possible. Interesting!

> if the callbacks are being called from another native thread

That actually might not be such a bad idea. All the callbacks would have to be
purely in C of course, which is what the concurrent-natives-callback egg does,
but you could run libuv with UV_RUN_DEFAULT and it couldn't have bizarre bugs
where a developer assumes that nobody ever uses UV_RUN_ONCE anyway. Plus I don't
want to tout the benefits of multi-threading or anything, but evidently
confining one's IO loop to a dedicated thread and communicated with it using
message passing has historically made things a lot faster, and preemptively
eliminated a lot of accidental blocking.

Well, if the ZeroMQ crowd are to be believed at least.

Huh, it's odd in concurrent-native-callbacks, how they write a pointer value to
the pipe, then wait on a condition, in the synchronous case. That seems 
redundant.
You could just use that pointer's address without a pipe, since nothing's going
to touch that pointer while the synchronous callback uses the pointer value to
get its arguments, since the IO thread is locked.

Like uh... something like this patch, except actually working and not forgetting
a million things.
diff --git a/cncb-compile-time.scm b/cncb-compile-time.scm
index fb43681..091f373 100644
--- a/cncb-compile-time.scm
+++ b/cncb-compile-time.scm
@@ -1,7 +1,7 @@
 ;;;; compile-time part of cncb
 
 
-(use data-structures srfi-1 matchable ports)
+(use data-structures srfi-1 matchable)
 
 
 (define (cncb-transformer x r c sync)
@@ -38,8 +38,6 @@
 (define (generate-entry-point r name dispvar t/a sync rtype)
   (let ((cvar (gensym "cvar"))
        (mutex (gensym "mutex"))
-       (infd (gensym "infd"))
-       (outfd (gensym "outfd"))
        (data (gensym "data"))
        (ptr (gensym "ptr"))
        (result (symbol->string (gensym "result")))
@@ -94,7 +92,7 @@
     `(,%begin
       (,%foreign-declare
        "#include <pthread.h>\n"
-       ,(conc "static int " infd "," outfd ";\n")
+       "void* global_data_for_scheme = NULL;"
        ,(conc (if sync (foreign-type-declaration rtype "") "void")
              " " name "("
              (string-intersperse 
@@ -115,7 +113,7 @@
                  "pthread_cond_init(&" cvar ", NULL);\n"
                  "pthread_mutex_lock(&" mutex ");\n")
            "")
-       ,(conc "(void)write(" outfd ", &" data ", sizeof(void *));\n")
+       "global_data_for_scheme = data;\n"
        ,(if sync
            (conc "pthread_cond_wait(&" cvar ", &" mutex ");\n"
                  "pthread_mutex_unlock(&" mutex ");\n"
@@ -123,13 +121,9 @@
                  "pthread_mutex_destroy(&" mutex ");\n")
           "")
        ,(if (and sync (not (eq? 'void rtype)))
-           (conc "return " result ";\n")
+           (conc "return (" rtype ") global_data_for_scheme;\n")
            "")
-       "}\n")
-      (,%define-foreign-variable ,infd int)
-      (,%define-foreign-variable ,outfd int)
-      (set! ,outfd (,%dispatcher-argument-output-fileno ,dispvar))
-      (set! ,infd (,%dispatcher-result-input-fileno ,dispvar)))))
+       "}\n"))))
 
 
 (define (unstash-and-execute r t/a ptr body sync rtype)
diff --git a/cncb.scm b/cncb.scm
index 58ecf82..054d5de 100644
--- a/cncb.scm
+++ b/cncb.scm
@@ -18,29 +18,18 @@
 (define-record dispatcher
   (id : symbol)
   (thread : thread)
-  (callbacks : (list-of (pair fixnum ((struct dispatcher) pointer -> * 
boolean))))
-  (argument-input-fileno : fixnum)
-  (argument-output-fileno : fixnum)
-  (result-input-fileno : fixnum)
-  (result-output-fileno : fixnum) )
+  (callbacks : (list-of (pair fixnum ((struct dispatcher) pointer -> * 
boolean)))))
 
 
 (define word-size (foreign-value "sizeof(void *)" int))
 (define dispatcher-table (make-hash-table eq?))
 
-(define (nonblocking-pipe-input-port fd id)
-  (##sys#custom-input-port 'nonblocking-pipe-input-port (->string id) fd #t))
-
-(define (nonblocking-pipe-output-port fd id)
-  (##sys#custom-output-port 'nonblocking-pipe-output-port (->string id) fd #t))
-
 (define (dispatch-loop box)
   (let* ((disp (car box))
         (id (dispatcher-id disp))
-        (in (nonblocking-pipe-input-port (dispatcher-argument-input-fileno 
disp) id))
-        (out (nonblocking-pipe-output-port (dispatcher-result-output-fileno 
disp) id)))
      (let loop ()
-      (let* ((str (read-string word-size in))
+       (wait-for-callback-called-condition)
+      (let* ((str (get-string-from "global_data_for_scheme"))
             (input (extract_argument_ptr str)))
        (cond (input
               (let ((cbname (extract_callback_name input)))
@@ -50,18 +39,12 @@
                       (else
                        (warning "callback not found" cbname id)))
                 (loop)))
-             (else                     ; NULL-ptr aborts dispatcher
-              (close-input-port in)
-              (close-output-port out)
-              (file-close (dispatcher-argument-output-fileno disp))
-              (file-close (dispatcher-result-input-fileno disp))))))))
+             (else #f)))))))                   ; NULL-ptr aborts dispatcher
 
 (define (create-dispatcher id thread)
-  (let-values (((in1 out1) (create-pipe))
-              ((in2 out2) (create-pipe)))
-    (let ((disp (make-dispatcher id thread '() in1 out1 in2 out2)))
+  (let ((disp (make-dispatcher id thread '())))
     (hash-table-set! dispatcher-table id disp)
-      disp)))
+    disp))
 
 (define (dispatcher id)
   (let ((box (list #f)))
@@ -82,7 +65,7 @@
 
 (define (dispatcher-terminate! disp)
   (send_termination_message
-   (dispatcher-argument-output-fileno disp)))
+   (get-c-global-thing "global_data_for_scheme"))))
 
 
 (define-syntax define-concurrent-native-callback

reply via email to

[Prev in Thread] Current Thread [Next in Thread]