libguile/async.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008,
   2  *   2009, 2010, 2011, 2014 Free Software Foundation, Inc.
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public License
   6  * as published by the Free Software Foundation; either version 3 of
   7  * the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  17  * 02110-1301 USA
  18  */
  19
  20
  21 \f
  22 #ifdef HAVE_CONFIG_H
  23 #  include <config.h>
  24 #endif
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/eval.h"
  28 #include "libguile/throw.h"
  29 #include "libguile/root.h"
  30 #include "libguile/smob.h"
  31 #include "libguile/dynwind.h"
  32 #include "libguile/deprecation.h"
  33
  34 #include "libguile/validate.h"
  35 #include "libguile/async.h"
  36
  37 #ifdef HAVE_STRING_H
  38 #include <string.h>
  39 #endif
  40 #include <unistd.h>
  41
  42 #include <full-write.h>
  43
  44 \f
  45 /* {Asynchronous Events}
  46  *
  47  * There are two kinds of asyncs: system asyncs and user asyncs.  The
  48  * two kinds have some concepts in commen but work slightly
  49  * differently and are not interchangeable.
  50  *
  51  * System asyncs are used to run arbitrary code at the next safe point
  52  * in a specified thread.  You can use them to trigger execution of
  53  * Scheme code from signal handlers or to interrupt a thread, for
  54  * example.
  55  *
  56  * Each thread has a list of 'activated asyncs', which is a normal
  57  * Scheme list of procedures with zero arguments.  When a thread
  58  * executes a SCM_ASYNC_TICK statement (which is included in
  59  * SCM_TICK), it will call all procedures on this list.
  60  *
  61  * Also, a thread will wake up when a procedure is added to its list
  62  * of active asyncs and call them.  After that, it will go to sleep
  63  * again.  (Not implemented yet.)
  64  *
  65  *
  66  * User asyncs are a little data structure that consists of a
  67  * procedure of zero arguments and a mark.  There are functions for
  68  * setting the mark of a user async and for calling all procedures of
  69  * marked asyncs in a given list.  Nothing you couldn't quickly
  70  * implement yourself.
  71  */
  72
  73
  74 \f
  75
  76 /* User asyncs. */
  77
  78 static scm_t_bits tc16_async;
  79
  80 /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
  81    this is ugly.  */
  82 #define SCM_ASYNCP(X)           SCM_TYP16_PREDICATE (tc16_async, X)
  83 #define VALIDATE_ASYNC(pos, a)  SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")
  84
  85 #define ASYNC_GOT_IT(X)        (SCM_SMOB_FLAGS (X))
  86 #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V))))
  87 #define ASYNC_THUNK(X)         SCM_SMOB_OBJECT_1 (X)
  88
  89
  90 SCM_DEFINE (scm_async, "async", 1, 0, 0,
  91             (SCM thunk),
  92             "Create a new async for the procedure @var{thunk}.")
  93 #define FUNC_NAME s_scm_async
  94 {
  95   SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk));
  96 }
  97 #undef FUNC_NAME
  98
  99 SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
 100             (SCM a),
 101             "Mark the async @var{a} for future execution.")
 102 #define FUNC_NAME s_scm_async_mark
 103 {
 104   VALIDATE_ASYNC (1, a);
 105   SET_ASYNC_GOT_IT (a, 1);
 106   return SCM_UNSPECIFIED;
 107 }
 108 #undef FUNC_NAME
 109
 110 SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
 111             (SCM list_of_a),
 112             "Execute all thunks from the asyncs of the list @var{list_of_a}.")
 113 #define FUNC_NAME s_scm_run_asyncs
 114 {
 115   while (! SCM_NULL_OR_NIL_P (list_of_a))
 116     {
 117       SCM a;
 118       SCM_VALIDATE_CONS (1, list_of_a);
 119       a = SCM_CAR (list_of_a);
 120       VALIDATE_ASYNC (SCM_ARG1, a);
 121       if (ASYNC_GOT_IT (a))
 122         {
 123           SET_ASYNC_GOT_IT (a, 0);
 124           scm_call_0 (ASYNC_THUNK (a));
 125         }
 126       list_of_a = SCM_CDR (list_of_a);
 127     }
 128   return SCM_BOOL_T;
 129 }
 130 #undef FUNC_NAME
 131
 132 \f
 133
 134 static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 135
 136 /* System asyncs. */
 137
 138 void
 139 scm_async_tick (void)
 140 {
 141   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 142   SCM asyncs;
 143
 144   /* Reset pending_asyncs even when asyncs are blocked and not really
 145      executed since this will avoid future futile calls to this
 146      function.  When asyncs are unblocked again, this function is
 147      invoked even when pending_asyncs is zero.
 148   */
 149
 150   scm_i_scm_pthread_mutex_lock (&async_mutex);
 151   t->pending_asyncs = 0;
 152   if (t->block_asyncs == 0)
 153     {
 154       asyncs = t->active_asyncs;
 155       t->active_asyncs = SCM_EOL;
 156     }
 157   else
 158     asyncs = SCM_EOL;
 159   scm_i_pthread_mutex_unlock (&async_mutex);
 160
 161   while (scm_is_pair (asyncs))
 162     {
 163       SCM next = SCM_CDR (asyncs);
 164       SCM_SETCDR (asyncs, SCM_BOOL_F);
 165       scm_call_0 (SCM_CAR (asyncs));
 166       asyncs = next;
 167     }
 168 }
 169
 170 void
 171 scm_i_queue_async_cell (SCM c, scm_i_thread *t)
 172 {
 173   SCM sleep_object;
 174   scm_i_pthread_mutex_t *sleep_mutex;
 175   int sleep_fd;
 176   SCM p;
 177
 178   scm_i_scm_pthread_mutex_lock (&async_mutex);
 179   p = t->active_asyncs;
 180   SCM_SETCDR (c, SCM_EOL);
 181   if (!scm_is_pair (p))
 182     t->active_asyncs = c;
 183   else
 184     {
 185       SCM pp;
 186       while (scm_is_pair (pp = SCM_CDR (p)))
 187         {
 188           if (scm_is_eq (SCM_CAR (p), SCM_CAR (c)))
 189             {
 190               scm_i_pthread_mutex_unlock (&async_mutex);
 191               return;
 192             }
 193           p = pp;
 194         }
 195       SCM_SETCDR (p, c);
 196     }
 197   t->pending_asyncs = 1;
 198   sleep_object = t->sleep_object;
 199   sleep_mutex = t->sleep_mutex;
 200   sleep_fd = t->sleep_fd;
 201   scm_i_pthread_mutex_unlock (&async_mutex);
 202
 203   if (sleep_mutex)
 204     {
 205       /* By now, the thread T might be out of its sleep already, or
 206          might even be in the next, unrelated sleep.  Interrupting it
 207          anyway does no harm, however.
 208
 209          The important thing to prevent here is to signal sleep_cond
 210          before T waits on it.  This can not happen since T has
 211          sleep_mutex locked while setting t->sleep_mutex and will only
 212          unlock it again while waiting on sleep_cond.
 213       */
 214       scm_i_scm_pthread_mutex_lock (sleep_mutex);
 215       scm_i_pthread_cond_signal (&t->sleep_cond);
 216       scm_i_pthread_mutex_unlock (sleep_mutex);
 217     }
 218
 219   if (sleep_fd >= 0)
 220     {
 221       char dummy = 0;
 222
 223       /* Likewise, T might already been done with sleeping here, but
 224          interrupting it once too often does no harm.  T might also
 225          not yet have started sleeping, but this is no problem either
 226          since the data written to a pipe will not be lost, unlike a
 227          condition variable signal.  */
 228       full_write (sleep_fd, &dummy, 1);
 229     }
 230
 231   /* This is needed to protect sleep_mutex.
 232    */
 233   scm_remember_upto_here_1 (sleep_object);
 234 }
 235
 236 int
 237 scm_i_setup_sleep (scm_i_thread *t,
 238                    SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex,
 239                    int sleep_fd)
 240 {
 241   int pending;
 242
 243   scm_i_scm_pthread_mutex_lock (&async_mutex);
 244   pending = t->pending_asyncs;
 245   if (!pending)
 246     {
 247       t->sleep_object = sleep_object;
 248       t->sleep_mutex = sleep_mutex;
 249       t->sleep_fd = sleep_fd;
 250     }
 251   scm_i_pthread_mutex_unlock (&async_mutex);
 252   return pending;
 253 }
 254
 255 void
 256 scm_i_reset_sleep (scm_i_thread *t)
 257 {
 258   scm_i_scm_pthread_mutex_lock (&async_mutex);
 259   t->sleep_object = SCM_BOOL_F;
 260   t->sleep_mutex = NULL;
 261   t->sleep_fd = -1;
 262   scm_i_pthread_mutex_unlock (&async_mutex);
 263 }
 264
 265 SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0,
 266            (SCM proc, SCM thread),
 267             "Mark @var{proc} (a procedure with zero arguments) for future execution\n"
 268             "in @var{thread}.  If @var{proc} has already been marked for\n"
 269             "@var{thread} but has not been executed yet, this call has no effect.\n"
 270             "If @var{thread} is omitted, the thread that called\n"
 271             "@code{system-async-mark} is used.\n\n"
 272             "This procedure is not safe to be called from C signal handlers.  Use\n"
 273             "@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install\n"
 274             "signal handlers.")
 275 #define FUNC_NAME s_scm_system_async_mark_for_thread
 276 {
 277   /* The current thread might not have a handle yet.  This can happen
 278      when the GC runs immediately before allocating the handle.  At
 279      the end of that GC, a system async might be marked.  Thus, we can
 280      not use scm_current_thread here.
 281   */
 282
 283   scm_i_thread *t;
 284
 285   if (SCM_UNBNDP (thread))
 286     t = SCM_I_CURRENT_THREAD;
 287   else
 288     {
 289       SCM_VALIDATE_THREAD (2, thread);
 290       if (scm_c_thread_exited_p (thread))
 291         SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
 292       t = SCM_I_THREAD_DATA (thread);
 293     }
 294   scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t);
 295   return SCM_UNSPECIFIED;
 296 }
 297 #undef FUNC_NAME
 298
 299 SCM
 300 scm_system_async_mark (SCM proc)
 301 #define FUNC_NAME s_scm_system_async_mark_for_thread
 302 {
 303   return scm_system_async_mark_for_thread (proc, SCM_UNDEFINED);
 304 }
 305 #undef FUNC_NAME
 306
 307 \f
 308
 309
 310 SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
 311             (SCM args),
 312             "Do nothing.  When called without arguments, return @code{#f},\n"
 313             "otherwise return the first argument.")
 314 #define FUNC_NAME s_scm_noop
 315 {
 316   SCM_VALIDATE_REST_ARGUMENT (args);
 317   return (SCM_NULL_OR_NIL_P (args) ? SCM_BOOL_F : SCM_CAR (args));
 318 }
 319 #undef FUNC_NAME
 320
 321
 322 \f
 323
 324 static void
 325 increase_block (void *data)
 326 {
 327   scm_i_thread *t = data;
 328   t->block_asyncs++;
 329 }
 330
 331 static void
 332 decrease_block (void *data)
 333 {
 334   scm_i_thread *t = data;
 335   if (--t->block_asyncs == 0)
 336     scm_async_tick ();
 337 }
 338
 339 void
 340 scm_dynwind_block_asyncs (void)
 341 {
 342   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 343   scm_dynwind_rewind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
 344   scm_dynwind_unwind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
 345 }
 346
 347 void
 348 scm_dynwind_unblock_asyncs (void)
 349 {
 350   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 351   if (t->block_asyncs == 0)
 352     scm_misc_error ("scm_with_unblocked_asyncs",
 353                     "asyncs already unblocked", SCM_EOL);
 354   scm_dynwind_rewind_handler (decrease_block, t, SCM_F_WIND_EXPLICITLY);
 355   scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
 356 }
 357
 358 SCM_DEFINE (scm_call_with_blocked_asyncs, "call-with-blocked-asyncs", 1, 0, 0,
 359             (SCM proc),
 360             "Call @var{proc} with no arguments and block the execution\n"
 361             "of system asyncs by one level for the current thread while\n"
 362             "it is running.  Return the value returned by @var{proc}.\n")
 363 #define FUNC_NAME s_scm_call_with_blocked_asyncs
 364 {
 365   SCM ans;
 366
 367   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 368   scm_dynwind_block_asyncs ();
 369   ans = scm_call_0 (proc);
 370   scm_dynwind_end ();
 371
 372   return ans;
 373 }
 374 #undef FUNC_NAME
 375
 376 void *
 377 scm_c_call_with_blocked_asyncs (void *(*proc) (void *data), void *data)
 378 {
 379   void* ans;
 380
 381   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 382   scm_dynwind_block_asyncs ();
 383   ans = proc (data);
 384   scm_dynwind_end ();
 385
 386   return ans;
 387 }
 388
 389
 390 SCM_DEFINE (scm_call_with_unblocked_asyncs, "call-with-unblocked-asyncs", 1, 0, 0,
 391             (SCM proc),
 392             "Call @var{proc} with no arguments and unblock the execution\n"
 393             "of system asyncs by one level for the current thread while\n"
 394             "it is running.  Return the value returned by @var{proc}.\n")
 395 #define FUNC_NAME s_scm_call_with_unblocked_asyncs
 396 {
 397   SCM ans;
 398
 399   if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
 400     SCM_MISC_ERROR ("asyncs already unblocked", SCM_EOL);
 401
 402   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 403   scm_dynwind_unblock_asyncs ();
 404   ans = scm_call_0 (proc);
 405   scm_dynwind_end ();
 406
 407   return ans;
 408 }
 409 #undef FUNC_NAME
 410
 411 void *
 412 scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
 413 {
 414   void* ans;
 415
 416   if (SCM_I_CURRENT_THREAD->block_asyncs == 0)
 417     scm_misc_error ("scm_c_call_with_unblocked_asyncs",
 418                     "asyncs already unblocked", SCM_EOL);
 419
 420   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 421   scm_dynwind_unblock_asyncs ();
 422   ans = proc (data);
 423   scm_dynwind_end ();
 424
 425   return ans;
 426 }
 427
 428 \f
 429 /* These are function variants of the same-named macros (uppercase) for use
 430    outside of libguile.  This is so that `SCM_I_CURRENT_THREAD', which may
 431    reside in TLS, is not accessed from outside of libguile.  It thus allows
 432    libguile to be built with the "local-dynamic" TLS model.  */
 433
 434 void
 435 scm_critical_section_start (void)
 436 {
 437   SCM_CRITICAL_SECTION_START;
 438 }
 439
 440 void
 441 scm_critical_section_end (void)
 442 {
 443   SCM_CRITICAL_SECTION_END;
 444 }
 445
 446 \f
 447
 448 void
 449 scm_init_async ()
 450 {
 451   tc16_async = scm_make_smob_type ("async", 0);
 452
 453 #include "libguile/async.x"
 454 }
 455
 456 /*
 457   Local Variables:
 458   c-file-style: "gnu"
 459   End:
 460 */