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