* futures.h, futures.c: New files; Introduced recycling of

futures.  For fine-grained threading this lifts performance to
another level.  We can now use parallelization in inner loops of
Guile programs without impossible overhead.

diff --git a/libguile/futures.c b/libguile/futures.c
new file mode 100644 (file)
index 0000000..fefd931
--- /dev/null
+++ b/libguile/futures.c
@@ -0,0 +1,387 @@
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003 Free Software Foundation, Inc.
+ * 
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+
+\f
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/validate.h"
+#include "libguile/stime.h"
+#include "libguile/threads.h"
+
+#include "libguile/futures.h"
+
+#define LINK(list, obj)                                \
+do {                                           \
+  SCM_SET_FUTURE_NEXT (obj, list);             \
+  list = obj;                                  \
+} while (0)
+
+#define UNLINK(list, obj)                      \
+do {                                           \
+  obj = list;                                  \
+  list = SCM_FUTURE_NEXT (list);               \
+} while (0)
+     
+SCM_MUTEX (future_admin_mutex);
+
+static SCM futures = SCM_EOL;
+static SCM young = SCM_EOL;
+static SCM old = SCM_EOL;
+static SCM undead = SCM_EOL;
+
+static long last_switch;
+
+#ifdef SCM_FUTURES_DEBUG
+static int n_dead = 0;
+
+static SCM
+count (SCM ls)
+{
+  int n = 0;
+  while (!SCM_NULLP (ls))
+    {
+      ++n;
+      ls = SCM_FUTURE_NEXT (ls);
+    }
+  return SCM_MAKINUM (n);
+}
+
+extern SCM scm_future_cache_status (void);
+
+SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0,
+           (),
+           "Return a list containing number of futures, youngs, olds, undeads and deads.")
+#define FUNC_NAME s_scm_future_cache_status
+{
+  int nd = n_dead;
+  n_dead = 0;
+  return scm_list_5 (count (futures),
+                    count (young),
+                    count (old),
+                    count (undead),
+                    SCM_MAKINUM (nd));
+}
+#undef FUNC_NAME
+
+#endif
+
+SCM *scm_loc_sys_thread_handler;
+
+SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0,
+           (SCM thunk),
+           "Make a future evaluating THUNK.")
+#define FUNC_NAME s_scm_make_future
+{
+  SCM_VALIDATE_THUNK (1, thunk);
+  return scm_i_make_future (thunk);
+}
+#undef FUNC_NAME
+
+static char *s_future = "future";
+
+static void
+cleanup (scm_t_future *future)
+{
+  scm_mutex_destroy (&future->mutex);
+  scm_cond_destroy (&future->cond);
+  scm_gc_free (future, sizeof (*future), s_future);
+#ifdef SCM_FUTURES_DEBUG
+  ++n_dead;
+#endif
+}
+
+static SCM
+future_loop (scm_t_future *future)
+{
+  scm_mutex_lock (&future->mutex);
+  do {
+    if (future->status == SCM_FUTURE_SIGNAL_ME)
+      scm_cond_broadcast (&future->cond);
+    future->status = SCM_FUTURE_COMPUTING;
+    future->data = (SCM_CLOSUREP (future->data)
+                   ? scm_i_call_closure_0 (future->data)
+                   : scm_call_0 (future->data));
+    scm_cond_wait (&future->cond, &future->mutex);
+  } while (!future->die_p);
+  future->status = SCM_FUTURE_DEAD;
+  scm_mutex_unlock (&future->mutex);
+  return SCM_UNSPECIFIED;
+}
+
+static SCM
+future_handler (scm_t_future *future, SCM key, SCM args)
+{
+  future->status = SCM_FUTURE_DEAD;
+  scm_mutex_unlock (&future->mutex);
+  return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
+}
+
+static SCM
+alloc_future (SCM thunk)
+{
+  scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future);
+  SCM future;
+  f->data = SCM_BOOL_F;
+  scm_mutex_init (&f->mutex, &scm_i_plugin_mutex);
+  scm_cond_init (&f->cond, 0);
+  f->die_p = 0;
+  f->status = SCM_FUTURE_TASK_ASSIGNED;
+  scm_mutex_lock (&future_admin_mutex);
+  SCM_NEWSMOB2 (future, scm_tc16_future, futures, f);
+  SCM_SET_FUTURE_DATA (future, thunk);
+  futures = future;
+  scm_mutex_unlock (&future_admin_mutex);
+  scm_spawn_thread ((scm_t_catch_body) future_loop,
+                   SCM_FUTURE (future),
+                   (scm_t_catch_handler) future_handler,
+                   SCM_FUTURE (future));
+  return future;
+}
+
+static void
+kill_future (SCM future)
+{
+  SCM_FUTURE (future)->die_p = 1;
+  LINK (undead, future);
+}
+
+SCM
+scm_i_make_future (SCM thunk)
+{
+  SCM future;
+  scm_mutex_lock (&future_admin_mutex);
+  while (1)
+    {
+      if (!SCM_NULLP (old))
+       UNLINK (old, future);
+      else if (!SCM_NULLP (young))
+       UNLINK (young, future);
+      else
+       {
+         scm_mutex_unlock (&future_admin_mutex);
+         return alloc_future (thunk);
+       }
+      if (scm_mutex_trylock (SCM_FUTURE_MUTEX (future)))
+       kill_future (future);
+      else if (!SCM_FUTURE_ALIVE_P (future))
+       {
+         scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+         cleanup (SCM_FUTURE (future));
+       }
+      else
+       break;
+    }
+  LINK (futures, future);
+  scm_mutex_unlock (&future_admin_mutex);
+  SCM_SET_FUTURE_DATA (future, thunk);
+  SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED);
+  scm_cond_signal (SCM_FUTURE_COND (future));
+  scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+  return future;
+}
+
+static SCM
+future_mark (SCM ptr) {
+  return SCM_FUTURE_DATA (ptr);
+}
+
+static int 
+future_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+  int writingp = SCM_WRITINGP (pstate);
+  scm_puts ("#<future ", port);
+  SCM_SET_WRITINGP (pstate, 1);
+  scm_iprin1 (SCM_FUTURE_DATA (exp), port, pstate);
+  SCM_SET_WRITINGP (pstate, writingp);
+  scm_putc ('>', port);
+  return !0;
+}
+
+SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
+           (SCM future),
+           "If the future @var{x} has not been computed yet, compute and\n"
+           "return @var{x}, otherwise just return the previously computed\n"
+           "value.")
+#define FUNC_NAME s_scm_future_ref
+{
+  SCM res;
+  SCM_VALIDATE_FUTURE (1, future);
+  scm_mutex_lock (SCM_FUTURE_MUTEX (future));
+  if (SCM_FUTURE_STATUS (future) != SCM_FUTURE_COMPUTING)
+    {
+      SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_SIGNAL_ME);
+      scm_cond_wait (SCM_FUTURE_COND (future), SCM_FUTURE_MUTEX (future));
+    }
+  if (!SCM_FUTURE_ALIVE_P (future))
+    {
+      scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+      SCM_MISC_ERROR ("requesting result from failed future ~A",
+                     scm_list_1 (future));
+    }
+  res = SCM_FUTURE_DATA (future);
+  scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+  return res;
+}
+#undef FUNC_NAME
+
+static void
+kill_futures (SCM victims)
+{
+  while (!SCM_NULLP (victims))
+    {
+      SCM future;
+      UNLINK (victims, future);
+      kill_future (future);
+      scm_cond_signal (SCM_FUTURE_COND (future));
+    }
+}
+
+static void
+cleanup_undead ()
+{
+  SCM next = undead, *nextloc = &undead;
+  while (!SCM_NULLP (next))
+    {
+      if (scm_mutex_trylock (SCM_FUTURE_MUTEX (next)))
+       goto next;
+      else if (SCM_FUTURE_ALIVE_P (next))
+       {
+         scm_cond_signal (SCM_FUTURE_COND (next));
+         scm_mutex_unlock (SCM_FUTURE_MUTEX (next));
+       next:
+         nextloc = SCM_FUTURE_NEXTLOC (next);
+         next = *nextloc;
+       }
+      else
+       {
+         SCM future;
+         UNLINK (next, future);
+         scm_mutex_unlock (SCM_FUTURE_MUTEX (future));
+         cleanup (SCM_FUTURE (future));
+         *nextloc = next;
+       }
+    }
+}
+
+static void
+mark_futures (SCM futures)
+{
+  while (!SCM_NULLP (futures))
+    {
+      scm_gc_mark (SCM_FUTURE_DATA (futures));
+      SCM_SET_GC_MARK (futures);
+      futures = SCM_FUTURE_NEXT (futures);
+    }
+}
+
+static void *
+scan_futures (void *dummy1, void *dummy2, void *dummy3)
+{
+  SCM next, *nextloc;
+  
+  long now = scm_c_get_internal_run_time ();
+  if (now - last_switch > SCM_TIME_UNITS_PER_SECOND)
+    {
+      /* switch out old (> 1 sec), unused futures */
+      kill_futures (old);
+      old = young;
+      young = SCM_EOL;
+      last_switch = now;
+    }
+
+  next = futures;
+  nextloc = &futures;
+  while (!SCM_NULLP (next))
+    {
+      if (!SCM_GC_MARK_P (next))
+       goto free;
+    keep:
+      nextloc = SCM_FUTURE_NEXTLOC (next);
+      next = *nextloc;
+    }
+  goto exit;
+  while (!SCM_NULLP (next))
+    {
+      if (SCM_GC_MARK_P (next))
+       {
+         *nextloc = next;
+         goto keep;
+       }
+    free:
+      {
+       SCM future;
+       UNLINK (next, future);
+       LINK (young, future);
+      }
+    }
+  *nextloc = SCM_EOL;
+ exit:
+  cleanup_undead ();
+  mark_futures (young);
+  mark_futures (old);
+  mark_futures (undead);
+  return 0;
+}
+
+void
+scm_init_futures ()
+{
+  last_switch = scm_c_get_internal_run_time ();
+  
+  scm_loc_sys_thread_handler
+    = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F));
+
+  scm_tc16_future = scm_make_smob_type ("future", 0);
+  scm_set_smob_mark (scm_tc16_future, future_mark);
+  scm_set_smob_print (scm_tc16_future, future_print);
+
+  scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0);
+#include "libguile/futures.x"
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

