guile18/libguile/futures.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20
  21 #if 0
  22
  23 /* This whole file is not being compiled.  See futures.h for the
  24    reason.
  25 */
  26
  27 #ifdef HAVE_CONFIG_H
  28 # include <config.h>
  29 #endif
  30
  31 #include "libguile/_scm.h"
  32 #include "libguile/eval.h"
  33 #include "libguile/ports.h"
  34 #include "libguile/validate.h"
  35 #include "libguile/stime.h"
  36 #include "libguile/threads.h"
  37
  38 #include "libguile/futures.h"
  39
  40 #define LINK(list, obj)                         \
  41 do {                                            \
  42   SCM_SET_FUTURE_NEXT (obj, list);              \
  43   list = obj;                                   \
  44 } while (0)
  45
  46 #define UNLINK(list, obj)                       \
  47 do {                                            \
  48   obj = list;                                   \
  49   list = SCM_FUTURE_NEXT (list);                \
  50 } while (0)
  51
  52 scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  53
  54 static SCM futures = SCM_EOL;
  55 static SCM young = SCM_EOL;
  56 static SCM old = SCM_EOL;
  57 static SCM undead = SCM_EOL;
  58
  59 static long last_switch;
  60
  61 #ifdef SCM_FUTURES_DEBUG
  62 static int n_dead = 0;
  63
  64 static SCM
  65 count (SCM ls)
  66 {
  67   int n = 0;
  68   while (!scm_is_null (ls))
  69     {
  70       ++n;
  71       ls = SCM_FUTURE_NEXT (ls);
  72     }
  73   return scm_from_int (n);
  74 }
  75
  76 extern SCM scm_future_cache_status (void);
  77
  78 SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0,
  79             (),
  80             "Return a list containing number of futures, youngs, olds, undeads and deads.")
  81 #define FUNC_NAME s_scm_future_cache_status
  82 {
  83   int nd = n_dead;
  84   n_dead = 0;
  85   return scm_list_5 (count (futures),
  86                      count (young),
  87                      count (old),
  88                      count (undead),
  89                      scm_from_int (nd));
  90 }
  91 #undef FUNC_NAME
  92
  93 #endif
  94
  95 SCM *scm_loc_sys_thread_handler;
  96
  97 SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0,
  98             (SCM thunk),
  99             "Make a future evaluating THUNK.")
 100 #define FUNC_NAME s_scm_make_future
 101 {
 102   SCM_VALIDATE_THUNK (1, thunk);
 103   return scm_i_make_future (thunk);
 104 }
 105 #undef FUNC_NAME
 106
 107 static char *s_future = "future";
 108
 109 static void
 110 cleanup (scm_t_future *future)
 111 {
 112   scm_i_pthread_mutex_destroy (&future->mutex);
 113   scm_i_pthread_cond_destroy (&future->cond);
 114   scm_gc_free (future, sizeof (*future), s_future);
 115 #ifdef SCM_FUTURES_DEBUG
 116   ++n_dead;
 117 #endif
 118 }
 119
 120 static SCM
 121 future_loop (scm_t_future *future)
 122 {
 123   scm_i_scm_pthread_mutex_lock (&future->mutex);
 124   do {
 125     if (future->status == SCM_FUTURE_SIGNAL_ME)
 126       scm_i_pthread_cond_broadcast (&future->cond);
 127     future->status = SCM_FUTURE_COMPUTING;
 128     future->data = (SCM_CLOSUREP (future->data)
 129                     ? scm_i_call_closure_0 (future->data)
 130                     : scm_call_0 (future->data));
 131     scm_i_scm_pthread_cond_wait (&future->cond, &future->mutex);
 132   } while (!future->die_p);
 133   future->status = SCM_FUTURE_DEAD;
 134   scm_i_pthread_mutex_unlock (&future->mutex);
 135   return SCM_UNSPECIFIED;
 136 }
 137
 138 static SCM
 139 future_handler (scm_t_future *future, SCM key, SCM args)
 140 {
 141   future->status = SCM_FUTURE_DEAD;
 142   scm_i_pthread_mutex_unlock (&future->mutex);
 143   return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
 144 }
 145
 146 static SCM
 147 alloc_future (SCM thunk)
 148 {
 149   scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future);
 150   SCM future;
 151   f->data = SCM_BOOL_F;
 152   scm_i_pthread_mutex_init (&f->mutex, NULL);
 153   scm_i_pthread_cond_init (&f->cond, NULL);
 154   f->die_p = 0;
 155   f->status = SCM_FUTURE_TASK_ASSIGNED;
 156   scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
 157   SCM_NEWSMOB2 (future, scm_tc16_future, futures, f);
 158   SCM_SET_FUTURE_DATA (future, thunk);
 159   futures = future;
 160   scm_i_pthread_mutex_unlock (&future_admin_mutex);
 161   scm_spawn_thread ((scm_t_catch_body) future_loop,
 162                     SCM_FUTURE (future),
 163                     (scm_t_catch_handler) future_handler,
 164                     SCM_FUTURE (future));
 165   return future;
 166 }
 167
 168 static void
 169 kill_future (SCM future)
 170 {
 171   SCM_FUTURE (future)->die_p = 1;
 172   LINK (undead, future);
 173 }
 174
 175 SCM
 176 scm_i_make_future (SCM thunk)
 177 {
 178   SCM future;
 179   scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
 180   while (1)
 181     {
 182       if (!scm_is_null (old))
 183         UNLINK (old, future);
 184       else if (!scm_is_null (young))
 185         UNLINK (young, future);
 186       else
 187         {
 188           scm_i_pthread_mutex_unlock (&future_admin_mutex);
 189           return alloc_future (thunk);
 190         }
 191       if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
 192         kill_future (future);
 193       else if (!SCM_FUTURE_ALIVE_P (future))
 194         {
 195           scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 196           cleanup (SCM_FUTURE (future));
 197         }
 198       else
 199         break;
 200     }
 201   LINK (futures, future);
 202   scm_i_pthread_mutex_unlock (&future_admin_mutex);
 203   SCM_SET_FUTURE_DATA (future, thunk);
 204   SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED);
 205   scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
 206   scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 207   return future;
 208 }
 209
 210 static SCM
 211 future_mark (SCM ptr) {
 212   return SCM_FUTURE_DATA (ptr);
 213 }
 214
 215 static int
 216 future_print (SCM exp, SCM port, scm_print_state *pstate)
 217 {
 218   int writingp = SCM_WRITINGP (pstate);
 219   scm_puts ("#<future ", port);
 220   SCM_SET_WRITINGP (pstate, 1);
 221   scm_iprin1 (SCM_FUTURE_DATA (exp), port, pstate);
 222   SCM_SET_WRITINGP (pstate, writingp);
 223   scm_putc ('>', port);
 224   return !0;
 225 }
 226
 227 SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
 228             (SCM future),
 229             "If the future @var{x} has not been computed yet, compute and\n"
 230             "return @var{x}, otherwise just return the previously computed\n"
 231             "value.")
 232 #define FUNC_NAME s_scm_future_ref
 233 {
 234   SCM res;
 235   SCM_VALIDATE_FUTURE (1, future);
 236   scm_i_scm_pthread_mutex_lock (SCM_FUTURE_MUTEX (future));
 237   if (SCM_FUTURE_STATUS (future) != SCM_FUTURE_COMPUTING)
 238     {
 239       SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_SIGNAL_ME);
 240       scm_i_scm_pthread_cond_wait (SCM_FUTURE_COND (future),
 241                              SCM_FUTURE_MUTEX (future));
 242     }
 243   if (!SCM_FUTURE_ALIVE_P (future))
 244     {
 245       scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 246       SCM_MISC_ERROR ("requesting result from failed future ~A",
 247                       scm_list_1 (future));
 248     }
 249   res = SCM_FUTURE_DATA (future);
 250   scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 251   return res;
 252 }
 253 #undef FUNC_NAME
 254
 255 static void
 256 kill_futures (SCM victims)
 257 {
 258   while (!scm_is_null (victims))
 259     {
 260       SCM future;
 261       UNLINK (victims, future);
 262       kill_future (future);
 263       scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
 264     }
 265 }
 266
 267 static void
 268 cleanup_undead ()
 269 {
 270   SCM next = undead, *nextloc = &undead;
 271   while (!scm_is_null (next))
 272     {
 273       if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next)))
 274         goto next;
 275       else if (SCM_FUTURE_ALIVE_P (next))
 276         {
 277           scm_i_pthread_cond_signal (SCM_FUTURE_COND (next));
 278           scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
 279         next:
 280           SCM_SET_GC_MARK (next);
 281           nextloc = SCM_FUTURE_NEXTLOC (next);
 282           next = *nextloc;
 283         }
 284       else
 285         {
 286           SCM future;
 287           UNLINK (next, future);
 288           scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
 289           cleanup (SCM_FUTURE (future));
 290           *nextloc = next;
 291         }
 292     }
 293 }
 294
 295 static void
 296 mark_futures (SCM futures)
 297 {
 298   while (!scm_is_null (futures))
 299     {
 300       SCM_SET_GC_MARK (futures);
 301       futures = SCM_FUTURE_NEXT (futures);
 302     }
 303 }
 304
 305 static void *
 306 scan_futures (void *dummy1, void *dummy2, void *dummy3)
 307 {
 308   SCM next, *nextloc;
 309
 310   long now = scm_c_get_internal_run_time ();
 311   if (now - last_switch > SCM_TIME_UNITS_PER_SECOND)
 312     {
 313       /* switch out old (> 1 sec), unused futures */
 314       kill_futures (old);
 315       old = young;
 316       young = SCM_EOL;
 317       last_switch = now;
 318     }
 319   else
 320     mark_futures (young);
 321
 322   next = futures;
 323   nextloc = &futures;
 324   while (!scm_is_null (next))
 325     {
 326       if (!SCM_GC_MARK_P (next))
 327         goto free;
 328     keep:
 329       nextloc = SCM_FUTURE_NEXTLOC (next);
 330       next = *nextloc;
 331     }
 332   goto exit;
 333   while (!scm_is_null (next))
 334     {
 335       if (SCM_GC_MARK_P (next))
 336         {
 337           *nextloc = next;
 338           goto keep;
 339         }
 340     free:
 341       {
 342         SCM future;
 343         UNLINK (next, future);
 344         SCM_SET_GC_MARK (future);
 345         LINK (young, future);
 346       }
 347     }
 348   *nextloc = SCM_EOL;
 349  exit:
 350   cleanup_undead ();
 351   mark_futures (old);
 352   return 0;
 353 }
 354
 355 scm_t_bits scm_tc16_future;
 356
 357 void
 358 scm_init_futures ()
 359 {
 360   last_switch = scm_c_get_internal_run_time ();
 361
 362   scm_loc_sys_thread_handler
 363     = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F));
 364
 365   scm_tc16_future = scm_make_smob_type ("future", 0);
 366   scm_set_smob_mark (scm_tc16_future, future_mark);
 367   scm_set_smob_print (scm_tc16_future, future_print);
 368
 369   scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0);
 370 #include "libguile/futures.x"
 371 }
 372
 373 #endif
 374
 375 /*
 376   Local Variables:
 377   c-file-style: "gnu"
 378   End:
 379 */