1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
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.
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.
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
23 /* This whole file is not being compiled. See futures.h for the
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"
38 #include "libguile/futures.h"
40 #define LINK(list, obj) \
42 SCM_SET_FUTURE_NEXT (obj, list); \
46 #define UNLINK(list, obj) \
49 list = SCM_FUTURE_NEXT (list); \
52 scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
54 static SCM futures = SCM_EOL;
55 static SCM young = SCM_EOL;
56 static SCM old = SCM_EOL;
57 static SCM undead = SCM_EOL;
59 static long last_switch;
61 #ifdef SCM_FUTURES_DEBUG
62 static int n_dead = 0;
68 while (!scm_is_null (ls))
71 ls = SCM_FUTURE_NEXT (ls);
73 return scm_from_int (n);
76 extern SCM scm_future_cache_status (void);
78 SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0,
80 "Return a list containing number of futures, youngs, olds, undeads and deads.")
81 #define FUNC_NAME s_scm_future_cache_status
85 return scm_list_5 (count (futures),
95 SCM *scm_loc_sys_thread_handler;
97 SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0,
99 "Make a future evaluating THUNK.")
100 #define FUNC_NAME s_scm_make_future
102 SCM_VALIDATE_THUNK (1, thunk);
103 return scm_i_make_future (thunk);
107 static char *s_future = "future";
110 cleanup (scm_t_future *future)
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
121 future_loop (scm_t_future *future)
123 scm_i_scm_pthread_mutex_lock (&future->mutex);
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;
139 future_handler (scm_t_future *future, SCM key, SCM args)
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);
147 alloc_future (SCM thunk)
149 scm_t_future *f = scm_gc_malloc (sizeof (*f), s_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);
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);
160 scm_i_pthread_mutex_unlock (&future_admin_mutex);
161 scm_spawn_thread ((scm_t_catch_body) future_loop,
163 (scm_t_catch_handler) future_handler,
164 SCM_FUTURE (future));
169 kill_future (SCM future)
171 SCM_FUTURE (future)->die_p = 1;
172 LINK (undead, future);
176 scm_i_make_future (SCM thunk)
179 scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
182 if (!scm_is_null (old))
183 UNLINK (old, future);
184 else if (!scm_is_null (young))
185 UNLINK (young, future);
188 scm_i_pthread_mutex_unlock (&future_admin_mutex);
189 return alloc_future (thunk);
191 if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
192 kill_future (future);
193 else if (!SCM_FUTURE_ALIVE_P (future))
195 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
196 cleanup (SCM_FUTURE (future));
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));
211 future_mark (SCM ptr) {
212 return SCM_FUTURE_DATA (ptr);
216 future_print (SCM exp, SCM port, scm_print_state *pstate)
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);
227 SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
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"
232 #define FUNC_NAME s_scm_future_ref
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)
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));
243 if (!SCM_FUTURE_ALIVE_P (future))
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));
249 res = SCM_FUTURE_DATA (future);
250 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
256 kill_futures (SCM victims)
258 while (!scm_is_null (victims))
261 UNLINK (victims, future);
262 kill_future (future);
263 scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
270 SCM next = undead, *nextloc = &undead;
271 while (!scm_is_null (next))
273 if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next)))
275 else if (SCM_FUTURE_ALIVE_P (next))
277 scm_i_pthread_cond_signal (SCM_FUTURE_COND (next));
278 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
280 SCM_SET_GC_MARK (next);
281 nextloc = SCM_FUTURE_NEXTLOC (next);
287 UNLINK (next, future);
288 scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
289 cleanup (SCM_FUTURE (future));
296 mark_futures (SCM futures)
298 while (!scm_is_null (futures))
300 SCM_SET_GC_MARK (futures);
301 futures = SCM_FUTURE_NEXT (futures);
306 scan_futures (void *dummy1, void *dummy2, void *dummy3)
310 long now = scm_c_get_internal_run_time ();
311 if (now - last_switch > SCM_TIME_UNITS_PER_SECOND)
313 /* switch out old (> 1 sec), unused futures */
320 mark_futures (young);
324 while (!scm_is_null (next))
326 if (!SCM_GC_MARK_P (next))
329 nextloc = SCM_FUTURE_NEXTLOC (next);
333 while (!scm_is_null (next))
335 if (SCM_GC_MARK_P (next))
343 UNLINK (next, future);
344 SCM_SET_GC_MARK (future);
345 LINK (young, future);
355 scm_t_bits scm_tc16_future;
360 last_switch = scm_c_get_internal_run_time ();
362 scm_loc_sys_thread_handler
363 = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F));
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);
369 scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0);
370 #include "libguile/futures.x"