[Guile-commits] 01/02: Move call-with-new-thread to Scheme

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit f3bfe29235199e12b961c3fd1fa92666ad031d0d
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 25 22:24:19 2016 +0200

    Move call-with-new-thread to Scheme
    
    * libguile/threads.c (scm_call_with_new_thread): Trampoline to Scheme.
      (launch_data, really_launch, scm_sys_call_with_new_thread): Simplify.
      (scm_init_ice_9_threads): Capture call-with-new-thread variable.
    * module/ice-9/threads.scm (call-with-new-thread): Add implementation in
      Scheme.  Should allow for easier cancel-thread via prompt abort.
---
 libguile/threads.c       |   83 +++++++++++++++++-----------------------------
 module/ice-9/threads.scm |   33 ++++++++++++++++++
 2 files changed, 63 insertions(+), 53 deletions(-)

diff --git a/libguile/threads.c b/libguile/threads.c
index 9f11ac7..1dece56 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -858,34 +858,29 @@ scm_without_guile (void *(*func)(void *), void *data)
 
 /*** Thread creation */
 
+/* Because (ice-9 boot-9) loads up (ice-9 threads), we know that this
+   variable will get loaded before a call to scm_call_with_new_thread
+   and therefore no lock or pthread_once_t is needed. */
+static SCM call_with_new_thread_var;
+
+SCM
+scm_call_with_new_thread (SCM thunk, SCM handler)
+{
+  SCM call_with_new_thread = scm_variable_ref (call_with_new_thread_var);
+  if (SCM_UNBNDP (handler))
+    return scm_call_1 (call_with_new_thread, thunk);
+  return scm_call_2 (call_with_new_thread, thunk, handler);
+}
+
 typedef struct {
   SCM parent;
   SCM thunk;
-  SCM handler;
-  SCM thread;
-  scm_i_pthread_mutex_t mutex;
-  scm_i_pthread_cond_t cond;
 } launch_data;
 
 static void *
 really_launch (void *d)
 {
-  launch_data *data = (launch_data *)d;
-  SCM thunk = data->thunk, handler = data->handler;
-  scm_i_thread *t;
-
-  t = SCM_I_CURRENT_THREAD;
-
-  scm_i_scm_pthread_mutex_lock (&data->mutex);
-  data->thread = scm_current_thread ();
-  scm_i_pthread_cond_signal (&data->cond);
-  scm_i_pthread_mutex_unlock (&data->mutex);
-
-  if (SCM_UNBNDP (handler))
-    t->result = scm_call_0 (thunk);
-  else
-    t->result = scm_catch (SCM_BOOL_T, thunk, handler);
-
+  SCM_I_CURRENT_THREAD->result = scm_call_0 (((launch_data *)d)->thunk);
   return 0;
 }
 
@@ -898,51 +893,29 @@ launch_thread (void *d)
   return NULL;
 }
 
-SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 1, 1, 0,
-           (SCM thunk, SCM handler),
-           "Call @code{thunk} in a new thread and with a new dynamic state,\n"
-           "returning a new thread object representing the thread.  The 
procedure\n"
-           "@var{thunk} is called via @code{with-continuation-barrier}.\n"
-           "\n"
-           "When @var{handler} is specified, then @var{thunk} is called from\n"
-           "within a @code{catch} with tag @code{#t} that has @var{handler} as 
its\n"
-           "handler.  This catch is established inside the continuation 
barrier.\n"
-           "\n"
-           "Once @var{thunk} or @var{handler} returns, the return value is 
made\n"
-           "the @emph{exit value} of the thread and the thread is terminated.")
-#define FUNC_NAME s_scm_call_with_new_thread
-{
-  launch_data data;
+SCM_INTERNAL SCM scm_sys_call_with_new_thread (SCM);
+SCM_DEFINE (scm_sys_call_with_new_thread, "%call-with-new-thread", 1, 0, 0,
+           (SCM thunk), "")
+#define FUNC_NAME s_scm_sys_call_with_new_thread
+{
+  launch_data *data;
   scm_i_pthread_t id;
   int err;
 
   SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
-  SCM_ASSERT (SCM_UNBNDP (handler) || scm_is_true (scm_procedure_p (handler)),
-             handler, SCM_ARG2, FUNC_NAME);
 
   GC_collect_a_little ();
-  data.parent = scm_current_dynamic_state ();
-  data.thunk = thunk;
-  data.handler = handler;
-  data.thread = SCM_BOOL_F;
-  scm_i_pthread_mutex_init (&data.mutex, NULL);
-  scm_i_pthread_cond_init (&data.cond, NULL);
-
-  scm_i_scm_pthread_mutex_lock (&data.mutex);
-  err = scm_i_pthread_create (&id, NULL, launch_thread, &data);
+  data = scm_gc_typed_calloc (launch_data);
+  data->parent = scm_current_dynamic_state ();
+  data->thunk = thunk;
+  err = scm_i_pthread_create (&id, NULL, launch_thread, data);
   if (err)
     {
-      scm_i_pthread_mutex_unlock (&data.mutex);
       errno = err;
       scm_syserror (NULL);
     }
 
-  while (scm_is_false (data.thread))
-    scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
-
-  scm_i_pthread_mutex_unlock (&data.mutex);
-
-  return data.thread;
+  return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
 
@@ -2097,6 +2070,10 @@ static void
 scm_init_ice_9_threads (void *unused)
 {
 #include "libguile/threads.x"
+
+  call_with_new_thread_var =
+    scm_module_variable (scm_current_module (),
+                         scm_from_latin1_symbol ("call-with-new-thread"));
 }
 
 void
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index 49d070b..f0f08e0 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -86,6 +86,39 @@
 
 
 
+(define* (call-with-new-thread thunk #:optional handler)
+  "Call @code{thunk} in a new thread and with a new dynamic state,
+returning a new thread object representing the thread.  The procedure
address@hidden is called via @code{with-continuation-barrier}.
+
+When @var{handler} is specified, then @var{thunk} is called from within
+a @code{catch} with tag @code{#t} that has @var{handler} as its handler.
+This catch is established inside the continuation barrier.
+
+Once @var{thunk} or @var{handler} returns, the return value is made the
address@hidden value} of the thread and the thread is terminated."
+  (let ((cv (make-condition-variable))
+        (mutex (make-mutex))
+        (thunk (if handler
+                   (lambda () (catch #t thunk handler))
+                   thunk))
+        (thread #f))
+    (with-mutex mutex
+      (%call-with-new-thread
+       (lambda ()
+         (lock-mutex mutex)
+         (set! thread (current-thread))
+         (signal-condition-variable cv)
+         (unlock-mutex mutex)
+         (thunk)))
+      (let lp ()
+        (unless thread
+          (wait-condition-variable cv mutex)
+          (lp))))
+    thread))
+
+
+
 ;;; Macros first, so that the procedures expand correctly.
 
 (define-syntax-rule (begin-thread e0 e1 ...)