diff --git a/libguile/futures.h b/libguile/futures.h
new file mode 100644 (file)
index 0000000..b5109dd
--- /dev/null
+++ b/libguile/futures.h
@@ -0,0 +1,100 @@
+/* classes: h_files */
+
+#ifndef SCM_FUTURES_H
+#define SCM_FUTURES_H
+
+/* Copyright (C) 2002, 2003 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/threads.h"
+
+\f
+
+typedef struct scm_t_future {
+  SCM data;
+  scm_t_mutex mutex;
+  scm_t_cond cond;
+  int status;
+  int die_p;
+} scm_t_future;
+
+#define SCM_FUTURE_DEAD 0
+#define SCM_FUTURE_SIGNAL_ME -1
+#define SCM_FUTURE_COMPUTING 1
+#define SCM_FUTURE_TASK_ASSIGNED 2
+
+#define SCM_VALIDATE_FUTURE(pos, obj) \
+  SCM_ASSERT_TYPE (SCM_TYP16_PREDICATE (scm_tc16_future, obj), \
+                  obj, pos, FUNC_NAME, "future");
+#define SCM_FUTURE(future) ((scm_t_future *) SCM_CELL_WORD_2 (future))
+#define SCM_FUTURE_MUTEX(future) (&SCM_FUTURE (future)->mutex)
+#define SCM_FUTURE_COND(future) (&SCM_FUTURE (future)->cond)
+#define SCM_FUTURE_STATUS(future) (SCM_FUTURE (future)->status)
+#define SCM_SET_FUTURE_STATUS(future, x) \
+ do { SCM_FUTURE (future)->status = (x); } while (0)
+#define SCM_FUTURE_ALIVE_P(future) (SCM_FUTURE_STATUS (future))
+#define SCM_FUTURE_DATA(future) (SCM_FUTURE (future)->data)
+#define SCM_SET_FUTURE_DATA(future, x) \
+ do { SCM_FUTURE (future)->data = (x); } while (0)
+#define SCM_FUTURE_NEXT SCM_CELL_OBJECT_1
+#define SCM_FUTURE_NEXTLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 1))
+#define SCM_SET_FUTURE_NEXT SCM_SET_CELL_OBJECT_1
+
+SCM_API scm_t_bits scm_tc16_future;
+
+extern SCM *scm_loc_sys_thread_handler;
+
+SCM_API SCM scm_i_make_future (SCM thunk);
+SCM_API SCM scm_make_future (SCM thunk);
+SCM_API SCM scm_future_ref (SCM future);
+
+void scm_init_futures (void);
+
+#endif  /* SCM_FUTURES_H */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/