[bpt/guile.git] / libguile / futures.c

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003 Free Software Foundation, Inc.
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
 */


\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_is_null (ls))
    {
      ++n;
      ls = SCM_FUTURE_NEXT (ls);
    }
  return scm_from_int (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_from_int (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_is_null (old))
	UNLINK (old, future);
      else if (!scm_is_null (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_is_null (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_is_null (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:
	  SCM_SET_GC_MARK (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_is_null (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;
    }
  else
    mark_futures (young);    

  next = futures;
  nextloc = &futures;
  while (!scm_is_null (next))
    {
      if (!SCM_GC_MARK_P (next))
	goto free;
    keep:
      nextloc = SCM_FUTURE_NEXTLOC (next);
      next = *nextloc;
    }
  goto exit;
  while (!scm_is_null (next))
    {
      if (SCM_GC_MARK_P (next))
	{
	  *nextloc = next;
	  goto keep;
	}
    free:
      {
	SCM future;
	UNLINK (next, future);
	SCM_SET_GC_MARK (future);
	LINK (young, future);
      }
    }
  *nextloc = SCM_EOL;
 exit:
  cleanup_undead ();
  mark_futures (old);
  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:
*/
Commit	Line	Data
6b468ba4 MD	1	/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003 Free Software Foundation, Inc.
6b468ba4 MD	2	*
73be1d9e MV	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.
6b468ba4	7	*
73be1d9e MV	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.
6b468ba4	12	*
73be1d9e MV	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	*/
6b468ba4 MD	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;
d2e53ed6	58	while (!scm_is_null (ls))
6b468ba4 MD	59	{
	60	++n;
	61	ls = SCM_FUTURE_NEXT (ls);
	62	}
e11e83f3	63	return scm_from_int (n);
6b468ba4 MD	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),
e11e83f3	79	scm_from_int (nd));
6b468ba4 MD	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	{
d2e53ed6	172	if (!scm_is_null (old))
6b468ba4	173	UNLINK (old, future);
d2e53ed6	174	else if (!scm_is_null (young))
6b468ba4 MD	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	{
d2e53ed6	247	while (!scm_is_null (victims))
6b468ba4 MD	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;
d2e53ed6	260	while (!scm_is_null (next))
6b468ba4 MD	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:
361d631f	269	SCM_SET_GC_MARK (next);
6b468ba4 MD	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	{
d2e53ed6	287	while (!scm_is_null (futures))
6b468ba4	288	{
6b468ba4 MD	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	}
361d631f MD	308	else
361d631f MD	309	mark_futures (young);
6b468ba4 MD	310
	311	next = futures;
	312	nextloc = &futures;
d2e53ed6	313	while (!scm_is_null (next))
6b468ba4 MD	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;
d2e53ed6	322	while (!scm_is_null (next))
6b468ba4 MD	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);
361d631f	333	SCM_SET_GC_MARK (future);
6b468ba4 MD	334	LINK (young, future);
	335	}
	336	}
	337	*nextloc = SCM_EOL;
	338	exit:
	339	cleanup_undead ();
6b468ba4	340	mark_futures (old);
6b468ba4 MD	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	*/