libguile/futures.c

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